/* Copyright 1989 GROUPE BULL -- See license conditions in file COPYRIGHT
 * Copyright 1989 Massachusetts Institute of Technology
 */
/**************************************************************\
* 							       *
* WOOL.c:						       *
* main body of interpreter				       *
* 							       *
* Here are defined Wool-only functions.			       *
* To add a function:					       *
* 	- declare it (coded in or extern)		       *
* 	- add it to the declaration of predefined functions    *
* 	  in the wool_init function			       *
* 							       *
* 'Kludged' to support the flex skeleton parser for V2.3.7   *
*				Dec 1992, O. Kirch	       *
\**************************************************************/

#if defined SVR4
#define SYSV
#endif

#include <stdio.h>
#include <sys/types.h>
#include <sys/file.h> 
#include <sys/times.h>
#include <signal.h> 
#include <sys/stat.h>
#if defined(IBM_RT) && defined(SYSV)
#include <unistd.h>
#endif /* IBM_RT && SYSV */
#if defined(i386) || defined(stellar)
#include <unistd.h>
#endif /* i386 */
#if defined(sun) && defined(SYSV)
#include <unistd.h>
#endif /* sun && SYSV */
#if defined(linux)
#include <unistd.h>
#endif /* linux */
#if defined(SYSV)
#include <limits.h>
#endif

#include "INTERN.h"
#include "wool.h"
#include "EXTERN.h"
#include "wl_atom.h"
#include "wl_coll.h"
#include "wl_func.h"
#include "wl_list.h"
#include "wl_number.h"
#include "wl_string.h"
#include "wl_pointer.h"
#include "wl_active.h"
#include "wl_name.h"
#include "yacc.h"

#ifdef SYSV
#include <string.h>
#include <sys/utsname.h>
#else /* SYSV */
#include <sys/wait.h>
#include <strings.h>
#include <sys/timeb.h>
#endif /* SYSV */

#ifdef STATS
extern WOOL_OBJECT zrtstats();
extern WOOL_OBJECT wlcfstats();
#endif /* STATS */
extern WOOL_OBJECT progn();
extern WOOL_OBJECT wool_print_nary();
extern WOOL_OBJECT wool_with(), wool_with_eval(); 
extern int 	wool_error_in_profile;
extern char 	*yytext;
DECLARE_strchr;

#ifdef DEBUG
#ifdef GWM
extern WOOL_OBJECT WLFsm_fp();
extern WOOL_OBJECT WLState_fp();
extern WOOL_OBJECT WLArc_fp();
#endif /* GWM */
#endif /* DEBUG */

/* VARS */

#ifdef SECURE
/* some helps */
char *wool_methods_names[] = {
    "WOOL_type_name",
    "WOOL_eval",
    "WOOL_print",
    "WOOL_free",
    "WOOL_execute",
    "WOOL_set",
    "WOOL_get_C_value",
    "WOOL_open",
    "WOOL_close",
    "WOOL_process_event",
    "WOOL_copy",
    "WOOL_get_dimensions",
    "WOOL_draw",
    "WOOL_equal",
    "WOOL_reconfigure",
    "WOOL_setq",
    "WOOL_silent_eval",
    "WOOL_UNDEFINED",
    "WOOL_UNDEFINED",
    "WOOL_UNDEFINED",
    "WOOL_UNDEFINED"
};

#endif /* SECURE */

#ifdef DO_BUS_ERROR
#define DoABusError() *((int *)0) = 1
#else /* DO_BUS_ERROR */
#define DoABusError()
#endif /* DO_BUS_ERROR */

/*
 * all constructors sets reference count of the object to 0
 * You should call check_reference on this object if it was only
 * a temporary one!
 */

/*******************\
* 		    *
*  run-time errors  *
* 		    *
\*******************/

static int             wool_error_position;
static char 	      *wool_error_expecting;
static int	       wool_error_print_argc;
static WOOL_OBJECT    *wool_error_print_argv;

/* echoes 1st, 2nd, 3rd, nth */

char *
English_enumeration_postfix(n)
int n;
{
    switch (n) {
	case 1: return "st";
	case 2: return "nd";
	case 3: return "rd";
	default: return "th";
    }
}

#ifdef __STDC__
extern void wool_print_error_message(int error, const void *message, char *text);
#else
extern void wool_print_error_message();
#endif

/*
 * wool_error:
 * This is the standard error function. It is really brutal, as it wool_prints
 * an error message an then LONGJMPs to "wool_goes_here_on_error" with an
 * error value, for now 1.
 * You can feel free to redefine wool_goes_here_on_error.
 * 
 * WARNING: Don't forget to clean your structures before going here,
 * you won't return!
 */

WOOL_OBJECT
#ifdef __STDC__
_wool_error(int error, const void *message)
#else
_wool_error(error, message)
int             error;		/* error number (see wool.h) */
char           *message;	/* anything, in fact */
#endif
{
    static int      is_in_wool_error;

    if (is_in_wool_error) {
	stop_if_in_dbx();
	goto direct_longjmp;
    }
    is_in_wool_error = 1;
    if (wool_do_print_errors && error != SILENT_ERROR) {
	wool_print_error_message(error, message, "WOOL ERROR: ");
	wool_stack_dump(0);
	fflush(stdout);
	fflush(stderr);
    }
    if (!wool_continue_reading_on_error)
	wool_error_status = 1;
    wool_error_handler();		/* C package handler */
    DoABusError();			/* debug only */
    WLStackFrame_pop_to(wool_stackframe_on_error);
    calling_function_current = calling_function_stack +
	calling_function_on_error;
direct_longjmp:
    is_in_wool_error = 0;
    stop_if_in_dbx();
    longjmp(wool_goes_here_on_error, 1);
    /* NOTREACHED *//* for lint */
    return NIL;
}

void
#ifdef __STDC__
wool_print_error_message(int error, const void *message, char *text)
#else
wool_print_error_message(error, message, text)
int             error;		/* error number (see wool.h) */
char           *message;	/* anything, in fact */
char           *text;		/* WOOL ERROR: */
#endif
{
#ifndef DEBUG
    wool_newline();
#endif /* DEBUG */
    if (wool_is_reading_file) {
	wool_printf("\"%s\"", wool_is_reading_file);
	wool_printf(": line %d\n", yylineno);
    }
    wool_puts(text);
    switch (error) {
    case UNDEFINED_VARIABLE:
	wool_printf("undefined variable: %s", message);
	break;
    case BAD_NUMBER_OF_ARGS:
	wool_printf("bad number of arguments %d", message);
	break;
    case UNDEFINED_FUNCTION:
	wool_puts("undefined function: ");
	wool_print(message);
	break;
    case BAD_DEFUN:
	wool_printf("bad definition of function: %s", message);
	break;
    case BAD_ARG_TYPE:
	wool_printf("bad %d", wool_error_position + 1);
	wool_printf("%s argument: ",
		    English_enumeration_postfix(wool_error_position + 1));
	wool_print(message);
	if (wool_error_expecting) {
	    wool_puts(" (its type is \"");
	    wool_print(((WOOL_OBJECT) message) -> type[0]);
	    if (wool_error_expecting[0])
	      wool_printf("\", was expecting a \"%s",
			  wool_error_expecting);
	    wool_puts("\")");
	}
	break;
    case RELEASING_ATOM:
	wool_printf("Internal error: trying to free atom: %s", message);
	break;
    case NOT_AN_ATOM:
	wool_printf("Not an atom: %s", message);
	break;
    case BAD_LOCAL_SYNTAX:
	wool_printf("bad local variable declaration. %s", message);
	break;
    case SYNTAX_ERROR:
	wool_printf("%s", message);
	break;
    case INTERNAL_ERROR:
	wool_printf("Internal error: %s", message);
	break;
    case TIME_EXCEEDED:
	wool_printf("Evaluation took longer than %ld second(s) -- Aborted",
		    message);
	break;
    case CANNOT_SET:
	wool_puts("Cannot set a \"");
	wool_print_type(message);
	wool_puts("\": ");
	wool_print(message);
	break;
    case CANNOT_GET_C_VALUE:
	wool_puts("Cannot figure how to get a number from a \"");
	wool_print_type(message);
	wool_puts("\": ");
	wool_print(message);
	break;
    case TOO_MANY_PARAMETERS:
	wool_puts("Too many parameters for a C function call: ");
	wool_print(message);
	break;
    case NON_WOOL_OBJECT:
	wool_printf("%s on a non wool object.", message);
	break;
    case UNDEFINED_METHOD:
#ifdef DEBUG
	wool_printf("Undef WOOL method %s for type \"",
		    wool_methods_names[WOOL_current_method]);
#else /* DEBUG */
	wool_puts("Bad object type \"");
#endif /* DEBUG */
	WLAtom_print(((WOOL_OBJECT) message) -> type[0]);
	wool_puts("\" for object: ");
	wool_print(message);
	break;
    case NO_MEMORY:
	wool_puts("No more memory, bye...\n");
	wool_end(1);
	break;
    case NOT_REDEFINABLE:
	wool_puts("Cannot redefine object: ");
	wool_print(message);
	break;
    case NOT_MODIFIABLE:
	wool_puts("Cannot modify object: ");
	wool_print(message);
	break;
    case USER_ERROR:
	wool_print_nary(wool_error_print_argc, wool_error_print_argv);
	break;
    default:			/* suppose first arg was a string! */
	wool_printf(error, message);
    }
    wool_newline();
}

