/*  You guessed it - another wiztool. This one is programmable in Lisp.
 *  Padrone (Thomas Padron-McCarthy, padrone@lysator.liu.se)
 *  Share and enjoy!
 *  Latest change of this file: Sept 3, 1993
 */

#define TOOLVERSION	"0.8.1, Sept 3, 1993"

#include "/players/padrone/padconfig.h"

#pragma strict_types

inherit "players/padrone/inherit/basic_object";
inherit "players/padrone/inherit/smartwrite";
inherit "players/padrone/inherit/smartpresent";
inherit "players/padrone/inherit/describe_object";

/*---------------------------------------------------------------------------*/

/*
#define catch(whatever)		((whatever), 0)
#define DEBUG_READ(str)		write(str + "\n")
#define DEBUG_EVAL(str)		write(str + "\n")
*/
#define DEBUG_READ(str)		0
#define DEBUG_EVAL(str)		0

/*---------------------------------------------------------------------------*/

/*  Data objects are stored using the LISPID data type.
 *  It's just #defined as "mixed", but there are some conventions:
 *  
 *  A symbol has id 0...MAX_ARRAY_SIZE-1 (0...999). NIL is 0.
 *  A cons cell has id MAX_ARRAY_SIZE...2*MAX_ARRAY_SIZE-1 (1000...1999).
 *  The offset must be subtracted before indexing
 *  the arrays of car's and cdr's.
 *  An integer has id ...-1 or 2*MAX_ARRAY_SIZE... (...-1 or 2000...).
 *  The offset must be subtracted, if the integer is positive,
 *  before it is used.
 *  Strings and objects are stored as themselves.
 *  There are no arrays, but lists are converted to arrays in calls to LPC,
 *  and vice versa.
 *  Mappings are not handled at all, yet, and can cause troubles of any kind.
 */

/*---------------------------------------------------------------------------*/

/* Some definitions for the lisp tool. */

#define NIL		0
#define T		1
#define BUILTIN		2
#define BUILTIN_NOEVAL	3
#define UNBOUND		4
#define LAMBDA		5
#define NLAMBDA		6
#define QUOTE		7
#define SETQ		8
#define DEFUN		9
#define DEFMACRO	10
#define CAR		11
#define CDR		12
#define CONS		13
#define LENGTH		14
#define EVAL		15
#define APPLY		16
#define PRINT		17
#define SET		18
#define NTH		19
#define MEMBER		20
#define MAP		21
#define COND		22
#define IF		23
#define EQUAL		24
#define PLUS		25
#define MINUS		26
#define TIMES		27
#define DIVISION	28
#define COPY		29
#define GARB		30
#define LIST		31
#define X7		32
#define X8		33
#define X9		34
#define IT		35
#define ME		36
#define VERSION_ID	37
#define CLONE		38
#define LOAD		39
#define DESTRUCT	40
#define CALL		41
#define MOVE		42
#define INV		43
#define ENV		44
#define PRESENT		45
#define FIND_LIVING	46
#define FIND_OBJECT	47
#define FIND		48
#define SAY		49
#define TELL		50
#define WRITE		51
#define GET_DIR		52
#define USERS		53
#define CATCH		54
#define THROW		55
#define SSCANF		56
#define CREATOR		57
#define STATUS		58
#define SILENT		59
#define PERSISTENT	60
#define CAAR		61
#define CADR		62
#define CDAR		63
#define CDDR		64
#define SMARTPRESENT	65
#define FIRST_USER_DEFINED_SYMBOL	66

#define IS_SYMBOL(id)	(intp(id) && (id) >= 0 && ((id) - SYMBOL_OFFSET) < sizeof(symbol_names))
#define IS_CONS(id)	(intp(id) && (id) >= CONS_OFFSET && ((id) - CONS_OFFSET) < sizeof(cons_cars))
#define IS_INTEGER(id)	(intp(id) && ((id) < 0 || (id) >= INTEGER_OFFSET))
#define IS_STRING(id)	(stringp(id))
#define IS_OBJECT(id)	(objectp(id))

#define SYMBOL_OFFSET		0
#define CONS_OFFSET		MAX_ARRAY_SIZE
#define INTEGER_OFFSET		(2*MAX_ARRAY_SIZE)

#define LISPID		mixed

#define LISP_ERROR(str)	(throw((str) + "\n"))

LISPID get_symbol_value(LISPID id);
LISPID length_int(LISPID id);

void angry_beep() {
    object tp;
    tp = this_player();
    if (tp && get_symbol_value(SILENT) == NIL) {
	say("The staff beeps angrily, and " +
	    tp->query_name() + " looks disappointed.\n");
    }
} /* angry_beep */

#define CHECK_SYMBOL(fun, pos, arg)	\
    (!IS_SYMBOL(arg) ?	\
	LISP_ERROR("Arg " + pos + " to " + fun + " must be a symbol: " + lispid2string(arg)) : 0)
#define CHECK_CONS(fun, pos, arg)	\
    (!IS_CONS(arg) ?	\
        LISP_ERROR("Arg " + pos + " to " + fun + " must be a list: " + lispid2string(arg)) : 0)
#define CHECK_INTEGER(fun, pos, arg)	\
    (!IS_INTEGER(arg) ?	\
	LISP_ERROR("Arg " + pos + " to " + fun + " must be an integer: " + lispid2string(arg)) : 0)
#define CHECK_STRING(fun, pos, arg)	\
    (!IS_STRING(arg) ?	\
	LISP_ERROR("Arg " + pos + " to " + fun + " must be a string: " + lispid2string(arg)) : 0)
#define CHECK_OBJECT(fun, pos, arg)	\
    (!IS_OBJECT(arg) ?	\
	LISP_ERROR("Arg " + pos + " to " + fun + " must be an object: " + lispid2string(arg)) : 0)
#define CHECK_STRING_OR_OBJECT(fun, pos, arg)	\
    (!IS_STRING(arg) && !IS_OBJECT(arg) ?	\
	LISP_ERROR("Arg " + pos + " to " + fun + " must be a string or an object: " + lispid2string(arg)) : 0)

#define CHECK_WIZARD(fun)	\
    (this_player() && this_player()->query_level() < WIZARD_LEVEL ?	\
	LISP_ERROR("The function " + fun + " is only available to wizards") : 0)

void CHECK_ARGS(string fun, int required_args, LISPID args) {
    int nrargs;
    nrargs = length_int(args);
    if (nrargs != required_args)
	LISP_ERROR("The function " + fun + " takes " + required_args + " argument" + ((required_args == 1) ? "" : "s") + ", not " + nrargs);
} /* CHECK_ARGS */

void CHECK_ARGS_RANGE(string fun, int minargs, int maxargs, LISPID args) {
    int nrargs;
    nrargs = length_int(args);
    if (nrargs < minargs || nrargs > maxargs)
	LISP_ERROR("The function " + fun + " takes " + minargs + "-" + maxargs + " arguments, not " + nrargs);
} /* CHECK_ARGS_RANGE */

/* NYI in LPC (grr!): '\t' and '\n' */
#define IS_BLANK(c)		((c) == ' ' || (c) == 9 || (c) == 10)
#define IS_DIGIT(c)		((c) >= '0' && (c) <= '9')

/*
#define VALID_FIRST_SYMBOL_CHAR(c)	(((c) >= 'a' && (c) <= 'z') || ((c) == '_') || ((c) >= 'A' && (c) <= 'Z'))
#define VALID_SYMBOL_CHAR(c)		(VALID_FIRST_SYMBOL_CHAR(c) || IS_DIGIT(c))
*/

#define VALID_FIRST_SYMBOL_CHAR(c)	(!IS_BLANK(c) && (c) != '(' && (c) != ')' && (c) != '"')
#define VALID_SYMBOL_CHAR(c)		(VALID_FIRST_SYMBOL_CHAR(c))

/*---------------------------------------------------------------------------*/

