midfavila
/
Generic_Window_Manager
1
0
Fork 0
Code Issues 4 Pull Requests Projects Releases Wiki Activity
Generic_Window_Manager/wool.c

2194 lines
50 KiB
C
Raw Blame History

/* 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 <string.h>
#include <stdlib.h>
#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;
}
Reference in New Issue View Git Blame Copy Permalink