/* wool_trigger_error
 * triggers an error from wool
 */

WOOL_OBJECT
wool_trigger_error(argc, argv)
int argc;
WOOL_OBJECT	argv[];
{
    wool_error_print_argc = argc;
    wool_error_print_argv = argv;
    return wool_error(USER_ERROR, 0);
}

/* wool_error_has_occurred:
 * encapsulates statements to trap errors without printing them
 */

WOOL_OBJECT
wool_error_has_occurred(argc, argv)
int argc;
WOOL_OBJECT	argv[];
{
    int             we_got_an_error = 0;
    int old_wool_do_print_errors = wool_do_print_errors;

    save_wool_error_resume_point();
    wool_do_print_errors = 0;
    if (set_wool_error_resume_point()) {
	we_got_an_error = 1;
    } else {
	progn(argc, argv);
    }
    wool_do_print_errors = old_wool_do_print_errors;
    restore_wool_error_resume_point();
    return (we_got_an_error ? TRU : NIL);
}

/* bad argument call
 */

WOOL_OBJECT
bad_argument(argument, position, expecting)
WOOL_OBJECT	argument;
int		position;
char	       *expecting;
{
    wool_error_position = position;
    wool_error_expecting = expecting;
    return wool_error(BAD_ARG_TYPE, argument);
}

/* wool warning messages 
 * returns 1 if printed
 */

int
wool_warning(alarm_text)
char	*alarm_text;
{
    if(wool_do_print_errors){
	wool_puts(alarm_text);
	if (wool_is_reading_file) {
	    wool_printf("\"%s\"", wool_is_reading_file);
	    wool_printf(": line %d, ", yylineno);
	}
	wool_stack_dump(0);
	return 1;
    } else
    	return 0;
}

int
wool_warning1(alarm_text, data)
char	*alarm_text;
char    *data;
{
    char msg[MAX_TEMP_STRING_SIZE];

    sprintf(msg, alarm_text, data);
    return wool_warning(msg);
}


/* executes an expression, returns if error (do not jump to toplevel)
 * return eval if no error occurred, NULL otherwise
 */

WOOL_OBJECT
wool_eval_and_catch_errors(wool_expr)
WOOL_OBJECT wool_expr;
{
    WOOL_OBJECT	    result = 0;

    save_wool_error_resume_point();	/* contains decls */
    if (set_wool_error_resume_point()) {
	result = 0;
    } else {
	result = WOOL_send(WOOL_eval, wool_expr, (wool_expr));
    }
    restore_wool_error_resume_point();
    return  result;
}

/* same but do not return a value
 */

wool_eval_and_catch_errors_proc(wool_expr)
WOOL_OBJECT wool_expr;
{
    int             local_zrt_size = zrt_size;

    wool_eval_and_catch_errors(wool_expr);
    zrt_gc(local_zrt_size);
}
  

/* 
 * undefined method, one for each number of parameters.
 */

WOOL_OBJECT
wool_undefined_method_1(object)
WOOL_OBJECT object;
{
    return wool_error(UNDEFINED_METHOD, object);
}

WOOL_OBJECT
wool_undefined_method_2(object, param1)
WOOL_OBJECT object;
WOOL_OBJECT param1;
{
    return wool_error(UNDEFINED_METHOD, object);
}

#ifdef DEBUG
#define RMAGIC		0x5555	/* magic # on range info (see malloc.c)*/

extern char *malloc_zone_begin, *malloc_zone_end;

wool_send_is_valid(message, object)
int message;
WOOL_OBJECT object;
{
    if (!object
	|| ((char *) object) < malloc_zone_begin
	|| ((char *) object) >= malloc_zone_end
	|| *((int *) object) == FREED_MAGIC
	|| ((((WOOL_Atom) object -> type[0]) -> type != WLAtom)
	    && (((WOOL_Atom) object -> type[0]) -> type != WLActive)
	    && (((WOOL_Atom) object -> type[0]) -> type != WLPointer)
	    && (((WOOL_Atom) object -> type[0]) -> type != WLName)))
	wool_error(NON_WOOL_OBJECT, wool_methods_names[message]);
}

wool_object_is_valid(object)
WOOL_OBJECT object;
{
    if (!object
	|| ((char *) object) < malloc_zone_begin
	|| ((char *) object) >= malloc_zone_end
	|| *((int *) object) == FREED_MAGIC
	|| ((((WOOL_Atom) object -> type[0]) -> type != WLAtom)
	    && (((WOOL_Atom) object -> type[0]) -> type != WLActive)
	    && (((WOOL_Atom) object -> type[0]) -> type != WLPointer)
	    && (((WOOL_Atom) object -> type[0]) -> type != WLName)))
	return 0;
    else
	return 1;
}

#endif /* DEBUG */

/*********************************************************\
* 							  *
* The definition of C WOOL routines			  *
* These constitue the WOOL interface to the C programmer  *
* 							  *
\*********************************************************/

/*
 * wool_read:
 * reads an expression from the input (string or stream).
 * returns this expression or NULL if EOF reached
 * In case of syntax error, returns NIL
 * the read expression is in the global variable wool_read_expr,
 * if you need it. (this global is maintained for ref count purposes)
 * You don't need to free it since it's done at the beginning of this
 * routine.
 * Beware that it could be overwritten by a subsequent call to wool_eval
 * or wool_read !
 */

WOOL_OBJECT
wool_read()
{
    if (yyparse())
	return NULL;		/* returns NULL if error */
    else
	return wool_read_expr;	/* returns parsed expression */
}

/*
 * wool_pool:
 * this routine MUST be used when you want to make successive calls to
 * wool_read to parse an expression. It stores the string passed as argument
 * and returns the parenthese level. Thus a normal use would be to call
 * wool_pool with successive lines, while it returns a non-zero value,
 * and then call wool_read on the pooled buffer maintained by wool_poll,
 * whose address is stored in the global wool_pool_buffer.
 * (the parenthese level is in the int wool_pool_parenthese_level)
 * The buffer is reset by calling wool_pool with a NULL argument.
 */