string lispid2string(LISPID id);
LISPID print(LISPID id);
int integer_id2int(LISPID id);
#define integer_int2id(val)	(((val) < 0) ? (val) : (val) + INTEGER_OFFSET)
LISPID convert_lpc2lisp(mixed something);
LISPID apply(LISPID fun, LISPID args, LISPID evalenv);
LISPID eval(LISPID id, LISPID evalenv);

/*---------------------------------------------------------------------------*/

/* Functions to handle symbols, and the data structures to store them */

string *symbol_names;
LISPID *symbol_values;

int symbol_name2id(string var) {
    int i;
    i = member_array(lower_case(var), symbol_names);
    if (i == -1) {
	symbol_names += ({ var });
	symbol_values += ({ UNBOUND });
	return sizeof(symbol_names) - 1 + SYMBOL_OFFSET;
    }
    else
	return i + SYMBOL_OFFSET;
} /* symbol_name2id */

string symbol_id2name(LISPID id) {
    if (!IS_SYMBOL(id)) {
	LISP_ERROR("Tried to get symbol name of non-symbol: " + lispid2string(id));
    }
    return symbol_names[id];
} /* symbol_id2name */

void set_symbol_name(string var, mixed val) {
    int id;
    id = symbol_name2id(var);
    symbol_values[id - SYMBOL_OFFSET] = val;
} /* set_symbol_name */

#if 0
/* Doesn't work - you can't change the array from its index expression! */
#define set_symbol_name(var, val)	\
	(symbol_values[symbol_name2id(var) - SYMBOL_OFFSET] = (val))
#endif

void set_symbol_value(LISPID id, mixed val) {
    if (!IS_SYMBOL(id)) {
	LISP_ERROR("Tried to set symbol value of non-symbol: " + lispid2string(id));
    }
    symbol_values[id - SYMBOL_OFFSET] = val;
} /* set_symbol_value */

LISPID get_symbol_value(LISPID id) {
    if (!IS_SYMBOL(id)) {
	LISP_ERROR("Tried to get symbol value of non-symbol: " + lispid2string(id));
    }
    if ((id == ME || id == IT) && this_player() && this_player()->query_level() < WIZARD_LEVEL)
	LISP_ERROR("The variable " + lispid2string(id) + " is only available to wizards");
    return symbol_values[id - SYMBOL_OFFSET];
} /* get_symbol_value */

/*---------------------------------------------------------------------------*/

/* Functions to handle cons lists, and the data structures to store them */

LISPID *cons_cars, *cons_cdrs;

LISPID cons(LISPID car, LISPID cdr) {
    int i;

    if (sizeof(cons_cars) == MAX_ARRAY_SIZE)
	LISP_ERROR("No more cons cells - try (garb)");

    cons_cars += ({ car });
    cons_cdrs += ({ cdr });
    return sizeof(cons_cdrs) - 1 + CONS_OFFSET;
} /* cons */

LISPID car(LISPID id) {
    CHECK_CONS("car", 1, id);
    return cons_cars[id - CONS_OFFSET];
} /* car */

LISPID cdr(LISPID id) {
    CHECK_CONS("cdr", 1, id);
    return cons_cdrs[id - CONS_OFFSET];
} /* cdr */

#if 0
/* This turned out not to be such a good idea. */
#define car(id) (CHECK_CONS("car", 1, (id)), cons_cars[(id) - CONS_OFFSET])
#define cdr(id) (CHECK_CONS("car", 1, (id)), cons_cdrs[(id) - CONS_OFFSET])
#endif

#define rplaca(cellid, valueid)	\
    (cons_cars[(cellid) - CONS_OFFSET] = (valueid))
#define rplacd(cellid, valueid)	\
    (cons_cdrs[(cellid) - CONS_OFFSET] = (valueid))

LISPID length_int(LISPID id) {
    int len;
    if (id != NIL)
	CHECK_CONS("length", 1, id);
    len = 0;
    while (id != NIL) {
	++len;
	id = cdr(id);
    }
    return len;
} /* length_int */

#if 0
LISPID length_id(LISPID id) {
    return integer_int2id(length_int(id));
} /* length_id */
#endif

#define length_id(id) (integer_int2id(length_int(id)))

LISPID nth(LISPID id1, LISPID id2) {
    int i, n;
    CHECK_INTEGER("nth", 1, id1);
    CHECK_CONS("nth", 2, id2);
    n = integer_id2int(id1);
    for (i = 0; i < n; ++i) {
	id2 = cdr(id2);
    }
    return car(id2);
} /* nth */

LISPID member(LISPID id1, LISPID id2) {
    CHECK_CONS("member", 2, id2);
    while (id2 != NIL) {
	if (id1 == car(id2))
	    return id2;
	id2 = cdr(id2);
    }
    return NIL;
} /* member */

LISPID copy(LISPID id) {
    LISPID head, p, p2;

    if (id == NIL)
	return NIL;
    CHECK_CONS("copy", 1, id);
    head = cons(car(id), cdr(id));
    p = head;
    id = cdr(id);
    while (id != NIL) {
	p2 = cons(car(id), NIL);
	rplacd(p, p2);
	p = p2;
	id = cdr(id);	
    }
    return head;
} /* copy */

LISPID last(LISPID id) {
    LISPID id2;

    if (id == NIL)
	return NIL;
    CHECK_CONS("last", 1, id);

    id2 = id;
    while (id != NIL) {
	id2 = id;
	id = cdr(id);	
    }
    return id2;
} /* last */

/*---------------------------------------------------------------------------*/

/* Usually called mapcar, but since I only have one map function... */

LISPID map(LISPID id1, LISPID id2, LISPID evalenv) {
    LISPID head, p, p2;

    DEBUG_EVAL(">MAP: " + lispid2string(id1) + ", " + lispid2string(id2));

    if (id2 == NIL)
	return NIL;
    CHECK_CONS("map", 2, id2);
    head = cons(apply(id1, cons(car(id2), NIL), evalenv), NIL);
    p = head;
    id2 = cdr(id2);
    while (id2 != NIL) {
	p2 = cons(apply(id1, cons(car(id2), NIL), evalenv), NIL);
	rplacd(p, p2);
	p = p2;
	id2 = cdr(id2);	
    }
    return head;
} /* map */

/*---------------------------------------------------------------------------*/

/* Functions to handle evaluation environments, used by eval */
/* A binding is never changed in this Lisp, just added. */

LISPID add_binding(LISPID evalenv, LISPID sym, LISPID val) {
    return cons(cons(sym, val), evalenv);
}

LISPID find_binding(LISPID sym, LISPID evalenv) {
    LISPID this_pair;
    while (evalenv != NIL) {
	this_pair = car(evalenv);
	if (sym == car(this_pair))
	    return cdr(this_pair);
	evalenv = cdr(evalenv);
    }
    return UNBOUND;
} /* find_binding */

/* Adds new bound variables to the "parent" environment */
LISPID build_evalenv(LISPID syms, LISPID vals, LISPID parent) {
    LISPID sym, val, this_pair;
    while (syms != NIL) {
	sym = car(syms);
	if (vals != NIL)
	    val = car(vals);
	else
	    val = NIL;
	parent = cons(cons(sym, val), parent);
	syms = cdr(syms);
	if (vals != NIL)
	    vals = cdr(vals);
    }
    return parent;
} /* build_evalenv */

/*---------------------------------------------------------------------------*/

/* Functions to convert data between Lisp and LPC */
/* integer_int2id() is a macro, defined at the beginning of the file */

int integer_id2int(LISPID id) {
    if (!IS_INTEGER(id)) {
	LISP_ERROR("Tried to get int value of non-int: " + lispid2string(id));
	return 0;
    }
    if (id < 0)
	return id;
    else
	return id - INTEGER_OFFSET;
} /* integer_id2int */

LISPID array2list(mixed *arr) {
    int i, n;
    LISPID head, p, p2;

    if (!arr)
	return NIL;
    n = sizeof(arr);
    if (n == 0)
	return NIL;
    head = cons(convert_lpc2lisp(arr[0]), NIL);
    p = head;
    for (i = 1; i < n; ++i) {
	p2 = cons(convert_lpc2lisp(arr[i]), NIL);
	rplacd(p, p2);
	p = p2;
    }
    return head;
} /* array2list */

mixed *list2array(LISPID id) {
    int i, n;
    mixed *res;

    res = ({ });
    if (id == NIL)
	return  res;
    n = length_int(id);
    for (i = 0; i < n; ++i) {
	res += ({ car(id) });
	id = cdr(id);
    }
    return res;
} /* list2array */

mixed convert_lisp2lpc(LISPID id) {
    if (id == NIL)
	return 0;
    else if (IS_SYMBOL(id))
	return symbol_names[id - SYMBOL_OFFSET];
    else if (IS_CONS(id))
	return list2array(id);
    else if (IS_INTEGER(id))
	return integer_id2int(id);
    else if (IS_STRING(id) || IS_OBJECT(id))
	return id;
    else
	LISP_ERROR("Tried to convert illegal id: " + smartwritestring(id));
} /* convert_lisp2lpc */

LISPID convert_lpc2lisp(mixed something) {
    if (intp(something))
	return integer_int2id(something);
    else if (pointerp(something))
	return array2list(something);
    else
	return something;
} /* convert_lpc2lisp */

/*---------------------------------------------------------------------------*/

/* A function to initialize the data structures, called from reset(0) */

void init_data() {
    symbol_names = ({ "nil", "t", "#builtin-function#", "#builtin-noeval-function#", "#unbound#",
		      "lambda", "nlambda", "quote", "setq", "defun",
		      "defmacro", "car", "cdr", "cons", "length",
		      "eval", "apply", "print", "set", "nth",
		      "member", "map", "cond", "if", "=",
		      "+", "-", "*", "/", "copy",
	              "garb", "list", "x7", "x8", "x9",
		      "it", "me", "version", "clone", "load",
		      "destruct", "call", "move", "inv", "env",
		      "present", "find_living", "find_object", "find!", "say",
	              "tell", "write", "get_dir", "users", "catch",
                      "throw", "sscanf", "creator", "status", "silent",
		      "persistent", "caar", "cadr", "cdar", "cddr",
		      "smartpresent" });
    symbol_values = ({ NIL, T, UNBOUND, UNBOUND, UNBOUND,
		       BUILTIN, BUILTIN, BUILTIN_NOEVAL, BUILTIN_NOEVAL, BUILTIN_NOEVAL,
		       BUILTIN_NOEVAL, BUILTIN, BUILTIN, BUILTIN, BUILTIN,
		       BUILTIN, BUILTIN, BUILTIN, BUILTIN, BUILTIN,
		       BUILTIN, BUILTIN, BUILTIN_NOEVAL, BUILTIN_NOEVAL, BUILTIN,
		       BUILTIN, BUILTIN, BUILTIN, BUILTIN, BUILTIN,
		       BUILTIN, BUILTIN, BUILTIN, BUILTIN, BUILTIN,
		       this_object(), NIL, TOOLVERSION, BUILTIN, BUILTIN,
		       BUILTIN, BUILTIN, BUILTIN, BUILTIN, BUILTIN,
		       BUILTIN, BUILTIN, BUILTIN, BUILTIN, BUILTIN,
		       BUILTIN, BUILTIN, BUILTIN, BUILTIN, BUILTIN_NOEVAL,
		       BUILTIN, BUILTIN, BUILTIN, BUILTIN, NIL,
		       NIL, BUILTIN, BUILTIN, BUILTIN, BUILTIN,
		       BUILTIN });
    cons_cars = ({ });
    cons_cdrs = ({ });
} /* init_data */

/*---------------------------------------------------------------------------*/

/* When an error occurs, throw away all temporary results */

LISPID rollback_nr_symbols, rollback_nr_conses;

static void set_rollback() {
    rollback_nr_symbols = sizeof(symbol_names) - 1;
    rollback_nr_conses = sizeof(cons_cars) - 1;
} /* set_rollback */

static void rollback() {
    /* write("LISP: Rollback...\n"); */
    symbol_names = symbol_names[0..rollback_nr_symbols];
    symbol_values = symbol_values[0..rollback_nr_symbols];
    cons_cars = cons_cars[0..rollback_nr_conses];
    cons_cdrs = cons_cdrs[0..rollback_nr_conses];
} /* rollback */

/*---------------------------------------------------------------------------*/

/* Garbage collection */

LISPID *symbol_marks, *cons_marks;

static void mark(LISPID id) {
    int i;

    if (IS_SYMBOL(id)) {
	i = id - SYMBOL_OFFSET;
	if (symbol_marks[i] != -1)
	    return;
	symbol_marks[i] = 1;
	mark(symbol_values[i]);
    }
    else if (IS_CONS(id)) {
	if (cons_marks[id - CONS_OFFSET] != -1)
	    return;
	while (IS_CONS(id) && cons_marks[id - CONS_OFFSET] == -1) {
	    i = id - CONS_OFFSET;
	    cons_marks[i] = 1;
	    mark(cons_cars[i]);
	    id = cdr(id);
	}
	if (id != NIL)
	    mark(id);	/* Last dotted pair */
    }
} /* mark */

LISPID garb() {
    int i, n, new_i, nr_new_symbols, nr_new_conses;
    LISPID id;

    if (get_symbol_value(SILENT) == NIL)
	say(this_player()->query_name() +
	    "'s magic staff starts collecting internal garbage...\n");
    write("Your magic staff starts collecting internal garbage...\n");

    symbol_marks = allocate(sizeof(symbol_names));
    cons_marks = allocate(sizeof(cons_cars));

    n = sizeof(symbol_names);
    for (i = 0; i < n; ++i)
	symbol_marks[i] = -1;
    n = sizeof(cons_cars);
    for (i = 0; i < n; ++i)
	cons_marks[i] = -1;

    write("Marking used data...\n");
    n = sizeof(symbol_names);
    for (i = 0; i < n; ++i) {
	id = symbol_values[i];
	if (id != UNBOUND && symbol_marks[i] == -1) {
	    symbol_marks[i] = 1;
	    mark(id);
	}
    }

/*
    write("symbol_marks = "); smartwrite(symbol_marks); write("\n");
    write("cons_marks = "); smartwrite(cons_marks); write("\n");
*/

    write("Compacting data and finding new Lisp ids...\n");

    n = sizeof(symbol_names);
    new_i = 0;
    for (i = 0; i < n; ++i)
	if (symbol_marks[i] != -1) {
	    symbol_marks[i] = new_i + SYMBOL_OFFSET;
	    symbol_names[new_i] = symbol_names[i];
	    symbol_values[new_i] = symbol_values[i];
	    ++new_i;
	}
    nr_new_symbols = new_i;

    write("Symbols shrunk from " + n + " to " + nr_new_symbols + "\n");

    n = sizeof(cons_cars);
    new_i = 0;
    for (i = 0; i < n; ++i)
	if (cons_marks[i] != -1) {
	    cons_marks[i] = new_i + CONS_OFFSET;
	    cons_cars[new_i] = cons_cars[i];
	    cons_cdrs[new_i] = cons_cdrs[i];
	    ++new_i;
	}
    nr_new_conses = new_i;

/*
    write("symbol_marks = "); smartwrite(symbol_marks); write("\n");
    write("symbol_names = "); smartwrite(symbol_names); write("\n");
    write("symbol_values = "); smartwrite(symbol_values); write("\n");
    write("cons_marks = "); smartwrite(cons_marks); write("\n");
    write("cons_cars = "); smartwrite(cons_cars); write("\n");
    write("cons_cdrs = "); smartwrite(cons_cdrs); write("\n");
*/

    write("Conses shrunk from " + n + " to " + nr_new_conses + "\n");

    write("Changing old Lisp ids...\n");

    for (i = 0; i < nr_new_symbols; ++i) {
	id = symbol_values[i];
	if (IS_SYMBOL(id))
	    symbol_values[i] = symbol_marks[id - SYMBOL_OFFSET];
	else if (IS_CONS(id))
	    symbol_values[i] = cons_marks[id - CONS_OFFSET];
    }

    for (i = 0; i < nr_new_conses; ++i) {
	id = cons_cars[i];
	if (IS_SYMBOL(id)) {
	    cons_cars[i] = symbol_marks[id - SYMBOL_OFFSET];
	}
	else if (IS_CONS(id))
	    cons_cars[i] = cons_marks[id - CONS_OFFSET];
	id = cons_cdrs[i];
	if (IS_SYMBOL(id))
	    cons_cdrs[i] = symbol_marks[id - SYMBOL_OFFSET];
	else if (IS_CONS(id))
	    cons_cdrs[i] = cons_marks[id - CONS_OFFSET];
    }

    symbol_names = symbol_names[0..nr_new_symbols-1];
    symbol_values = symbol_values[0..nr_new_symbols-1];
    cons_cars = cons_cars[0..nr_new_conses-1];
    cons_cdrs = cons_cdrs[0..nr_new_conses-1];

/*
    write("symbol_marks = "); smartwrite(symbol_marks); write("\n");
    write("cons_marks = "); smartwrite(cons_marks); write("\n");
*/

    symbol_marks = 0;
    cons_marks = 0;

    if (get_symbol_value(SILENT) == NIL)
	say(this_player()->query_name() +
	    "'s staff has finished garbage collecting.\n");
    write("The staff has finished garbage collecting.\n");

    return NIL;
} /* garb */