int
wool_pool(s)
char           *s;		/* the string to be put in the pool */
{
    int             required_length;

    if (!wool_pool_buffer)
	wool_pool_buffer =
	    (char *) Malloc(wool_pool_buffer_size);
    if (!s) {
	*wool_pool_buffer = '\0';
	return wool_pool_parentheses_level = 0;
    } else {
	if ((int) (strlen(wool_pool_buffer) + (required_length = strlen(s)))
	    >= wool_pool_buffer_size) {
	    wool_pool_buffer_size +=
		Max(wool_pool_buffer_size, required_length) + 4;
	    wool_pool_buffer = (char *)
		Realloc(wool_pool_buffer, wool_pool_buffer_size);
	}
	strcat(wool_pool_buffer, "\n");
	strcat(wool_pool_buffer, s);
	{
	    char           *oldstream, old_input_buf[AHEAD_BUF_SIZE];
	    int             old_type;

	    old_type = wool_input_redirect(1, s, &oldstream, old_input_buf);
	    while (yylex() != END_OF_FILE);
	    wool_input_redirect(old_type, oldstream, NULL, NULL);
	    wool_unput(old_input_buf);
	    return wool_pool_parentheses_level;
	}
    }
}

/*
 * wool_eval:
 * evals an expression given as argument;
 * returns the result of the evaluation
 * if you want to keep the result, increase its reference count!
 * In case of eval error, calls wool_error which returns NIL
 */

WOOL_OBJECT
wool_eval(read_expr)
WOOL_OBJECT read_expr;
{
    return WOOL_send(WOOL_eval, read_expr, (read_expr));
}

/***************************************************************************\
* 									    *
* WOOL USER routines:							    *
* here are the definition of the standard routines binded to wool atoms by  *
* wool_init								    *
* 									    *
\***************************************************************************/

/*
 * The NULL function is there only as a placeholder
 */

WOOL_OBJECT
NIL_FUNC()
{
    return NIL;
}

/*
 * quoting can be implemented as a function:
 * 'foo ==> (quote foo)
 */

WOOL_OBJECT
wool_quote(obj)
WOOL_OBJECT obj;
{
    return obj;
}

/*
 * eval is the opposite of quoting
 */

WOOL_OBJECT
eval(obj)
WOOL_OBJECT     obj;
{
    return WOOL_send(WOOL_eval, obj, (obj));
}

/* copy an object (useful for lists)
 */

WOOL_OBJECT
wool_copy(obj)
WOOL_OBJECT     obj;
{
    return WOOL_send(WOOL_copy, obj, (obj));
}

/*
 * Arithmetic functions, patterned along Le_Lisp ones
 */

WOOL_OBJECT
wool_divide(n1, n2)
WOOL_Number n1, n2;
{
    return (WOOL_OBJECT) WLNumber_make(n2 -> number ?
				       n1 -> number / n2 -> number : 0);
}

WOOL_OBJECT
wool_modulo(n1, n2)
WOOL_Number n1, n2;
{
    Num tmp = n2 -> number ? n1 -> number % n2 -> number : 0;
    
    if (tmp < 0)
	tmp = tmp + n2 -> number;
    
    return (WOOL_OBJECT) WLNumber_make(tmp);
}

WOOL_OBJECT
wool_multiply(n1, n2)
WOOL_Number n1, n2;
{
    return (WOOL_OBJECT) WLNumber_make(n1 -> number * n2 -> number);
}

WOOL_OBJECT
wool_add(argc,argv)
int		argc;
WOOL_Number     argv[];
{
    WOOL_TYPE       type;

    if (argc == 0)
	wool_error(BAD_NUMBER_OF_ARGS, (char *)argc);
    type = argv[0] -> type;
    if (type == WLList || argv[0] == (WOOL_Number) NIL)
	return WLList_concat(argc, argv);
    else if (type == WLNumber)
	return add_numbers(argc, argv);
    else
	must_be_string(argv[0], 0);
    return add_strings(argc, argv);
}

WOOL_OBJECT
wool_minus(argc, argv)
int		argc;
WOOL_Number     argv[];
{
    switch (argc) {
    case 1:
	return (WOOL_OBJECT) WLNumber_make(-(argv[0] -> number));
    case 2:
	return (WOOL_OBJECT) WLNumber_make(
				 (argv[0] -> number) - (argv[1] -> number));
    case 0:
	return wool_error(BAD_NUMBER_OF_ARGS, (char *)argc);
    default: {int i, result = argv[0] -> number;
	      for (i = 1; i < argc; i++)
		  result -= argv[i] -> number;
	      return (WOOL_OBJECT) WLNumber_make(result);
	  }	
    }
}

/* comparisons
 */

WOOL_OBJECT
wool_equal(o1, o2)
WOOL_OBJECT     o1, o2;
{
    return WOOL_send(WOOL_equal, o1, (o1, o2));
}

WOOL_OBJECT
wool_eq(o1, o2)
WOOL_OBJECT     o1, o2;
{
    if (o1 == o2)
	return TRU;
    else
	return NIL;
}

WOOL_OBJECT
greater_than(o1, o2)
WOOL_OBJECT     o1, o2;
{
    if (o1 -> type != o2 -> type)
	return NIL;
    if (((o1 -> type == WLNumber) &&
	 (((WOOL_Number) o1) -> number > ((WOOL_Number) o2) -> number))
	|| ((o1 -> type == WLString) &&
	    strcmp(((WOOL_String) o1) -> string,
		   ((WOOL_String) o2) -> string) == 1))
	return TRU;
    else
	return NIL;
}

WOOL_OBJECT
lesser_than(o1, o2)
WOOL_OBJECT     o1, o2;
{
    if (o1 -> type != o2 -> type)
	return NIL;
    if (((o1 -> type == WLNumber) &&
	 (((WOOL_Number) o1) -> number < ((WOOL_Number) o2) -> number))
	|| ((o1 -> type == WLString) &&
	    strcmp(((WOOL_String) o1) -> string,
		   ((WOOL_String) o2) -> string) == -1))
	return TRU;
    else
	return NIL;
}
    
/* wool_compare returns -1, 0, +1 if <, =, > and () if not comparable.
 */

WOOL_OBJECT
wool_compare(o1, o2)
WOOL_Number     o1, o2;
{
    if (o1 -> type != o2 -> type)
	return NIL;
    if (o1 -> type == WLNumber) {
	if (o1 -> number < o2 -> number)
	    return (WOOL_OBJECT) WLNumber_make(-1);
	else if (o1 -> number > o2 -> number)
	    return (WOOL_OBJECT) WLNumber_make(1);
	else
	    return (WOOL_OBJECT) WLNumber_make(0);
    } else {
	must_be_string(o1, 0);
	return (WOOL_OBJECT) WLNumber_make(
					strcmp(((WOOL_String) o1) -> string,
					     ((WOOL_String) o2) -> string));
    }
}

/* member of a list, or substring of a string:
 * returns position in list or string or NIL if not found
 */

WOOL_OBJECT
wool_member(obj, list)
WOOL_String	obj;
WOOL_List	list;
{
    if (list -> type == WLList) {	/* list */
	WOOL_OBJECT    *p = list -> list;
	WOOL_OBJECT    *last = p + list -> size;

	while (p < last) {
	    if (WOOL_send(WOOL_equal, obj, (obj, *p)) != NIL)
		return (WOOL_OBJECT) WLNumber_make(p - list -> list);
	    p++;
	}
	return NIL;
    } else if (list == (WOOL_List) NIL) {	/* () */
	return NIL;
    } else {				/* substring of a string */
	char           *p, *string;
	int             length;

	must_be_string(list, 1);
	must_be_string(obj, 0);
	string = ((WOOL_String) list) -> string;
	length = strlen(obj -> string);
	for (p = string; *p; p++)
	    if (!strncmp(obj -> string, p, length))
		return (WOOL_OBJECT) WLNumber_make(p - string);
	return NIL;
    }
}

/* logical operations
 */

WOOL_OBJECT
not(obj)
WOOL_OBJECT     obj;
{
    if (obj == NIL)
	return TRU;
    else
	return NIL;
}