/*---------------------------------------------------------------------------*/

/* The print function */

string lispid2string(LISPID id) {
    string result;
    string nlrest, nlpart;

    if (IS_SYMBOL(id))
	return symbol_names[id - SYMBOL_OFFSET];
    else if (IS_CONS(id)) {
	result = "(";
	while (id != NIL && IS_CONS(id)) {
	    result += lispid2string(car(id));
	    id = cdr(id);
	    if (id != NIL)
		result += " ";
	}
	if (id != NIL) {
	    result += ". ";
	    result += lispid2string(id);
	}
	return result + ")";
    }
    else if (IS_INTEGER(id))
	return "" + (integer_id2int(id));
    else if (IS_STRING(id)) {
	nlrest = id;
	id = "";
	while (nlrest) {
	    if (sscanf(nlrest, "%s\n%s", nlpart, nlrest) != 2) {
		id += nlrest;
		nlrest = 0;
	    }
	    else
		id += nlpart + "\\n";
	}
	return "\"" + id + "\"";
    }
    else if (IS_OBJECT(id))
	return "OBJ(" + file_name(id) + ")";
        /* return "#object#" + file_name(id) + "#"; */
    else {
	LISP_ERROR("Tried to print illegal id: " + smartwritestring(id));
    }
    return id;
} /* lispid2string */

LISPID print(LISPID id) {
    write(lispid2string(id));
    return id;
} /* print */

/*---------------------------------------------------------------------------*/

/* Some built-in standard functions */

LISPID plus (LISPID args) {
    LISPID res, e;

    if (args == NIL)
	return 0;
    res = car(args);
    args = cdr(args);
    while (args != NIL) {
	e = car(args);
	if (res == NIL && e == NIL) {
	    /* res = NIL; */
	}
	else if (IS_CONS(res) || IS_CONS(e)) {
	    if (IS_CONS(res) && IS_CONS(e)) {
		res = copy(res);
		rplacd(last(res), e);
	    }
	    else if (res == NIL)
		res = e;
	    else if (e == NIL) {
		/* res = res; */
	    }
	    else
		LISP_ERROR("Incompatible add: " + lispid2string(res) + " + " + lispid2string(e));
	}
	else if (IS_STRING(e))
	    res = convert_lpc2lisp(convert_lisp2lpc(res) + convert_lisp2lpc(e));
	else if (IS_INTEGER(e))
	    res = convert_lpc2lisp(convert_lisp2lpc(res) + convert_lisp2lpc(e));
	else
	    LISP_ERROR("Incompatible add: " + lispid2string(res) + " + " + lispid2string(e));
	args = cdr(args);
    }
    return res;
} /* plus */

LISPID minus (LISPID id1, LISPID id2) {
    CHECK_INTEGER("minus", 1, id1);
    CHECK_INTEGER("minus", 2, id2);
    return integer_int2id(integer_id2int(id1) - integer_id2int(id2));
} /* minus */

LISPID times (LISPID id1, LISPID id2) {
    CHECK_INTEGER("times", 1, id1);
    CHECK_INTEGER("times", 2, id2);
    return integer_int2id(integer_id2int(id1) * integer_id2int(id2));
} /* times */

LISPID division (LISPID id1, LISPID id2) {
    CHECK_INTEGER("division", 1, id1);
    CHECK_INTEGER("division", 2, id2);
    return integer_int2id(integer_id2int(id1) / integer_id2int(id2));
} /* division */

/*---------------------------------------------------------------------------*/

LISPID equal (LISPID id1, LISPID id2) {
    return id1 == id2;
} /* equal */

LISPID cond (LISPID args, LISPID evalenv) {
    LISP_ERROR("NYI: cond");
} /* cond */

/*---------------------------------------------------------------------------*/

LISPID f_if (LISPID args, LISPID evalenv) {
    LISPID r, clause, path1, path2;
    int nrargs;

    nrargs = length_int(args);
    if (nrargs == 2) {
	clause = car(args);
	path1 = car(cdr(args));
	path2 = NIL;
    }
    else if (nrargs == 3) {
	clause = car(args);
	path1 = car(cdr(args));
	path2 = car(cdr(cdr(args)));
    }
    /* else LISP_ERROR("Wrong number of arguments to if"); -- already checked in apply */
    if (eval(clause, evalenv) != NIL)
	return eval(path1, evalenv);
    else if (path2)
	return eval(path2, evalenv);
    else
	return NIL;
} /* f_if */

/*---------------------------------------------------------------------------*/

/* The read function */

string original_string, rest;

static LISPID read1();

static void skip_leading_blanks() {
    int i;
    i = 0;
    while (i < strlen(rest) && IS_BLANK(rest[i]))
	++i;
    if (i == strlen(rest)) {
	LISP_ERROR("Missing right parenthesis");
    }
    else if (i)
	rest = rest[i..strlen(rest)-1];
} /* skip_leading_blanks */

static void skip_trailing_blanks() {
    int j;
    j = strlen(rest) - 1;
    while (j > 0 && IS_BLANK(rest[j]))
	--j;
    if (j == -1) {
	LISP_ERROR("Missing right parenthesis");
    }
    else if (j != strlen(rest) - 1)
	rest = rest[0..j];
} /* skip_trailing_blanks */

static LISPID readlist() {
    LISPID head, p, p2;

    DEBUG_READ(">READLIST: '" + rest + "'");

    skip_leading_blanks();	/* Also checks for empty string! */
    if (rest[0] == ')') {
	rest = rest[1..strlen(rest)-1];
	return NIL;
    }
    head = cons(read1(), NIL);
    p = head;
    while (skip_leading_blanks(), rest[0] != ')') {
	DEBUG_READ("READLIST: '" + rest + "'");
	p2 = cons(read1(), NIL);
	rplacd(p, p2);
	p = p2;
    }
    rest = rest[1..strlen(rest)-1];
    DEBUG_READ("READLIST returns " + lispid2string(head) + ", rest = '" + rest + "'");
    return head;
} /* readlist */

static LISPID readquote() {
    LISPID start_cons, this_cons, this_car;

    DEBUG_READ(">READQUOTE: '" + rest + "'");

    skip_leading_blanks();

    DEBUG_READ("READQUOTE: '" + rest + "'");

    return cons(QUOTE, cons(read1(), NIL));
} /* readquote */

static LISPID read1() {
    string the_string, the_symbol, nlrest, nlpart;
    int the_integer;
    object the_object;
    int i, j, sscanf_res;

    DEBUG_READ(">READ1: '" + rest + "'");

    skip_leading_blanks();

    if (rest[0] == '\"') {
	sscanf(rest, "\"%s", rest);
	if (sscanf(rest, "%s\"%s", the_string, rest) != 2) {
	    LISP_ERROR("Unfinished string: " + smartwritestring(the_string));
	}
	DEBUG_READ("READ1: STRING: '" + the_string + "', REST = '" + rest + "'");
	nlrest = the_string;
	the_string = "";
	while (nlrest) {
	    if (sscanf(nlrest, "%s\\n%s", nlpart, nlrest) != 2) {
		the_string += nlrest;
		nlrest = 0;
	    }
	    else
		the_string += nlpart + "\n";
	}
	return the_string;
    }

    if (sscanf(rest, "%d%s", the_integer,  rest) == 2) {
	DEBUG_READ("READ1: INTEGER: '" + the_integer + "', REST = '" + rest + "'");
	return integer_int2id(the_integer);
    }

    if (rest[0] == '(') {
	sscanf(rest, "(%s", rest);
	return readlist();
    }

    if (rest[0] == '\'') {
	sscanf(rest, "'%s", rest);
	return readquote();
    }

    if (rest[0] == ')') {
	LISP_ERROR("Extra right parenthesis: " + smartwritestring(rest));
    }

    if (sscanf(rest, "OBJ(%s)%s", the_string,  rest) == 2) {
	the_string = the_string;
	the_object = find_object(the_string);
	if (the_object)
	    DEBUG_READ("READ1: OBJECT: '" + the_string + "' (found), REST = '" + rest + "'");
	else
	    DEBUG_READ("READ1: OBJECT: '" + the_string + "' (not found), REST = '" + rest + "'");
	return the_object;
    }

    if (VALID_FIRST_SYMBOL_CHAR(rest[0])) {
	i = 1;
	while (i < strlen(rest) && VALID_SYMBOL_CHAR(rest[i]))
	    ++i;
	if (i == strlen(rest)) {
	    the_symbol = rest;
	    rest = "";
	}
	else {
	    the_symbol = rest[0..i-1];
	    rest = rest[i..strlen(rest)];
	}
	DEBUG_READ("READ1: SYMBOL: '" + the_symbol + "', REST = '" + rest + "'");
	return symbol_name2id(the_symbol);
    }

    LISP_ERROR("Malformed token: " + smartwritestring(rest));
} /* read1 */

LISPID read(string str) {
    int i, j;
    LISPID retval;
    string errstr;

    DEBUG_READ(">READ: '" + str + "'");

    original_string = str;
    rest = str;

    skip_leading_blanks();
    skip_trailing_blanks();

    set_rollback();

    if ((errstr = catch(retval = read1())) != 0) {
	write("LISP ERROR in read: " + errstr);
	angry_beep();
	rollback();
	return UNBOUND;
    }
    else if (rest != "") {
	write("LISP ERROR in read: Junk after expression: '" + rest + "'\n");
	angry_beep();
	rollback();
	return UNBOUND;
    }

/*
    write("READ: Finished reading, REST = '" + rest + "'\n");
    write("READ: retval = ");
    print(retval);
    write("\n");
*/

    return retval;
} /* read */

/*---------------------------------------------------------------------------*/

/* Mud-specific functions */

LISPID f_clone(LISPID what) {
    object res;

    CHECK_STRING("clone", 1, what);
    CHECK_WIZARD("clone");

    res = clone_object(what);
    if (res->get())
	move_object(res, this_player());
    else
	move_object(res, environment(this_player()));
    set_symbol_value(IT, res);
    return res;
} /* f_clone */

LISPID f_load(LISPID what) {
    object res;

    CHECK_STRING("load", 1, what);
    CHECK_WIZARD("load");
    call_other(what, "fiberoptiksvan");
    res = find_object(what);
    if (res)
	set_symbol_value(IT, res);
    return res;
} /* f_load */

LISPID f_destruct(LISPID what) {
    CHECK_OBJECT("destruct", 1, what);
    CHECK_WIZARD("destruct");
    destruct(what);
    return what;
} /* f_destruct */

LISPID f_call(LISPID obj, LISPID fun, LISPID args) {
    int i, nrargs;
    mixed arg1, arg2, arg3, arg4, arg5, arg6, arg7, arg8, arg9, arg10;
    mixed res;

    CHECK_STRING_OR_OBJECT("call", 1, obj);
    if (!IS_STRING(fun) && !IS_SYMBOL(fun))
	LISP_ERROR("Arg 2 to call must be a string or a symbol: " + lispid2string(fun));
    CHECK_WIZARD("call");

    if (args == NIL)
	nrargs = 0;
    else
	nrargs = length_int(args);
    if (nrargs > 10)
	LISP_ERROR("Max arguments to call is 10 - you tried " + nrargs);
    for (i = 0; i < nrargs; ++i) {
	switch (i) {
	  case 0: arg1 = convert_lisp2lpc(car(args)); break;
	  case 1: arg2 = convert_lisp2lpc(car(args)); break;
	  case 2: arg3 = convert_lisp2lpc(car(args)); break;
	  case 3: arg4 = convert_lisp2lpc(car(args)); break;
	  case 4: arg5 = convert_lisp2lpc(car(args)); break;
	  case 5: arg6 = convert_lisp2lpc(car(args)); break;
	  case 6: arg7 = convert_lisp2lpc(car(args)); break;
	  case 7: arg8 = convert_lisp2lpc(car(args)); break;
	  case 8: arg9 = convert_lisp2lpc(car(args)); break;
	  case 9: arg10 = convert_lisp2lpc(car(args)); break;
	}
	args = cdr(args);
    }
    res = convert_lpc2lisp(call_other(obj, convert_lisp2lpc(fun),
				      arg1, arg2, arg3, arg4, arg5, arg6, arg7, arg8, arg9, arg10));
    set_symbol_value(IT, obj);
    return res;
} /* f_call */

LISPID f_move(LISPID what, LISPID where) {
    CHECK_OBJECT("move", 1, what);
    CHECK_STRING_OR_OBJECT("move", 2, where);
    CHECK_WIZARD("move");
    move_object(what, where);
    set_symbol_value(IT, what);
    return what;
} /* f_move */

LISPID f_inv(LISPID what) {
    CHECK_OBJECT("inv", 1, what);
    CHECK_WIZARD("inv");
    return array2list(all_inventory(what));
} /* f_inv */

LISPID f_env(LISPID what) {
    CHECK_OBJECT("inv", 1, what);
    CHECK_WIZARD("env");
    return environment(what);
} /* f_env */

LISPID f_present(LISPID what, LISPID where) {
    object res;

    CHECK_STRING_OR_OBJECT("present", 1, what);
    CHECK_OBJECT("present", 2, where);
    CHECK_WIZARD("present");
    res = present(what, where);
    if (res)
	set_symbol_value(IT, res);
    return res;
} /* f_present */

LISPID f_smartpresent(LISPID what, LISPID where) {
    object res;

    CHECK_STRING_OR_OBJECT("smartpresent", 1, what);
    CHECK_WIZARD("smartpresent");
    res = smartpresent(what, where);
    if (res)
	set_symbol_value(IT, res);
    return res;
} /* f_smartpresent */

LISPID f_find_living(LISPID what) {
    object res;

    CHECK_STRING("find_living", 1, what);
    CHECK_WIZARD("find_living");
    res = find_living(what);
    if (!res)
	res = find_living(lower_case(what));
    if (res)
	set_symbol_value(IT, res);
    return res;
} /* f_find_living */