WOOL_OBJECT
and(argc, argv)
int		argc;
WOOL_OBJECT     argv[];
{
    int    i;

    for (i = 0; i < argc; i++)
	if (WOOL_send(WOOL_eval, argv[i], (argv[i])) == NIL)
	    return NIL;
    return TRU;
}

WOOL_OBJECT
or(argc, argv)
int		argc;
WOOL_OBJECT     argv[];
{
    int    i;
    WOOL_OBJECT tmp;

    for (i = 0; i < argc; i++)
	if ((tmp = WOOL_send(WOOL_eval, argv[i], (argv[i]))) != NIL)
	    return tmp;
    return NIL;
}

/*
 * bitwise-operators
 */

WOOL_OBJECT
wool_bitwise_or(argc, argv)
int argc;
WOOL_Number argv[];
{
    int             num = 0;

    while (argc--)
	num |= argv[argc] -> number;
    return (WOOL_OBJECT) WLNumber_make(num);
}

WOOL_OBJECT
wool_bitwise_and(argc, argv)
int argc;
WOOL_Number argv[];
{
    int             num = argv[0] -> number;

    while (argc--)
	num &= argv[argc] -> number;
    return (WOOL_OBJECT) WLNumber_make(num);
}

WOOL_OBJECT
wool_bitwise_xor(argc, argv)
int argc;
WOOL_Number argv[];
{
    int             num = 0;

    while (argc--)
	num ^= argv[argc] -> number;
    return (WOOL_OBJECT) WLNumber_make(num);
}

/*
 * Setq, the most important function
 * implemented as a method
 */

WOOL_OBJECT
setq(atom, value)
WOOL_Atom atom;
WOOL_OBJECT value;
{
    return WOOL_send(WOOL_set, atom, (atom, value));
}

WOOL_OBJECT
set(atom, value)
WOOL_Atom atom;
WOOL_OBJECT value;
{
    return WOOL_send(WOOL_setq, atom, (atom, value));
}

/*
 * unbind: release storage of an atom
 */

WOOL_OBJECT
wool_unbind(atom)
WOOL_Atom atom;
{
    extern WOOL_OBJECT WLAtom_unbind(), WLName_unbind();

    if (atom -> type == WLAtom)
	return WLAtom_unbind(atom);
    else if (atom -> type == WLName)
	return WLName_unbind(atom);
    else
	return bad_argument(atom, 0, "atom or name");
}

/*
 * boundp: tests if atom has already be defined
 */

WOOL_OBJECT
wool_boundp(atom)
WOOL_OBJECT atom;
{
    WOOL_OBJECT	value = WOOL_send(WOOL_silent_eval, atom, (atom));

    if (value && value != UNDEFINED_WOOL_VALUE)
	return (atom == NIL ? TRU : atom);
    else
	return NIL;
}

/*
 * list: makes a list of its evaluated arguments
 */

WOOL_OBJECT
wool_list(argc, argv)
int argc;
WOOL_OBJECT     argv[];
{
    WOOL_List list;
    WOOL_OBJECT *q, *last;

    if (!argc)
	return NIL;
    list = wool_list_make(argc);
    q = list -> list;
    last = argv + argc;

    while (argv < last)
        increase_reference(*q++ = *argv++);
    return (WOOL_OBJECT) list;
}

/*
 * length: of a string or list
 */

WOOL_Number
wool_length(obj)
WOOL_List     obj;
{
    if (obj -> type == WLList)
	return WLNumber_make(obj -> size);
    else if (obj == (WOOL_List) NIL)
	return WLNumber_make(0);
    else {
	must_be_string(obj, 0);
	return WLNumber_make(strlen(((WOOL_String) obj) -> string));
    }
}

/*
 * BEWARE: hacker's corner!
 * returns the object of the same type found at location number!
 * 	type		action
 * 	number		*int
 * 	string		*char
 * 	()		object
 * 	atom		adress of pointer object
 */

WOOL_OBJECT
wool_hack(type, pointer)
WOOL_OBJECT type;
WOOL_Number pointer;
{
    if (type -> type == WLNumber)
	return (WOOL_OBJECT) WLNumber_make(*((int *) pointer -> number));
    else if (type -> type == WLString)
	return (WOOL_OBJECT) WLString_make(pointer -> number);
    else if (type == NIL) {
	increase_reference(pointer -> number);
	return (WOOL_OBJECT) pointer -> number;
    } else if (type -> type == WLAtom)
	return (WOOL_OBJECT) WLNumber_make(pointer);
    else
	return NIL;
}

/* used time function expressed in milliseconds
 */

#ifdef CLK_TCK
#define TIME_UNIT CLK_TCK
#else
#define TIME_UNIT 60
#endif

WOOL_OBJECT
wool_used_time()
{
    long time;

#ifdef SYSV_TIME
    struct tms buffer;

#ifdef CLK_TCK
    time = (times(&buffer) * 1000) / TIME_UNIT;
#else
    times(&buffer);
    time = ((buffer.tms_utime + buffer.tms_stime) * 1000 ) / TIME_UNIT;
#endif
#else /* !SYSV_TIME */
    struct timeb time_bsd;

    ftime(&time_bsd);
    time = 1000 * time_bsd.time + time_bsd.millitm;
#endif /* !SYSV_TIME */

    return (WOOL_OBJECT) WLNumber_make(time);
}

/*
 * atoi and itoa
 */

WOOL_OBJECT
wool_atoi(obj)
WOOL_String obj;
{
    must_be_string(obj, 0);
    return (WOOL_OBJECT) WLNumber_make(atoi(obj -> string));
}

WOOL_OBJECT
wool_itoa(obj)
WOOL_Number obj;
{
    char tmp_str[20];

    must_be_number(obj, 0);
    sprintf(tmp_str, "%d", obj -> number);
    return (WOOL_OBJECT) WLString_make(tmp_str);
}

/*
 * Shell escape: executes a SYSTEM of the string (or atom) argument
 */

WOOL_OBJECT
shell(argc, argv)
int		argc;
WOOL_String     argv[];
{
    int             i;
    char          **program_args = (char **) Malloc(sizeof(char *) * (argc + 1));

    if (!argc)
	wool_error(BAD_NUMBER_OF_ARGS, (char *)argc);
    for (i = 0; i < argc; i++) {
	must_be_string(argv[i], i);
	program_args[i] = argv[i] -> string;
    }
    program_args[argc] = NULL;
    if (!fork()) {
	wool_clean_before_exec();
	execvp(program_args[0], program_args);
	exit(127);
    }
    Free(program_args);
    return NIL;
}

/* signals management avoiding defunct processes */

#if defined SYSV || defined SVR4
void
ChildDeathHandler(sig)
int sig;
{
    wait(0);
    signal(SIGCLD, ChildDeathHandler);
}

SignalsInit()
{
    signal(SIGCLD, ChildDeathHandler);
}
#else /* SYSV */
#include <sys/time.h>
#include <sys/resource.h>
void
ChildDeathHandler(sig)
int sig;
{
    int status;

    wait3(&status, WNOHANG, 0);
    signal(SIGCHLD, ChildDeathHandler);
}

SignalsInit()
{
    signal(SIGCHLD, ChildDeathHandler);
}
#endif /* SYSV */

/*
 *  print value of an object
 */

WOOL_OBJECT
wool_print(obj)
WOOL_OBJECT     obj;
{
    wool_print_level = 0;
    return WOOL_send(WOOL_print, obj, (obj));
}

WOOL_OBJECT
wool_print_nary(argc, argv)
int argc;
WOOL_OBJECT     argv[];
{
    int             i;
    WOOL_OBJECT	result = NIL;

    wool_print_level = 0;
    for (i = 0; i < argc; i++)
	result = WOOL_send(WOOL_print, argv[i], (argv[i]));
    yyoutflush();
    return result;
}