LISPID f_find_object(LISPID what) {
    object res;

    CHECK_STRING("find_object", 1, what);
    CHECK_WIZARD("find_object");
    res = find_object(what);
    if (!res)
	res = find_object(lower_case(what));
    if (res)
	set_symbol_value(IT, res);
    return res;
} /* f_find_object */

/* This function does all it can to find the "what" */
LISPID f_find_bang(LISPID what, LISPID where) {
    object res;
    string lwhat, pwhat, lpwhat;

    CHECK_STRING_OR_OBJECT("find!", 1, what);
    if (where != NIL)
	CHECK_STRING_OR_OBJECT("find!", 2, where);
    CHECK_WIZARD("find!");
    if (IS_OBJECT(what))
	return what;
    if (IS_STRING(where))
	where = f_find_bang(where, 0);
    res = smartpresent(what, where);
    if (!res)
	res = find_living(what);
    if (!res) {
	lwhat = lower_case(what);
	res = find_living(lwhat);
    }
    if (!res)
	res = find_object(what);
    if (!res)
	res = find_object(lwhat);
    if (!res) {
	catch(call_other(what, "fiberoptiksvan"));
	res = find_object(what);
    }	
    if (!res) {
	catch(call_other(lwhat, "fiberoptiksvan"));
	res = find_object(lwhat);
    }	
    if (!res) {
	pwhat = "/players/" + lower_case((string)this_player()->query_name()) +
	        "/" + what;
	catch(call_other(pwhat, "fiberoptiksvan"));
	res = find_object(pwhat);
    }	
    if (!res) {
	lpwhat = lower_case(pwhat);
	catch(call_other(lpwhat, "fiberoptiksvan"));
	res = find_object(lpwhat);
    }	
    if (res)
	set_symbol_value(IT, res);
    else
	LISP_ERROR("The function 'find!' failed to find " + lispid2string(what));
    return res;
} /* f_find_bang */

/* I don't check the arguments too carefully. */
LISPID f_say(LISPID str, LISPID arg2) {
    CHECK_WIZARD("say");
    if (arg2 != NIL)
	say(convert_lisp2lpc(str), convert_lisp2lpc(arg2));
    else
	say(convert_lisp2lpc(str));	/* A 2nd arg == 0 doesn't seem to work! */
    return str;
} /* f_say */

LISPID f_tell(LISPID who, LISPID what) {
    CHECK_WIZARD("tell");
    tell_object(convert_lisp2lpc(who), convert_lisp2lpc(what));
    return what;
} /* f_tell */

LISPID f_write(LISPID str) {
    /* CHECK_WIZARD("write"); -- No, this one is safe, and needed! */
    write(convert_lisp2lpc(str));
    return str;
} /* f_write */

LISPID f_get_dir(LISPID str) {
    CHECK_STRING("get_dir", 1, str);
    CHECK_WIZARD("get_dir");
    return convert_lpc2lisp(get_dir(convert_lisp2lpc(str)));
} /* f_get_dir */

LISPID f_users() {
    CHECK_WIZARD("users");
    return convert_lpc2lisp(users());
} /* f_users */

LISPID f_catch(LISPID expr, LISPID evalenv) {
    string errstr;
    mixed res;
    /* CHECK_WIZARD("catch"); -- No, this one is safe (???), and needed! */

    errstr = NIL;
    res = NIL;
    errstr = catch(res = eval(expr, evalenv));
    if (errstr) {
	write("LISP: Caught error ");
	print(errstr);
	write(" when evaluating ");
	print(expr);
	write("\n");
    }
    return cons(res, cons(errstr, NIL));
} /* f_catch */

LISPID f_throw(LISPID str) {
    CHECK_STRING("get_dir", 1, str);
    /* CHECK_WIZARD("throw"); -- No, this one is safe, and needed! */
    throw(str);
} /* f_throw */

LISPID f_sscanf(LISPID args) {
    string src, fmt;
    src = car(args);
    fmt = car(cdr(args));
    args = cdr(cdr(args));
    CHECK_STRING("sscanf", 1, src);
    CHECK_STRING("sscanf", 2, fmt);
    /* CHECK_WIZARD("sscanf"); -- No, this one is safe, and needed! */

    LISP_ERROR("NYI: sscanf");
} /* f_sscanf */

LISPID f_creator(LISPID obj) {
    CHECK_OBJECT("creator", 1, obj);
    CHECK_WIZARD("creator");
    return(creator(obj));
} /* f_creator */

LISPID f_status(LISPID arg) {
    write("symbols: " + sizeof(symbol_names) + "\n");
    write("conses: " + sizeof(cons_cars) + "\n");
    if (arg != NIL) {
	write("symbol_names = "); smartwrite(symbol_names); write("\n");
	write("symbol_values = "); smartwrite(symbol_values); write("\n");
	write("cons_cars = "); smartwrite(cons_cars); write("\n");
	write("cons_cdrs = "); smartwrite(cons_cdrs); write("\n");
    }
    return arg;
} /* f_status */

/*---------------------------------------------------------------------------*/

/* Eval and apply */

LISPID evalargs(LISPID args, LISPID evalenv) {
    DEBUG_EVAL(">EVALARGS: " + lispid2string(args));
    if (args == NIL)
	return NIL;
    else
	return cons(eval(car(args), evalenv), evalargs(cdr(args), evalenv));
} /* evalargs */

/* For user-defined functions, fun is the lambda-expression, for builtins the name */
LISPID apply(LISPID fun, LISPID args, LISPID evalenv) {
    LISPID res, fundef;

    DEBUG_EVAL(">APPLY: " + lispid2string(fun) + ", " + lispid2string(args));

    if (IS_SYMBOL(fun))
	fundef = eval(fun, evalenv);
    else
	fundef = fun;

    if (fundef == UNBOUND) {
	LISP_ERROR("Undefined function: " + lispid2string(fun));
    }
    else if (IS_CONS(fundef) && (car(fundef) == LAMBDA || car(fundef) == NLAMBDA)) {
	LISPID body, new_evalenv;
	body = cdr(cdr(fundef));
	new_evalenv = build_evalenv(car(cdr(fundef)), args, evalenv);
	while (body != NIL) {
	    res = eval(car(body), new_evalenv);
	    body = cdr(body);
	}
    }
    else if (fundef != BUILTIN && fundef != BUILTIN_NOEVAL) {
	LISP_ERROR("Not a function: " + lispid2string(fun));
    }
    else {
	switch (fun) {
	  /* The ones below without CHECK_ARGS should probably have something too. */

	  /* These functions don't evaluate their arguments: */

	  case QUOTE: CHECK_ARGS("quote", 1, args); res = car(args); break;
	  case LAMBDA: CHECK_ARGS("lambda", 1, args); res = car(args); break;
	  case SETQ:
	    CHECK_ARGS("setq", 2, args);
	    res = eval(car(cdr(args)), evalenv);
	    set_symbol_value(car(args), res);
	    break;
	  case DEFUN:
	    res = cons(LAMBDA, (cdr(args))); 
	    set_symbol_value(car(args), res);
	    break;
	  case DEFMACRO:
	    res = cons(NLAMBDA, (cdr(args))); 
	    set_symbol_value(car(args), res);
	    break;
	  case COND:
	    res = cond(args, evalenv);
	    break;
	  case IF:
	    CHECK_ARGS("if", 3, args);
	    res = f_if(args, evalenv);
	    break;

	  /* The rest of the functions do evaluate their arguments: */

	  case CAR: CHECK_ARGS("car", 1, args); res = car(car(args)); break;
	  case CDR: CHECK_ARGS("cdr", 1, args); res = cdr(car(args)); break;
	  case CONS: CHECK_ARGS("cons", 2, args); res = cons(car(args), car(cdr(args))); break;
	  case LENGTH: CHECK_ARGS("length", 1, args); res = length_id(car(args)); break;
	  case EVAL: CHECK_ARGS("eval", 1, args); res = eval(car(args), evalenv); break;
	  case APPLY: CHECK_ARGS("apply", 2, args); res = apply(car(args), car(cdr(args)), evalenv); break;
	  case PRINT: CHECK_ARGS("print", 1, args); res = print(car(args)); break;
	  case SET:
	    CHECK_ARGS("set", 2, args);
	    res = cdr(args);
	    set_symbol_value(car(args), res);
	    break;
	  case NTH: CHECK_ARGS("nth", 2, args); res = nth(car(args), car(cdr(args))); break;
	  case MEMBER: CHECK_ARGS("member", 2, args); res = member(car(args), car(cdr(args))); break;
	  case MAP: CHECK_ARGS("map", 2, args); res = map(car(args), car(cdr(args)), evalenv); break;
	  case EQUAL: CHECK_ARGS("=", 2, args); res = equal(car(args), car(cdr(args))); break;
	  case PLUS: res = plus(args); break;
	  case MINUS: CHECK_ARGS("-", 2, args); res = minus(car(args), car(cdr(args))); break;
	  case TIMES: CHECK_ARGS("*", 2, args); res = times(car(args), car(cdr(args))); break;
	  case DIVISION: CHECK_ARGS("/", 2, args); res = division(car(args), car(cdr(args))); break;
	  case COPY: CHECK_ARGS("copy", 1, args); res = copy(car(args)); break;
	  case GARB: CHECK_ARGS("garb", 0, args); res = garb(); break;
	  case LIST: res = args; break;

	  case X9: res = NIL; break;

	  /* MUD-specific functions: */      

	  case CLONE: CHECK_ARGS("clone", 1, args); res = f_clone(car(args)); break;
	  case LOAD: CHECK_ARGS("load", 1, args); res = f_load(car(args)); break;
	  case DESTRUCT: CHECK_ARGS("destruct", 1, args); res = f_destruct(car(args)); break;
	  case CALL: res = f_call(car(args), car(cdr(args)), cdr(cdr(args))); break;
	  case MOVE: CHECK_ARGS("move", 2, args); res = f_move(car(args), car(cdr(args))); break;
	  case INV: CHECK_ARGS("inv", 1, args); res = f_inv(car(args)); break;
	  case ENV: CHECK_ARGS("env", 1, args); res = f_env(car(args)); break;
	  case PRESENT: CHECK_ARGS("present", 2, args); res = f_present(car(args), car(cdr(args))); break;
	  case FIND_LIVING: CHECK_ARGS("find_living", 1, args); res = f_find_living(car(args)); break;
	  case FIND_OBJECT: CHECK_ARGS("find_object", 1, args); res = f_find_object(car(args)); break;
	  case FIND:
	    CHECK_ARGS_RANGE("find", 1, 2, args); 
	    if (length_int(args) < 2)
		res = f_find_bang(car(args), NIL);
	    else
		res = f_find_bang(car(args), car(cdr(args)));
	    break;
	  case SAY:
	    CHECK_ARGS_RANGE("say", 1, 2, args); 
	    if (length_int(args) < 2)
		res = f_say(car(args), NIL);
	    else
		res = f_say(car(args), car(cdr(args)));
	    break;
	  case TELL: CHECK_ARGS("tell", 2, args); res = f_tell(car(args), car(cdr(args))); break;
	  case WRITE: CHECK_ARGS("write", 1, args); res = f_write(car(args)); break;
	  case GET_DIR: CHECK_ARGS("get_dir", 1, args); res = f_get_dir(car(args)); break;
	  case USERS: CHECK_ARGS("users", 0, args); res = f_users(); break;
	  case CATCH: CHECK_ARGS("catch", 1, args); res = f_catch(car(args), evalenv); break;
	  case THROW: CHECK_ARGS("throw", 0, args); res = f_throw(car(args)); break;
	  case SSCANF: res = f_sscanf(args); break;
	  case CREATOR: CHECK_ARGS("creator", 1, args); res = f_creator(car(args)); break;
	  case STATUS:
	    CHECK_ARGS_RANGE("status", 0, 1, args); 
	    if (length_int(args) < 1)
		res = f_status(NIL);
	    else
		res = f_status(car(args));
	    break;
	  case CAAR: CHECK_ARGS("caar", 1, args); res = car(car(car(args))); break;
	  case CADR: CHECK_ARGS("cadr", 1, args); res = car(cdr(car(args))); break;
	  case CDAR: CHECK_ARGS("cdar", 1, args); res = cdr(car(car(args))); break;
	  case CDDR: CHECK_ARGS("cddr", 1, args); res = cdr(cdr(car(args))); break;
	  case SMARTPRESENT:
	    CHECK_ARGS_RANGE("smartpresent", 1, 2, args); 
	    if (length_int(args) == 1)
		res = f_smartpresent(car(args), NIL);
	    else
		res = f_smartpresent(car(args), car(cdr(args)));
	    break;
	  default: LISP_ERROR("Built-in function NYI: " + lispid2string(fun)); break;
	} /* switch */
    } /* built-in function */

    DEBUG_EVAL("APPLY " + lispid2string(fun) + ", " + lispid2string(args) + " returns = " + lispid2string(res));
    return res;
} /* apply */

LISPID eval(LISPID id, LISPID evalenv) {
    LISPID fun, fundef, args, res;

    DEBUG_EVAL(">EVAL: " + lispid2string(id));
    if IS_CONS(id) {
	fun = car(id);
	args = cdr(id);
	fundef = eval(fun, evalenv);
	if (fundef != BUILTIN_NOEVAL && (!IS_CONS(fundef) || car(fundef) != NLAMBDA))
	    args = evalargs(args, evalenv);
	if (fundef == BUILTIN || fundef == BUILTIN_NOEVAL)
	    res = apply(fun, args, evalenv);
	else
	    res = apply(fundef, args, evalenv);
    }
    else if (IS_SYMBOL(id)) {
	res = find_binding(id, evalenv);
	if (res == UNBOUND)
	    res = get_symbol_value(id);
	if (res == UNBOUND) {
	    LISP_ERROR("Unbound symbol: " + lispid2string(id));
	}
    }
    else
	res = id;
    DEBUG_EVAL("EVAL " + lispid2string(id) + " returns = " + lispid2string(res));
    return res;
} /* eval */

/*---------------------------------------------------------------------------*/

void reset(int arg) {
    ::reset(arg);

    if (arg)
	return;

    set_name("lisptool");
    set_article("a");
    set_aliases(({ "oak staff", "staff", "oak-staff", "freshly cut oak staff",
		   "freshly cut oak-staff",
		   "new staff", "new oak-staff", "new oak staff", "fresh staff",
		   "wiztool", "tool", "lisp tool" }));
    set_plural("lisptools");
    set_short("a freshly cut oak staff");
    set_long("This is Padrone's lisptool, disguised as a magic staff.\n" +
	     "You can use it to evaluate Lisp code - either with the command 'eval',\n" +
	     "or by just typing anything that starts with a left parenthesis, '('.\n" +
	     "The command 'help lisptool' will tell you more.\n");
    set_can_get(1);
    set_weight(1);
    set_value(20);

    init_data();
} /* reset */

/*---------------------------------------------------------------------------*/

void init() {
    if (this_player() != environment(this_object()))
	return;
    add_action("cmd_point", "point");
    add_action("cmd_point", "wave");
    add_action("cmd_eval", "eval");
    add_action("cmd_paren", "(", 1);
    add_action("cmd_help", "help");
    add_action("cmd_garb", "garb");
    set_symbol_value(ME, this_player());
} /* init */

/*---------------------------------------------------------------------------*/