static int
expand_string_stream (str)
  WOOL_STRING_STREAM str;
{
    char *new_buf;
    int nbytes = str->last - str->buffer + 1;
    int ptr_pos = str->ptr - str->buffer;

    str->buffer = Realloc (str->buffer, 2*nbytes);        
    str->last = str->buffer + nbytes - 1;
    str->ptr = str->buffer + ptr_pos;
}

WOOL_OBJECT
wool_with_output_to_string (argc, argv)
  int argc;
  WOOL_OBJECT *argv;
{
    WOOL_STRING_STREAM str, WOOL_STRING_STREAM_make (); 
    int old_type;
    char *old_stream;
    WOOL_OBJECT result;

    str = WOOL_STRING_STREAM_make (256, expand_string_stream);
    old_type = wool_output_redirect (1, str, &old_stream);
    progn (argc, argv);
    wool_output_redirect (old_type, old_stream, NULL);

    result = (WOOL_OBJECT) WLString_make (str->buffer);
    WOOL_STRING_STREAM_free (str);
    return result;
}

WOOL_OBJECT
wool_with_output_to_file (argc, argv)
  int argc;
  WOOL_OBJECT *argv;
{
    FILE* f;
    WOOL_String fname;
    int old_type;
    char *old_stream;
    char* filename;
    int ok;

    fname = (WOOL_String) WOOL_send(WOOL_eval, *argv, (*argv));
    must_be_string(fname, 0);
    f = fopen(fname->string, "w");
    if (f) {
        old_type = wool_output_redirect (0, f, &old_stream);
        progn (argc-1, argv+1);
        wool_output_redirect (old_type, old_stream, NULL);
        fclose(f);
        return TRU;
    } else {
	wool_puts(wool_application_NAME);
    	wool_printf(": could not open file : %s\n", fname->string);
	return NIL;
    }
}

/*
 * (progn inst1 ... instn)
 * evals the n instructions then return the last one's result
 */

WOOL_OBJECT
progn(argc, argv)
int    argc;
WOOL_OBJECT *argv;
{
    if (argc) {
	int             local_zrt_size = zrt_size;

	while (--argc > 0) {
	    WOOL_send(WOOL_eval, *argv, (*argv));
	    zrt_gc(local_zrt_size);
	    argv++;
	}
	return WOOL_send(WOOL_eval, *argv, (*argv));
    } else {
	return NIL;
    }
}

/*
 * if "a la emacs"
 * if test thenclause [test thenclause]* [elseclause]
 * nearly a COND, in fact
 */

WOOL_OBJECT
wool_if(argc, argv)
int    argc;
WOOL_OBJECT *argv;
{
    while (argc > 1) {
	if (WOOL_send(WOOL_eval, *argv, (*argv)) != NIL) {
	    return WOOL_send(WOOL_eval, *(argv + 1), (*(argv + 1)));
	}
	argc -= 2;
	argv += 2;
	if (argc == 1) {
	    return WOOL_send(WOOL_eval, *argv, (*argv));
	}
    }
    return NIL;
}

/*
 * while cond inst1 ... instn
 * classical while
 */

WOOL_OBJECT
wool_while(argc, argv)
int    argc;
WOOL_OBJECT *argv;
{
    while (WOOL_send(WOOL_eval, *argv, (*argv)) != NIL) {
	progn(argc - 1, argv + 1);
    }
    return NIL;
}

/*
 * for:
 * (for var list-of-values instructions...)
 */

WOOL_OBJECT
wool_for_loop(argc, argv, map)
int    argc;
WOOL_List *argv;
int		map;
{
    WOOL_List       list, result_list;
    WOOL_OBJECT	    /* previous_value, */ result;
    int i;

    if (argc < 3)
	wool_error(BAD_NUMBER_OF_ARGS, (char *)argc);
    must_be_atom(argv[0], 0);
    list = (WOOL_List) WOOL_send(WOOL_eval, argv[1], (argv[1]));
    if (WLList_length(list) == 0)  /* (list == (WOOL_List) NIL) */
    	return NIL;

    WLStackFrame_push_value(argv[0]);

    if(map) {
    	result_list = wool_list_make(list -> size);
    	for (i = 0; i < list -> size; i++) {
	    WOOL_send(WOOL_setq, argv[0], (argv[0], list -> list[i]));
	    increase_reference(result_list -> list[i] =
		progn(argc - 2, argv + 2));
        }
    } else {
	for (i = 0; i < list -> size; i++) {
            WOOL_send(WOOL_setq, argv[0], (argv[0], list -> list[i]));
            result = progn(argc - 2, argv + 2);
	}
    }

    WLStackFrame_pop();

    return (map ? (WOOL_OBJECT) result_list : result);
}

WOOL_OBJECT
wool_for(argc, argv)
int    argc;
WOOL_List *argv;
{
    return wool_for_loop(argc, argv, 0);
}

WOOL_OBJECT
wool_mapfor(argc, argv)
int    argc;
WOOL_List *argv;
{
    return wool_for_loop(argc, argv, 1);
}



/*
 * TAG/EXIT:
 * (tag tag insts...)
 * (exit tag insts...)
 */

typedef struct _JumpingPoint {
    WOOL_StackFrame frame;
    int 	    level; 		/* in calling_function_stack */
    jmp_buf	    jump_buffer;
    WOOL_OBJECT	result;
} *JumpingPoint;

WOOL_OBJECT
wool_tag(argc, argv)
int             argc;
WOOL_String    *argv;
{
    struct _JumpingPoint tag;
    WOOL_OBJECT     result;
    WOOL_Pointer    tag_name;

    if (argc < 2)
	wool_error(BAD_NUMBER_OF_ARGS, (char *)argc);
    must_be_string(argv[0], 0);
    wool_self_pointer_make(argv[0] -> string, '\024', &tag_name);
    *(tag_name -> ptr) = (long) &tag;
    tag.frame = wool_current_stackframe;
    tag.level = calling_function_current - calling_function_stack;
    if (setjmp(tag.jump_buffer) != 0) /* nonzero is return from longjmp */
	result = tag.result;
    else
	result = progn(argc - 1, argv + 1);
    *(tag_name -> ptr) = 0;
    return result;
}
	
WOOL_OBJECT
wool_exit(argc, argv)
int             argc;
WOOL_String    *argv;
{
    JumpingPoint    tag;
    WOOL_Pointer    tag_name;
    WOOL_OBJECT     result;

    if (argc < 1)
	wool_error(BAD_NUMBER_OF_ARGS, (char *)argc);
    must_be_string(argv[0], 0);
    if (wool_self_pointer_make(argv[0] -> string, '\024', &tag_name)
	&& *(tag_name -> ptr)) {
	tag = (JumpingPoint) * (tag_name -> ptr);
	result = argc > 1 ? progn(argc - 1, argv + 1) : NIL;
	WLStackFrame_pop_to(tag -> frame);
	calling_function_current = calling_function_stack + tag -> level;
	tag -> result = result;
	longjmp(tag -> jump_buffer, -1);
    } else
	wool_error(UNDEFINED_VARIABLE, argv[0] -> string);
    return NIL;
}

/* the host name as a string
 */

WOOL_OBJECT
wool_hostname_get()
{
    if (!wool_host_name) {
	char buf[256];
	int maxlen = 256;
	int len;
#ifdef SYSV
	struct utsname name;
	
	uname (&name);
	len = strlen (name.nodename);
	if (len >= maxlen) len = maxlen - 1;
	strncpy (buf, name.nodename, len);
	buf[len] = '\0';
#else /* SYSV */
	buf[0] = '\0';
	(void) gethostname (buf, maxlen);
	buf [maxlen - 1] = '\0';
	len = strlen(buf);
#endif /* SYSV */
	increase_reference(wool_host_name = (WOOL_OBJECT) WLString_make(buf));
    }
    return  wool_host_name;
}