/* A command that you canf use to set the value of the symbol "it" */
int cmd_point(string str) {
    string what, where, description;
    object the_obj;

    if (!str) {
	notify_fail("But what do you want to " + query_verb() + "?\n");
	return 0;
    }

    if (   sscanf(str, "with %s at %s", what, where) == 2
	|| sscanf(str, "at %s with %s", where, what) == 2
	|| sscanf(str, "%s at %s", what, where) == 2) {
	if (!id(what)) {
	    notify_fail("Point WHAT at " + where + "?\n");
	    return 0;
	}
    }
    else if (sscanf(str, "at %s", where) != 1) {
	if (id(str)) {
	    write("You wave your oak staff in the air, pointing at nothing special.\n");
	    if (get_symbol_value(SILENT) == NIL)
		say(this_player()->query_name() + " waves with " +
		    this_player()->query_possessive() + " oak staff in the air.\n");
	    set_symbol_value(IT, environment(this_player()));
	    return 1;
	}
	notify_fail("Do you want to point something at something, or what?\n");
	return 0;
    }

    the_obj = smartpresent(where, this_player());
    if (!the_obj)
	the_obj = smartpresent(where, environment(this_player()));
    if (!the_obj && environment(this_player())->id(where)) {
	the_obj = environment(this_player());
	description = describe_the_object(0, where);
    }
    if (!the_obj) {
	write("There is no " + where + " here.\n");
	return 1;
    }

   if (!description)
       description = describe_the_object(the_obj, where);
    if (get_symbol_value(SILENT) == NIL)
	say(this_player()->query_name() + " points at " + description +
	    " with " + this_player()->query_possessive() + " oak staff.\n");
    write("You point at " + description + " with the oak staff.\n");
    set_symbol_value(IT, the_obj);
    return 1;
} /* cmd_point */

int cmd_help(string str) {

    if (!str) {
	notify_fail("But what do you want help about?\n");
	return 0;
    }
    if (!id(str)) {
	notify_fail("No help available about that.\n");
	return 0;
    }

    cat("/players/padrone/wiz/lisptool.help");
    return 1;
} /* cmd_help */

/* If it's totaly full, you can't even type "(garb"), since that takes one cons cell. */
int cmd_garb(string str) {

    if (!str) {
	notify_fail("But what do you want to garb?\n");
	return 0;
    }
    if (!id(str)) {
	notify_fail("Maybe you should try 'garb staff'?\n");
	return 0;
    }

    write("You press the emergency garbage collect button on your magic staff.\n");
    if (get_symbol_value(SILENT) == NIL)
	say(this_player()->query_name() +
	    " pressed the emergency garbage collect button on " +
	    this_player()->query_possessive() + " magic staff.\n");

    garb();
    return 1;
} /* cmd_garb */

int cmd_eval(string str) {
    LISPID read_result, eval_result;
    string errstr;

    if (str == 0) {
	notify_fail("Eval what?\n");
	return 0;
    }

    if (get_symbol_value(SILENT) == NIL)
	say("There is a strange clicking sound as " +
	    this_player()->query_name() + " does something with " +
	    this_player()->query_possessive() + " magic staff.\n");

/*
    write("Staff command: "); smartwrite(str); write("\n");
*/

    read_result = read(str);

    if (read_result == UNBOUND)
	return 1;
    write("Input: "); print(read_result); write("\n");

    set_rollback();

    errstr = catch(eval_result = eval(read_result, NIL));

    write("\n");
    if (errstr == 0) {
	write("Result: ");
	print(eval_result);
	write("\n");
    }
    else {
	write("LISP ERROR in eval: " + errstr);
	angry_beep();
	rollback();
    }

    return 1;
} /* cmd_eval */

int cmd_paren(string str) {
    LISPID read_result;

    if (str == 0 && query_verb() == ")") {
	notify_fail("Eval what?\n");
	return 0;
    }
    if (str)
	cmd_eval(query_verb() + " " + str);
    else
	cmd_eval(query_verb());
    return 1;
} /* cmd_paren */

/*---------------------------------------------------------------------------*/

/* Used when saving the lisptool's data */
string get_all_symbol_values() {
    LISPID persistent_list, this_sym, this_val;
    string ret_val;
    int i;
    status did_persistent;

    persistent_list = get_symbol_value(PERSISTENT);
    if (persistent_list == NIL)
	return "nil";
    else if (IS_CONS(persistent_list)) {
	/* Save the symbols on "persistent_list" */
	did_persistent = 0;
	ret_val = "(";
	while (persistent_list != NIL) {
	    this_sym = car(persistent_list);
	    did_persistent = (this_sym == PERSISTENT);
	    persistent_list = cdr(persistent_list);
	    this_val = get_symbol_value(this_sym);
	    if (this_val != UNBOUND)
		ret_val += "(" + symbol_id2name(this_sym) + " " +
		    lispid2string(this_val) + ")";
	}
	if (!did_persistent)
	    ret_val += "(" + symbol_id2name(PERSISTENT) + " " +
		lispid2string(get_symbol_value(PERSISTENT)) + ")";
	ret_val += ")";
	return ret_val;
    }
    else if (persistent_list == T) {
	/* "persistent_list" is not a list, so we save all (user-defines) symbols */
	ret_val = "(";
	ret_val += "(" + symbol_id2name(SILENT) + " " +
		lispid2string(get_symbol_value(SILENT)) + ")";
	for (i = FIRST_USER_DEFINED_SYMBOL; i < sizeof(symbol_names); ++i) {
	    this_val = get_symbol_value(i);
	    if (this_val != UNBOUND)
		ret_val += "(" + symbol_id2name(i) + " " +
		    lispid2string(this_val) + ")";
	}
	ret_val += "(" + symbol_id2name(PERSISTENT) + " " +
	    lispid2string(get_symbol_value(PERSISTENT)) + ")";
	ret_val += ")";
	return ret_val;
    }
    else {
	LISP_ERROR("The list of symbols to save (\"persistent\") had an illegal format: " +
		   lispid2string(persistent_list));
    }
} /* get_all_symbol_values */

/* Used when restoring the lisptool's data */
void set_all_symbol_values(string str) {
    LISPID sym_list, this_sym;

    sym_list = read(str);
    while (sym_list != NIL) {
	this_sym = car(sym_list);
	sym_list = cdr(sym_list);
	set_symbol_value(car(this_sym), car(cdr(this_sym)));
    }
} /* set_all_symbol_values */

/*---------------------------------------------------------------------------*/

/* The lisptool is auto-loading, but only for wizards */
string query_auto_load() {
  string name;
  int junk;

  if (this_player() && this_player()->query_level() >= WIZARD_LEVEL) {
      sscanf(file_name(this_object()),"%s#%d", name, junk);
      return name + ":" + get_all_symbol_values();
  }
  else
      return 0;
} /* query_auto_load */

void init_arg(string str) {
    write("A freshly cut oak staff materializes in your hand with a lisping sound.\n");
    if (str != "")
	set_all_symbol_values(str);
} /* init_arg */

/* It should destruct when the wizard leaves the game */
int drop() {
  if (this_player() && this_player()->query_level() >= WIZARD_LEVEL && query_verb() == "quit")
	return 1;
    else
	return 0;
} /* drop */

/*---------------------------------------------------------------------------*/

/* A few functions for debugging the tool */

void list_conses() {
    int i, n;
    n = sizeof(cons_cdrs);
    for (i = 0; i < n; ++i) {
	write(i + CONS_OFFSET + ": ");
	print(cons_cars[i]);
	write(", ");
	print(cons_cdrs[i]);
	write("\n");
    }
} /* list_conses */

void list_symbols() {
    int i, n;
    n = sizeof(symbol_names);
    for (i = 0; i < n; ++i) {
	write(i + SYMBOL_OFFSET + ": " + symbol_names[i]);
	write(" = ");
	print(symbol_values[i]);
	write("\n");
    }
} /* list_symbols */