/*
 * very useful: de and df!
 * USAGE:
 * (de <func-name> (parameter-list) inst1 ... instn)
 * returns  the atom pointing to the subr
 */

WOOL_OBJECT
de(argc, argv)
int             argc;
WOOL_OBJECT    *argv;
{
    return defun(WLExpr, argc, argv);
}

WOOL_OBJECT
df(argc, argv)
int             argc;
WOOL_OBJECT    *argv;
{
    return defun(WLFExpr, argc, argv);
}

/*
 * wool_loadfile:
 * raw loadfile function: search EXACTLY for name in parameter
 */

WOOL_OBJECT
wool_loadfile(string)
char           *string;
{
    FILE           *fd, *oldinput;
    char            filename[MAX_TEMP_STRING_SIZE];
    int             local_zrt_size = zrt_size;

    if (!string)
	return NIL;
    strcpy(filename, string);
    fd = fopen(filename, "r");
    if (fd) {
	int             we_got_an_error = 0;
	char           *old_file = wool_is_reading_file;
	char            old_input_buffer[AHEAD_BUF_SIZE];
	int             oldtype = wool_input_redirect(0, fd, &oldinput,
						      old_input_buffer);
	int             old_yylineno = yylineno;

	save_wool_error_resume_point();	/* contains decls */
	yylineno = 1;
	wool_is_reading_file = filename;
	/* now, we must close the file and redirect input on error */
	if (wool_continue_reading_on_error) {
	    set_wool_error_resume_point();
	    while (wool_read()) {
		wool_eval(wool_read_expr);
		zrt_gc(local_zrt_size);
	    }
	} else {
	    if (set_wool_error_resume_point()) {
		we_got_an_error = 1;
	    } else {
		while (wool_read()) {
#ifdef READ_ECHO
		    printf("\"%s\"[%d]: ", filename, yylineno);
		    wool_print(wool_read_expr);
		    wool_puts("\n");
		    fflush(stdout);
		    fflush(stderr);
#endif
		    wool_eval(wool_read_expr);
		    zrt_gc(local_zrt_size);
		}
	    }
	}
	wool_input_redirect(oldtype, oldinput, 0, 0);
	wool_unput(old_input_buffer);
	fclose(fd);
	restore_wool_error_resume_point();
	wool_is_reading_file = old_file;
	yylineno = old_yylineno;
	if (we_got_an_error)
	    _wool_error(SILENT_ERROR, 0);
	return TRU;
    } else {
	return NIL;
    }
}

/* executes a given string */

WOOL_OBJECT
wool_execute_string(string)
char           *string;
{
    FILE           *oldinput;
    int             we_got_an_error = 0;
    char           *old_file = wool_is_reading_file;
    char            old_input_buffer[AHEAD_BUF_SIZE];
    int             oldtype = wool_input_redirect(1, string, &oldinput,
						  old_input_buffer);
    int             old_yylineno = yylineno;
    int             local_zrt_size = zrt_size;

    save_wool_error_resume_point();
    yylineno = 1;
    wool_is_reading_file = 0;
    /* now, we redirect input on error */
    if (set_wool_error_resume_point()) {
	we_got_an_error = 1;
    } else {
	while (wool_read()) {
	    wool_eval(wool_read_expr);
	    zrt_gc(local_zrt_size);
	}
    }
    wool_input_redirect(oldtype, oldinput, 0, 0);
    wool_unput(old_input_buffer);
    restore_wool_error_resume_point();
    wool_is_reading_file = old_file;
    yylineno = old_yylineno;
    if (we_got_an_error)
	return NIL;
    else
	return TRU;
}

/* same callable from wool */

WOOL_OBJECT
wool_execute_wool_string(string)
WOOL_String string;
{
    return wool_execute_string(string -> string);
}

/*
 * tests if file exists and is readable
 */

char *
file_exists(name)
char *name;
{
    /* Should detect if the file is a regular file, not a directory */
    struct stat sbuf;

    if ((stat(name, &sbuf)) < 0)
	return 0;
    if ((sbuf.st_mode & S_IFMT) == S_IFREG) {	/* regular file */
	if (access(name, R_OK)) {	/* good mode flags */
	    return 0;
	} else
	    return name;
    } else
	return 0;
}

/*
 * file_with_optional_extension:
 * see if file exists with extension
 */

char *
file_with_optional_extension(filename, extension)
char           *filename;
char           *extension;
{
    static char     filename_wl[MAX_TEMP_STRING_SIZE];

    strcpy(filename_wl, filename);
    strcat(filename_wl, extension);
    if(file_exists(filename_wl))
    	return filename_wl;
    return file_exists(filename);
}

/*
 * file_in_path:
 * find file with using path, extensions, etc...
 * complete_filename is a pointer to temporary space
 */

char *
file_in_path(filename, extension, path, complete_filename)
char           *filename, *extension, *path, *complete_filename;
{
    char  *directory, *name;
    int 	    dirlen;

    if (strchr(filename, '/')) {	/* absolute pathname */
	return (file_with_optional_extension(filename, extension));
    } else {			/* relative pathname */
	while (*path) {
	    directory = path;
	    dirlen = 0;
	    while (*path && (*path != ':')) {
		path++;
		dirlen++;
	    }
	    if (*path)
		path++;
	    complete_filename[dirlen] = '\0';
	    if (dirlen) {
		strncpy(complete_filename, directory, dirlen);
		if (complete_filename[dirlen - 1] != '/')
		    strcat(complete_filename, "/");
	    }
	    strcat(complete_filename, filename);
	    if (name = file_with_optional_extension(complete_filename,
						    extension))
		return name;
	}
	return 0;
    }
}


/*
 * loading a file (callable from wool)
 */

WOOL_OBJECT
wool_loadfile_in_path(string)
WOOL_String     string;
{
    char            temp_filename[MAX_TEMP_STRING_SIZE];
    char	   *actual_pathname = file_in_path(string -> string,
    			wool_text_extension, wool_path, temp_filename);

    if(NIL == wool_loadfile(actual_pathname)) {
	wool_puts(wool_application_NAME);
    	wool_printf(": file not found: %s\n", string -> string);
	return NIL;
    } else {
    	return (WOOL_OBJECT) WLString_make(actual_pathname);
    }
}

/*
 * cond for compatibility
 */

WOOL_OBJECT 
wool_cond(argc, argv)
int    argc;
WOOL_OBJECT *argv;
{
    WOOL_OBJECT    *list;
    WOOL_OBJECT     result = wool_if(argc * 2,
				  list = wool_flatten_pairlist(argc, argv));

    Free(list);
    return result;
}

/*
 * A context is a list of pairs variable-name/variable-values (atom/object).
 * Context operations are:
 * 
 * 	context-save: archives in the context the current values of
 * 		variables (sets to () undefined ones...)
 * 	context-restore: sets the variables to their archived values
 */

must_be_context(context, n)
WOOL_List	context;
int		n;
{
    if ((context != (WOOL_List) NIL)
	 && ((context -> type != WLList)
             || (context -> size % 2)))
	bad_argument(context, n, "even-sized list");
}

WOOL_OBJECT
wool_context_save(context)
WOOL_List	context;
{
    int             i;
    WOOL_List       new;

    must_be_context(context, 0);
    if (context == (WOOL_List) NIL)
        return NIL;
    new = wool_list_make(context -> size);
    for (i = 0; i < context -> size; i += 2) {
#ifdef        STUPID
      WOOL_OBJECT tmp;
#endif 
      increase_reference(new -> list[i] = context -> list[i]);
#ifdef  STUPID
      tmp = context -> list[i];
      if (tmp -> type == WLAtom &&
#else
      if (context -> list[i] -> type == WLAtom &&
#endif
	    (!((WOOL_Atom) context -> list[i]) -> c_val)) 
	    /*
	     * if atom is undefined, take the following element of the list
	     * as a value of new context 
	     */
	    increase_reference(new -> list[i + 1] = context -> list[i + 1]);
	else
	    increase_reference(new -> list[i + 1] =
	    WOOL_send(WOOL_eval, context -> list[i], (context -> list[i])));
    }
    return (WOOL_OBJECT) new;
}

WOOL_OBJECT
wool_context_restore(context)
WOOL_List	context;
{
    int             i;

    must_be_context(context, 0);
    for (i = 0; i < context -> size; i += 2)
	WOOL_send(WOOL_setq, context -> list[i],
		  (context -> list[i], context -> list[i + 1]));
    return (WOOL_OBJECT) context;
}

/*
 * wool_getenv:
 * makes the WOOL_String out of getenv(wool_string)
 */

WOOL_OBJECT
wool_getenv(obj)
WOOL_String obj;
{
    char  *result;

    if (result = (char *) getenv(obj -> string))
	return (WOOL_OBJECT) WLString_make(result);
    else
	return (WOOL_OBJECT) NIL_STRING;
}

/*
 * makes an atom out of a string
 */

WOOL_OBJECT
wool_atom_of_string(s)
WOOL_String	s;
{
    return (WOOL_OBJECT) wool_atom(s -> string);
}

/*
 * if object is from type, ok.
 * if not, evaluates it and call wool_error if result is still not
 * YOU MUST check reference on result when no longer needed!
 */

WOOL_OBJECT
wool_type_or_evaluate(object, type)
WOOL_OBJECT object;
WOOL_TYPE   type;
{
    if ((object == NIL) || (object -> type == type))
	return object;
    if (((object = WOOL_send(WOOL_eval, object, (object))) -> type == type)
	|| (object == NIL))
	return object;
    if (object == UNDEFINED_WOOL_VALUE)
	return wool_error(UNDEFINED_VARIABLE, "");
    return bad_argument(object, 0, WOOL_TYPE_P_NAME(type));
}

wool_user_end()
{
    wool_puts("Bye.\n");
    wool_end(0);
}

#ifdef DEBUG 			/* some routines convenient for debugging: */

stop_if_in_dbx(){} /* used in dbx */

int		dbxi = 0; 
WOOL_Atom 	dbxa;
WOOL_OBJECT 	dbxo;

PO(n)
int n;
{
    wool_print(n);
    wool_newline();
    fflush(stdout);
}

/*
 * break function for gwm for debugging purposes
 */

WOOL_OBJECT
wool_break(){return NIL;}	/* WOOL user break! */

WOOL_OBJECT
wp(obj)
WOOL_OBJECT     obj;
{
    wool_print_level = 0;
    WOOL_send(WOOL_print, obj, (obj));
    wool_newline();
    yyoutflush();
}

/*
 * type(obj) prints its type (under dbx!)
 */

wt(obj)
WOOL_OBJECT obj;
{
    printf("%s\n", ((WOOL_Atom) obj -> type[0]) -> p_name);
}

char *
type(obj)
WOOL_OBJECT obj;
{
    return ((WOOL_Atom) obj -> type[0]) -> p_name;
}


WOOL_OBJECT
wool_print_newline(obj)
WOOL_OBJECT     obj;
{
    WOOL_send(WOOL_print, obj, (obj));
    putchar('\n');
    return obj;
}

struct _UniqId {
    int size;
    int last;
    int *list;
};

int
UniqId(UI, n)
struct _UniqId *UI;
int n;
{
    int i;
    if (!UI->size) {
	UI->size = 4000;
	UI->list = (int *) Malloc(UI->size);
    }
    for (i=0; i< UI->last; i++) {
	if (UI->list[i] == n) {
	    return i;
	}
    }
    UI->list[i] = n;
    return (UI->last)++;
}

/* checksum on jump-buffers */

int
jmpbuf_checksum(jmpbuf)
int *jmpbuf;
{
    int i, result = 0;
    static struct _UniqId UI;
    for(i=0; i < sizeof(jmp_buf)/sizeof(int); i++)
	result = (result << 3) + (result >> 28) + jmpbuf[i];
    return UniqId(&UI, result);
}

#endif /* DEBUG */

WOOL_OBJECT
wool_type(obj)
WOOL_OBJECT obj;
{
    return (WOOL_OBJECT) obj->type[0];
}

wool_print_type(obj)
WOOL_OBJECT obj;
{
    WLAtom_print(obj -> type[0]);
}

#ifdef MONITOR
WOOL_OBJECT
wool_moncontrol(num)
WOOL_Number	num;
{
    moncontrol(num ->number);
}
#endif /* MONITOR */

/* tracing info
 */

WOOL_OBJECT
wool_get_trace()
{
    return (WOOL_OBJECT) WLNumber_make(wool_tracing_on);
}

/* (trace obj)
 * obj = expr, evals expr at each eval of list
 * obj = 0/1 turns tracing on/off (without resetting expr)
 * obj = t resets expr
 */

WOOL_OBJECT
wool_set_trace(obj)
WOOL_OBJECT obj;
{

    if(obj -> type == WLNumber) {
	wool_tracing_on = ((WOOL_Number) obj) -> number;
    } else if(obj == NIL) {
	wool_tracing_on = 0;
    } else {
	wool_tracing_on = 1;
	decrease_reference(wool_tracing_on_EXPR);
	if (obj == TRU)
	    wool_tracing_on_EXPR = 0;
	else
	    increase_reference(wool_tracing_on_EXPR = obj);
    }
    wool_still_tracing = wool_tracing_on;
    return obj;
}

/***************************************************************************\
* 									    *
* add .:$HOME:$HOME/gwm: before built-in-path (INSTALL_DIR) and returns it  *
* (malloced)								    *
* 									    *
\***************************************************************************/

char *
wool_fix_path(built_in_path)
char *built_in_path;
{
    char           *home = (char *) getenv("HOME");
    char           *path =
    Malloc(strlen(built_in_path) + 9 + 2*(home ? strlen(home) : 0));

    strcpy(path, ".:");
    if (home) {
	strcat(path, home);
	strcat(path, ":");
	strcat(path, home);
	strcat(path, "/");
	strcat(path, WOOL_APP_name);
	strcat(path, ":");
    }
    strcat(path, built_in_path);
    return path;
}

/****************************************\
* 					 *
*  INITIALISATION:			 *
*  to be called before everything else 	 *
* 					 *
\****************************************/

/*
 * wool_init returns 0 if all is ok
 * It calls its parameter function if not NULL, just before reading user
 * profile. Used by GWM for setting default keywords
 */

int
wool_init(client_initialisation)
int	(*client_initialisation)();
{
    /* initialize tables */
    zrt_init();
    dft_init();
    WLNumber_init();
    HashTable_init();

    /* initialize signals */
    SignalsInit();

    /* initialize wool's objects */

    wool_atom_make(WOOL_OBJECT, NIL, "()", NIL);	/* atoms */
    increase_reference(wool_atom("nil") -> c_val = NIL);
    wool_atom_make(WOOL_OBJECT, TRU, "t", TRU);
    NIL_STRING_make();
    WA_progn = (WOOL_OBJECT) wool_atom("progn");

    /* init stack */
    WLStackFrame_init();
    calling_function_init();

    /* intitialise predefined functions (Subrs) */
    QUOTE = wool_subr_make(WLFSubr, wool_quote, "quote", 1);
    wool_subr_make(WLFSubr, setq, "setq", 2);
    wool_subr_make(WLFSubr, setq, ":", 2);
    wool_subr_make(WLSubr, set, "set", 2);
    wool_subr_make(WLSubr, wool_multiply, "*", 2);
    wool_subr_make(WLSubr, wool_divide, "/", 2);
    wool_subr_make(WLSubr, wool_modulo, "%", 2);
    wool_subr_make(WLSubr, wool_add, "+", NARY);
    wool_subr_make(WLSubr, wool_minus, "-", NARY);
    increase_reference(wool_atom("defun") -> c_val =
		       wool_subr_make(WLFSubr, de, "de", NARY));
    increase_reference(wool_atom("defunq") -> c_val =
		       wool_subr_make(WLFSubr, df, "df", NARY));
    wool_subr_make(WLFSubr, wool_lambda_make, "lambda", NARY);
    wool_subr_make(WLFSubr, wool_lambdaq_make, "lambdaq", NARY);
    wool_subr_make(WLSubr, wool_atom_of_string, "atom", 1);
    wool_subr_make(WLFSubr, progn, "progn", NARY);
    wool_subr_make(WLFSubr, wool_if, "if", NARY);
    wool_subr_make(WLFSubr, wool_cond, "cond", NARY);
    increase_reference(wool_atom("equal") -> c_val =
		       wool_subr_make(WLSubr, wool_equal, "=", 2));
    wool_subr_make(WLSubr, wool_eq, "eq", 2);
    wool_subr_make(WLSubr, greater_than, ">", 2);
    wool_subr_make(WLSubr, lesser_than, "<", 2);
    wool_subr_make(WLSubr, wool_compare, "compare", 2);
    wool_subr_make(WLSubr, shell, "!", NARY);
    increase_reference(wool_atom("print") -> c_val =
		       wool_subr_make(WLSubr, wool_print_nary, "?", NARY));
    wool_subr_make(WLFSubr, wool_with_output_to_string,
                   "with-output-to-string", NARY);
    wool_subr_make(WLFSubr, wool_with_output_to_file,
                   "with-output-to-file", NARY);
    wool_subr_make(WLSubr, not, "not", 1);
    wool_subr_make(WLFSubr, and, "and", NARY);
    wool_subr_make(WLFSubr, or, "or", NARY);
    increase_reference(wool_atom("together") -> c_val =
	       wool_subr_make(WLSubr, wool_bitwise_or, "bitwise-or", NARY));
    wool_subr_make(WLSubr, wool_bitwise_and, "bitwise-and", NARY);
    wool_subr_make(WLSubr, wool_bitwise_xor, "bitwise-xor", NARY);
    wool_subr_make(WLFSubr, wool_while, "while", NARY);
    wool_subr_make(WLFSubr, wool_for, "for", NARY);
    wool_subr_make(WLFSubr, wool_mapfor, "mapfor", NARY);
    wool_subr_make(WLFSubr, wool_with, "with", NARY);
    wool_subr_make(WLFSubr, wool_with_eval, "with-eval", NARY);
    wool_subr_make(WLSubr, wool_context_save, "context-save", 1);
    wool_subr_make(WLSubr, wool_context_restore, "context-restore", 1);
    wool_subr_make(WLSubr, wool_loadfile_in_path, "load", 1);
    wool_subr_make(WLSubr, wool_execute_wool_string, "execute-string", 1);
    wool_subr_make(WLSubr, eval, "eval", 1);
    wool_subr_make(WLSubr, wool_getenv, "getenv", 1);
    wool_subr_make(WLSubr, wool_unbind, "unbind", 1);
    wool_subr_make(WLSubr, wool_boundp, "boundp", 1);
    wool_subr_make(WLSubr, WLString_match, "match", NARY);
    wool_subr_make(WLSubr, wool_length, "length", 1);
    wool_subr_make(WLSubr, WLList_sub, "sublist", NARY);
    increase_reference(wool_atom("nth") -> c_val =
		       wool_subr_make(WLSubr, WLList_nth, "#", NARY));
    increase_reference(wool_atom("replace-nth") -> c_val =
		    wool_subr_make(WLSubr, WLList_replace_nth, "##", NARY));
    wool_subr_make(WLSubr, WLList_delete_nth, "delete-nth", 2);
    wool_subr_make(WLFSubr, wool_user_end, "end", 0);
    wool_subr_make(WLSubr, wool_atoi, "atoi", 1);
    wool_subr_make(WLSubr, wool_itoa, "itoa", 1);
    wool_subr_make(WLSubr, wool_hack, "hack", 2);
    wool_subr_make(WLSubr, wool_list, "list", NARY);
    wool_subr_make(WLFSubr, wool_tag, "tag", NARY);
    wool_subr_make(WLFSubr, wool_exit, "exit", NARY);
    wool_subr_make(WLSubr, wool_type, "type", 1);
    wool_subr_make(WLFSubr, wool_error_has_occurred, "error-occurred", NARY);
    wool_subr_make(WLSubr, wool_trigger_error, "trigger-error", NARY);
    wool_subr_make(WLSubr, wool_copy, "copy", 1);
    wool_subr_make(WLSubr, wool_used_time, "elapsed-time", 0);
    wool_subr_make(WLSubr, wool_member, "member", 2);
    wool_subr_make(WLSubr, WLNamespace_make, "namespace-make", 0);
    wool_subr_make(WLSubr, WLNamespace_add, "namespace-add", 1);
    wool_subr_make(WLSubr, WLNamespace_remove, "namespace-remove", 2);
    wool_subr_make(WLSubr, WLName_add, "defname", NARY);
    wool_subr_make(WLSubr, WLNamespace_set_current, "namespace", 2);
    wool_subr_make(WLSubr, WLName_namespace, "namespace-of", 1);
    wool_subr_make(WLSubr, WLNamespace_size, "namespace-size", 1);
    wool_subr_make(WLSubr, WLList_qsort, "sort", 2);
    wool_active_make("hostname", wool_hostname_get, NULL);

    /* --- */
#ifdef STATS
    wool_subr_make(WLFSubr, zrtstats, "gcinfo", 0);
    wool_subr_make(WLFSubr, wlcfstats, "wlcfinfo", 0);
    wool_subr_make(WLFSubr, WlMstats, "meminfo", 0);
    wool_subr_make(WLFSubr, hashstats, "hashinfo", 0);
    wool_subr_make(WLFSubr, oblist, "oblist", 0);
#else /* STATS */
    wool_subr_make(WLFSubr, NIL_FUNC, "gcinfo", 0);
    wool_subr_make(WLFSubr, NIL_FUNC, "wlcfinfo", 0);
    wool_subr_make(WLFSubr, NIL_FUNC, "meminfo", 0);
    wool_subr_make(WLFSubr, NIL_FUNC, "hashinfo", 0);
    wool_subr_make(WLFSubr, NIL_FUNC, "oblist", 0);
#endif /* STATS */
#ifdef DEBUG
    wool_subr_make(WLFSubr, wool_break, "break", 0);
#ifdef GWM
    wool_subr_make(WLSubr, WLFsm_fp, "print-fsm", 1);
    wool_subr_make(WLSubr, WLState_fp, "print-state", 1);
    wool_subr_make(WLSubr, WLArc_fp, "print-arc", 1);
#endif
#else /* DEBUG */
    wool_subr_make(WLFSubr, NIL_FUNC, "break", 0);
#endif /* DEBUG */
#ifdef MONITOR
    wool_subr_make(WLSubr, wool_moncontrol, "moncontrol", 1);
#endif /* MONITOR */
#ifdef USER_DEBUG
    wool_active_make("trace", wool_get_trace, wool_set_trace);
    wool_pointer_make("trace-level", &wool_tracing_level);
#endif /* USER_DEBUG */

    wool_pointer_make("print-level", &wool_max_print_level);
    wool_pointer_make("stack-print-level", &wool_max_stack_print_level);

    /* here do client inits before the profile is read */
    if (client_initialisation)
	(*client_initialisation) ();

    /* first time, load the user file */
    wool_error_status = 0;
    if (!set_wool_error_resume_point()) {
	zrt_gc(0);
	if (wool_loadfile_in_path(wool_atom(wool_user_profile_name)) == NIL) {
	    return 1;
	}
    }
    wlcf_flush();
    wool_error_in_profile = wool_error_status;
    set_wool_error_resume_point();
    dft_gc();

    return 0;
}