/* csl.c Copyright (C) 1989-2007 Codemist Ltd */
/*
* This is Lisp system for use when delivering Lisp applications
* (such as REDUCE) on pretty-well any computer that has an ANSI
* C compiler where sizeof(void *)==4 and there is in integral
* type that is also 4 bytes wide. In fact I can also manage if
* sizeof(void *)==8 provided that it can be arranged that all
* addresses returned by malloc() have only their bottom 32 bits
* set... And with even more care I can manage on true 64 bit systems,
* although arithmetic then does not take advantage of the wider words.
*/
/*
* This code may be used and modified, and redistributed in binary
* or source form, subject to the "CCL Public License", which should
* accompany it. This license is a variant on the BSD license, and thus
* permits use of code derived from this in either open and commercial
* projects: but it does require that updates to this code be made
* available back to the originators of the package.
* Before merging other code in with this or linking this code
* with other packages or libraries please check that the license terms
* of the other material are compatible with those of this.
*/
/* Signature: 783627cd 12-Apr-2008 */
#define INCLUDE_ERROR_STRING_TABLE 1
#include "headers.h"
#undef INCLUDE_ERROR_STRING_TABLE
#include "version.h"
#ifdef SOCKETS
#include "sockhdr.h"
#endif
#ifndef WIN32
#include <sys/wait.h>
#endif
#ifdef HAVE_UNISTD_H
#include <sys/unistd.h>
#endif
#ifndef HAVE_FWIN
/*
* During startup on a windowed system if I needed to report an error
* but the window was minimised I need to restore it...
*/
#define fwin_restore()
#endif
#ifdef SOCKETS
static int port_number, remote_store, current_users, max_users;
SOCKET socket_server;
int sockets_ready;
clock_t cpu_timeout;
time_t elapsed_timeout;
static int char_to_socket(int c);
#endif
/*
* These flags are used to ensure that protected symbols don't get
* overwritten by default, and that the system keeps quiet about it.
*/
CSLbool symbol_protect_flag = YES;
CSLbool warn_about_protected_symbols = NO;
#ifdef WINDOW_SYSTEM
CSLbool use_wimp;
#endif
#ifdef USE_MPI
int32_t mpi_rank,mpi_size;
#endif
/*****************************************************************************/
/* Error reporting and recovery */
/*****************************************************************************/
#ifdef CHECK_STACK
/*
* Some computers are notably unhelpful about their behaviour when the system
* stack overflows. As a debugging tool on such machines I can do limited
* software checking by inserting explicit calls to this function in places
* I think may be critical. I impose an arbitrary limit on the stack size,
* but that is better than no checking and random corruption - maybe. Please
* do not enable CHECK_STACK unless it is really necessary to hunt a bug,
* since it is miserably expensive and crude.
*/
#define C_STACK_ALLOCATION 240000
static int spset = 0;
static int32_t spbase = 0, spmin;
static int stack_depth[C_STACK_ALLOCATION], stack_line[C_STACK_ALLOCATION];
static char *stack_file[C_STACK_ALLOCATION];
static int c_stack_ptr = 0;
int check_stack(char *file, int line)
{
int32_t temp = (int32_t)&temp;
if (!spset)
{ spbase = spmin = temp;
spset = 1;
c_stack_ptr = 0;
stack_depth[0] = temp;
stack_line[0] = line;
stack_file[0] = file;
}
if (temp < stack_depth[c_stack_ptr] && c_stack_ptr<C_STACK_ALLOCATION-2)
c_stack_ptr++;
else while (temp > stack_depth[c_stack_ptr] && c_stack_ptr>0)
c_stack_ptr--;
stack_depth[c_stack_ptr] = temp;
stack_line[c_stack_ptr] = line;
stack_file[c_stack_ptr] = file;
if (temp < spmin-250) /* Only check at granularity of 250 bytes */
{ int i;
term_printf("Stack depth %d at file %s line %d\n",
spbase-temp, file, line);
for (i=c_stack_ptr; i>=0 && i > c_stack_ptr-30; i--)
term_printf(" %s:%d", stack_file[i], stack_line[i]);
term_printf("\n");
spmin = temp;
if (temp < spbase-C_STACK_ALLOCATION) return 1;
}
return 0;
}
#endif
/*
* error_message_table was defined in cslerror.h since that way I can keep its
* contents textually close to the definitions of the message codes that it
* has to relate to.
*/
#define errcode(n) error_message_table[n]
Lisp_Object MS_CDECL error(int nargs, int code, ...)
/*
* nargs indicates how many values have been provided AFTER the
* code. Thus nargs==0 will just display a simple message, nargs==1
* will be a message plus a value and so on. I will expect that the
* number of actual args here is well within any limits that I ought to
* impose.
*/
{
va_list a;
int i;
Lisp_Object nil = C_nil, w1;
Lisp_Object *w = (Lisp_Object *)&work_1;
if (nargs > ARG_CUT_OFF) nargs = ARG_CUT_OFF;
if (miscflags & (HEADLINE_FLAG|ALWAYS_NOISY))
{ err_printf("\n+++ Error %s: ", errcode(code));
/*
* There is now some painful shuffling around to get all the args
* to error() moved over onto the Lisp stack so that is garbage collection
* is triggered during printing all will be well.
*/
va_start(a, code);
for (i=0; i<nargs; i++) *w++ = va_arg(a, Lisp_Object);
va_end(a);
for (i=0; i<nargs; i++) push(*--w);
if (code != err_stack_overflow) /* Be cautious here! */
{ stackcheck0(nargs);
}
for (i=0; i<nargs; i++)
{ Lisp_Object p;
pop(p);
loop_print_error(p);
err_printf("\n");
}
}
if ((w1 = qvalue(break_function)) != nil &&
symbolp(w1) &&
qfn1(w1) != undefined1)
{ (*qfn1(w1))(qenv(w1), nil);
ignore_exception();
}
/*
* After doing this is is necessary to be VERY careful, since nil is
* used as a base register for lots of things... Still this is the
* cheapest way I can see to mark the need for unwinding.
*/
exit_reason = (miscflags & (MESSAGES_FLAG|ALWAYS_NOISY)) ? UNWIND_ERROR :
UNWIND_UNWIND;
exit_value = exit_tag = nil;
exit_count = 0;
flip_exception();
return nil;
}
Lisp_Object MS_CDECL cerror(int nargs, int code1, int code2, ...)
/*
* nargs indicated the number of EXTRA args after code1 & code2.
*/
{
Lisp_Object nil = C_nil, w1;
va_list a;
int i;
Lisp_Object *w = (Lisp_Object *)&work_1;
if (nargs > ARG_CUT_OFF) nargs = ARG_CUT_OFF;
if (miscflags & (HEADLINE_FLAG|ALWAYS_NOISY))
{ err_printf("\n+++ Error %s, %s: ", errcode(code1), errcode(code2));
va_start(a, code2);
for (i=0; i<nargs; i++) *w++ = va_arg(a, Lisp_Object);
va_end(a);
for (i=0; i<nargs; i++) push(*--w);
stackcheck0(nargs-2);
nil = C_nil;
for (i=0; i<nargs; i++)
{ Lisp_Object p;
pop(p);
loop_print_error(p);
err_printf("\n");
}
}
if ((w1 = qvalue(break_function)) != nil &&
symbolp(w1) &&
qfn1(w1) != undefined1)
{ (*qfn1(w1))(qenv(w1), nil);
ignore_exception();
}
/*
* After doing this is is necessary to be VERY careful, since nil is
* used as a base register for lots of things... Still this is the
* cheapest way I can see to mark the need for unwinding.
*/
exit_reason = (miscflags & (MESSAGES_FLAG|ALWAYS_NOISY)) ? UNWIND_ERROR :
UNWIND_UNWIND;
exit_value = exit_tag = nil;
exit_count = 0;
flip_exception();
return nil;
}
Lisp_Object interrupted(Lisp_Object p)
/*
* Could return onevalue(p) to proceed from the interrupt event...
*/
{
Lisp_Object nil = C_nil, w;
/*
* If I have a windowed system I expect that the mechanism for
* raising an exception will have had a menu that gave me a chance
* to decide whether to proceed or abort. Thus the following code
* is only needed if there is no window system active. On some systems
* this may be an active check.
*/
#ifdef HAVE_FWIN
if ((fwin_windowmode() & FWIN_IN_WINDOW) == 0)
#else
#ifdef WINDOW_SYSTEM
if (!use_wimp)
#endif
#endif
{
if (clock_stack == &consolidated_time[0])
{ clock_t t0 = read_clock();
/*
* On at least some (Unix) systems clock_t is a 32-bit signed value
* and CLOCKS_PER_SEC = 1000000. The effect is that integer overflow
* occurs after around 35 minutes of running. I must therefore check the
* clock and move information into a floating point variable at least
* every half-hour. With luck I will do it more like 20 times per second
* because I have code muck like this in a tick handler that is activated
* on a rather regular basis on at least some systems. On others this
* clock overfow issue is a bit of a pain and I really ought just to use
* a different low-level API for timing that can not so suffer. But
* as a bit of a fall-back I will see if the garbage collector can
* consolidate time for me and since I ignore time spent waiting for the
* keyboard overflows due to 35 minutes of activity there will not hurt so
* I am probably at worst at risk if I can compute for a solid half
* hour without triggering garbage collection.
*/
double delta = (double)(t0 - base_time)/(double)CLOCKS_PER_SEC;
base_time = t0;
consolidated_time[0] += delta;
}
#ifndef NAG
#ifdef HAVE_FWIN
term_printf("\n");
#else
term_printf(
"\n+++ [%.2f+%.2f] Type C to continue, A to abort, X to exit\n",
consolidated_time[0], gc_time);
#endif
ensure_screen(); nil = C_nil;
if (exception_pending()) return nil;
push(prompt_thing);
prompt_thing = CHAR_EOF;
#ifdef HAVE_FWIN
fwin_set_prompt("+++ Type C to continue, A to abort, X to exit: ");
#endif
other_read_action(READ_FLUSH, lisp_terminal_io);
for (;;)
{ int c = char_from_terminal(nil);
/*
* Note that I explicitly say "char_from_terminal()" here - this is because
* I do not expect to be interrupted unless there was a terminal available
* to send the interrupt! This is in fact a slightly marginal assumption.
*/
switch (c)
{
case 'c': case 'C': /* proceed as if no interrupt */
pop(prompt_thing);
#ifdef HAVE_FWIN
fwin_set_prompt(prompt_string);
#endif
return onevalue(p);
case 'a': case 'A': /* raise an exception */
break;
case 'x': case 'X':
my_exit(EXIT_FAILURE); /* Rather abrupt */
case '\n':
#ifndef HAVE_FWIN
term_printf("C to continue, A to abort, X to exit: ");
#endif
ensure_screen(); nil = C_nil;
if (exception_pending()) return nil;
continue;
default: /* wait for A or C */
continue;
}
break;
}
pop(prompt_thing);
#ifdef HAVE_FWIN
fwin_set_prompt(prompt_string);
#endif
#endif
}
/*
* now for the common code to be used in all cases.
*/
if (miscflags & (HEADLINE_FLAG|ALWAYS_NOISY))
err_printf("+++ Interrupted\n");
if ((w = qvalue(break_function)) != nil &&
symbolp(w) &&
qfn1(w) != undefined1)
{ (*qfn1(w))(qenv(w), nil);
ignore_exception();
}
exit_reason = (miscflags & (MESSAGES_FLAG|ALWAYS_NOISY)) ? UNWIND_ERROR :
UNWIND_UNWIND;
exit_value = exit_tag = nil;
exit_count = 0;
flip_exception();
return nil;
}
Lisp_Object aerror(char *s)
{
Lisp_Object nil = C_nil, w;
if (miscflags & (HEADLINE_FLAG|ALWAYS_NOISY))
err_printf("+++ Error bad args for %s\n", s);
if ((w = qvalue(break_function)) != nil &&
symbolp(w) &&
qfn1(w) != undefined1)
{ (*qfn1(w))(qenv(w), nil);
ignore_exception();
}
exit_reason = (miscflags & (MESSAGES_FLAG|ALWAYS_NOISY)) ? UNWIND_ERROR :
UNWIND_UNWIND;
exit_value = exit_tag = nil;
exit_count = 0;
flip_exception();
return nil;
}
Lisp_Object aerror0(char *s)
{
Lisp_Object nil = C_nil, w;
if (miscflags & (HEADLINE_FLAG|ALWAYS_NOISY))
err_printf("+++ Error: %s\n", s);
if ((w = qvalue(break_function)) != nil &&
symbolp(w) &&
qfn1(w) != undefined1)
{ (*qfn1(w))(qenv(w), nil);
ignore_exception();
}
exit_reason = (miscflags & (MESSAGES_FLAG|ALWAYS_NOISY)) ? UNWIND_ERROR :
UNWIND_UNWIND;
exit_value = exit_tag = nil;
exit_count = 0;
flip_exception();
#ifdef COMMON
/*
* This is to help me debug in the face of low level system crashes
*/
if (spool_file) fflush(spool_file);
#endif
return nil;
}
Lisp_Object aerror1(char *s, Lisp_Object a)
{
Lisp_Object nil = C_nil, w;
if (miscflags & (HEADLINE_FLAG|ALWAYS_NOISY))
{ err_printf("+++ Error: %s ", s);
loop_print_error(a);
err_printf("\n");
}
if ((w = qvalue(break_function)) != nil &&
symbolp(w) &&
qfn1(w) != undefined1)
{ (*qfn1(w))(qenv(w), nil);
ignore_exception();
}
exit_reason = (miscflags & (MESSAGES_FLAG|ALWAYS_NOISY)) ? UNWIND_ERROR :
UNWIND_UNWIND;
exit_value = exit_tag = nil;
exit_count = 0;
flip_exception();
#ifdef COMMON
/*
* This is to help me debug in the face of low level system crashes
*/
if (spool_file) fflush(spool_file);
#endif
return nil;
}
Lisp_Object aerror2(char *s, Lisp_Object a, Lisp_Object b)
{
Lisp_Object nil = C_nil, w;
if (miscflags & (HEADLINE_FLAG|ALWAYS_NOISY))
{ err_printf("+++ Error: %s ", s);
loop_print_error(a);
err_printf(" ");
loop_print_error(b);
err_printf("\n");
}
if ((w = qvalue(break_function)) != nil &&
symbolp(w) &&
qfn1(w) != undefined1)
{ (*qfn1(w))(qenv(w), nil);
ignore_exception();
}
exit_reason = (miscflags & (MESSAGES_FLAG|ALWAYS_NOISY)) ? UNWIND_ERROR :
UNWIND_UNWIND;
exit_value = exit_tag = nil;
exit_count = 0;
flip_exception();
#ifdef COMMON
/*
* This is to help me debug in the face of low level system crashes
*/
if (spool_file) fflush(spool_file);
#endif
return nil;
}
static Lisp_Object wrong(int wanted, int given, Lisp_Object env)
{
char msg[64];
Lisp_Object nil = C_nil;
CSL_IGNORE(nil);
sprintf(msg, "Function called with %d args where %d wanted", given, wanted);
if (is_cons(env)) env = qcdr(env);
if ((miscflags & (HEADLINE_FLAG|ALWAYS_NOISY)) && is_vector(env))
{ Lisp_Object fname = elt(env, 0);
err_printf("\nCalling ");
loop_print_error(fname);
err_printf("\n");
}
return aerror(msg);
}
Lisp_Object too_few_2(Lisp_Object env, Lisp_Object a1)
{
CSL_IGNORE(a1);
return wrong(2, 1, env);
}
Lisp_Object too_many_1(Lisp_Object env, Lisp_Object a1, Lisp_Object a2)
{
CSL_IGNORE(a1);
CSL_IGNORE(a2);
return wrong(1, 2, env);
}
Lisp_Object wrong_no_0a(Lisp_Object env, Lisp_Object a1)
{
CSL_IGNORE(a1);
return wrong(0, 1, env);
}
Lisp_Object wrong_no_0b(Lisp_Object env, Lisp_Object a1, Lisp_Object a2)
{
CSL_IGNORE(a1);
CSL_IGNORE(a2);
return wrong(0, 2, env);
}
Lisp_Object wrong_no_3a(Lisp_Object env, Lisp_Object a1)
{
CSL_IGNORE(a1);
return wrong(3, 1, env);
}
Lisp_Object wrong_no_3b(Lisp_Object env, Lisp_Object a1, Lisp_Object a2)
{
CSL_IGNORE(a1);
CSL_IGNORE(a2);
return wrong(3, 2, env);
}
Lisp_Object wrong_no_na(Lisp_Object env, Lisp_Object a1)
{
CSL_IGNORE(a1);
if (is_cons(env) && is_bps(qcar(env)))
return wrong(((unsigned char *)data_of_bps(qcar(env)))[0], 1, env);
else return aerror("function called with 1 arg when 0 or >= 3 wanted");
}
Lisp_Object wrong_no_nb(Lisp_Object env, Lisp_Object a1, Lisp_Object a2)
{
CSL_IGNORE(a1);
CSL_IGNORE(a2);
if (is_cons(env) && is_bps(qcar(env)))
return wrong(((unsigned char *)data_of_bps(qcar(env)))[0], 2, env);
else return aerror("function called with 2 args when 0 or >= 3 wanted");
}
Lisp_Object MS_CDECL wrong_no_1(Lisp_Object env, int nargs, ...)
{
CSL_IGNORE(env);
CSL_IGNORE(nargs);
return wrong(1, nargs, env);
}
Lisp_Object MS_CDECL wrong_no_2(Lisp_Object env, int nargs, ...)
{
CSL_IGNORE(env);
CSL_IGNORE(nargs);
return wrong(2, nargs, env);
}
Lisp_Object bad_special2(Lisp_Object env, Lisp_Object a1, Lisp_Object a2)
{
CSL_IGNORE(env);
CSL_IGNORE(a1);
CSL_IGNORE(a2);
return aerror("call to special form");
}
Lisp_Object MS_CDECL bad_specialn(Lisp_Object env, int nargs, ...)
{
CSL_IGNORE(env);
CSL_IGNORE(nargs);
return aerror("call to special form");
}
void MS_CDECL fatal_error(int code, ...)
{
/*
* Note that FATAL error messages are sent to the terminal, not to the
* error output stream. This is because the error output stream may be
* corrupted in such dire circumstances.
*/
term_printf("+++ Fatal error %s\n", errcode(code));
if (spool_file != NULL)
{
#ifdef COMMON
fprintf(spool_file, "\nFinished dribbling to %s.\n", spool_file_name);
#else
fprintf(spool_file, "\n+++ Transcript terminated after error +++\n");
#endif
fclose(spool_file);
spool_file = NULL;
}
my_exit(EXIT_FAILURE);
}
#ifndef __cplusplus
static jmp_buf my_exit_buffer;
static volatile int my_return_code = 0;
#endif
void my_exit(int n)
{
/*
* This all seems a HORRID MESS. It is here because of a general need to
* tidy up at the end of a run, and the fact that I may be running as
* a sub-task of some other package so I can not let atexit() take the
* strain since although I am exiting CSL here I may not be (quite yet)
* leaving the whole of the current application.
*/
#ifdef USE_MPI
MPI_Finalize();
#endif
ensure_screen();
#ifdef SOCKETS
if (sockets_ready) WSACleanup();
#endif
#ifdef WINDOW_SYSTEM
pause_for_user();
#endif
#ifdef HAVE_FWIN
#ifdef __cplusplus
throw n;
#else
/*
* When I am compiling in C I will be ultra-cautions and only ever use
* "1" as the second argument to longjmp. Here, which is the only place
* where I want to hand back a value I might (often!) want to hand back the
* value "0", so I put it in a static variable (and make that volatile to
* help it survive setjmp/longjmp). Doing things this was is also a valuable
* temporary expedient for the 64-bit variant on mingw at a stage where that
* is not fully settled!
*/
my_return_code = n;
longjmp(my_exit_buffer, 1);
#endif
#else
#if defined(WIN32) && defined(NAG)
{ extern void sys_abort(int);
sys_abort(n);
}
#else
exit(n);
#endif
#endif
}
static int return_code = 0;
CSLbool segvtrap = YES;
CSLbool batch_flag = NO;
CSLbool ignore_restart_fn = NO;
static void lisp_main(void)
{
Lisp_Object nil;
#ifndef __cplusplus
/*
* The setjmp here is to provide a long-stop for untrapped
* floating point exceptions.
*/
jmp_buf this_level, *save_level = errorset_buffer;
#endif
tty_count = 0;
while (YES)
/*
* The sole purpose of the while loop here is to allow me to proceed
* for a second try if I get a (cold-start) call.
*/
{ Lisp_Object *save = stack;
nil = C_nil;
#ifndef __cplusplus
errorset_buffer = &this_level;
#endif
errorset_msg = NULL;
#ifdef __cplusplus
try
#else
if (!setjmp(this_level))
#endif
{ nil = C_nil;
if (supervisor != nil && !ignore_restart_fn)
{ miscflags |= HEADLINE_FLAG | MESSAGES_FLAG;
if (exit_charvec != NULL)
{ Lisp_Object a = read_from_vector(exit_charvec);
nil = C_nil;
if (exception_pending())
{ flip_exception();
a = nil;
}
exit_charvec = NULL;
push(a);
apply(supervisor, 1, nil, supervisor);
}
else apply(supervisor, 0, nil, supervisor);
}
/*
* Here the default read-eval-print loop used if the user has not provided
* a supervisor function.
*/
else read_eval_print(lisp_true);
}
#ifdef __cplusplus
catch (char *)
#else
else
#endif
{ nil = C_nil;
if (errorset_msg != NULL)
{ term_printf("\n%s detected\n", errorset_msg);
errorset_msg = NULL;
}
unwind_stack(save, NO);
exit_reason = UNWIND_ERROR;
flip_exception();
#ifndef UNDER_CE
signal(SIGFPE, low_level_signal_handler);
if (segvtrap) signal(SIGSEGV, low_level_signal_handler);
#ifdef SIGBUS
if (segvtrap) signal(SIGBUS, low_level_signal_handler);
#endif
#ifdef SIGILL
if (segvtrap) signal(SIGILL, low_level_signal_handler);
#endif
#endif
}
nil = C_nil;
if (exception_pending())
{ flip_exception();
if (exit_reason == UNWIND_RESTART)
{ if (exit_tag == fixnum_of_int(0)) /* "stop" */
return_code = (int)int_of_fixnum(exit_value);
else if (exit_tag == fixnum_of_int(1)) /* "preserve" */
{ char *msg = "";
return_code = EXIT_SUCCESS;
compression_worth_while = 128;
if (is_vector(exit_value) &&
type_of_header(vechdr(exit_value)) == TYPE_STRING)
msg = &celt(exit_value, 0);
preserve(msg);
nil = C_nil;
if (exception_pending())
{ flip_exception();
return_code = EXIT_FAILURE;
}
}
else /* "restart" */
{ int32_t fd = stream_pushed_char(lisp_terminal_io);
char new_module[64], new_fn[64]; /* Limited name length */
int cold_start;
cold_start = (exit_value == nil);
/*
* Of course a tick may very well have happened rather recently - so
* I will flush it out now just to clear the air.
*/
if (stack >= stacklimit)
{ reclaim(nil, "stack", GC_STACK, 0);
ignore_exception();
}
cold_start = (exit_value == nil);
Lrds(nil, nil);
Lwrs(nil, nil);
/*
* If either of the above two calls to rds/wrs were to fail I would
* be in a big mess.
*/
if (!cold_start)
{ new_module[0] = 0;
new_fn[0] = 0;
if (exit_value != lisp_true)
{ Lisp_Object modname = nil;
if (is_cons(exit_value))
{ modname = qcar(exit_value);
exit_value = qcdr(exit_value);
if (is_cons(exit_value))
exit_value = qcar(exit_value);
}
if (symbolp(modname) && modname != nil)
{ modname = get_pname(modname);
if (exception_pending()) ignore_exception();
else
{ Header h = vechdr(modname);
int32_t len = length_of_header(h) - CELL;
if (len > 63) len = 63;
memcpy(new_module,
(char *)modname + (CELL - TAG_VECTOR),
(size_t)len);
new_module[len] = 0;
}
}
if (symbolp(exit_value) && exit_value != nil)
{ exit_value = get_pname(exit_value);
if (exception_pending()) ignore_exception();
else
{ Header h = vechdr(exit_value);
int32_t len = length_of_header(h) - CELL;
if (len > 63) len = 63;
memcpy(new_fn,
(char *)exit_value + (CELL - TAG_VECTOR),
(size_t)len);
new_fn[len] = 0;
}
}
}
}
while (vheap_pages_count != 0)
pages[pages_count++] = vheap_pages[--vheap_pages_count];
while (heap_pages_count != 0)
pages[pages_count++] = heap_pages[--heap_pages_count];
while (bps_pages_count != 0)
pages[pages_count++] = bps_pages[--bps_pages_count];
/*
* When I call restart-csl I will leave the random number generator where it
* was. Anybody who wants to reset if either to a freshly randomised
* configuration or to a defined condition must do so for themselves. For
* people who do not care too much what I do here is probably acceptable!
*/
CSL_MD5_Init();
CSL_MD5_Update((unsigned char *)errcode(err_registration), 32);
IreInit();
setup(cold_start ? 0 : 1, 0.0);
exit_tag = exit_value = nil;
exit_reason = UNWIND_NULL;
stream_pushed_char(lisp_terminal_io) = fd;
interrupt_pending = already_in_gc = NO;
tick_pending = tick_on_gc_exit = NO;
if (!cold_start && new_fn[0] != 0)
{ Lisp_Object w;
if (new_module[0] != 0)
{ w = make_undefined_symbol(new_module);
Lload_module(nil, w);
ignore_exception();
}
w = make_undefined_symbol(new_fn);
nil = C_nil;
if (exception_pending()) ignore_exception();
else supervisor = w;
}
continue;
}
}
}
/*
* In all normal cases when read_eval_print exits (i.e. all cases except
* if it terminates after (cold-start)) I exit here.
*/
#ifndef __cplusplus
errorset_buffer = save_level;
#endif
break;
}
}
#ifndef HAVE_FWIN
#ifndef UNDER_CE
CSLbool sigint_must_longjmp = NO;
#ifndef __cplusplus
jmp_buf sigint_buf;
#endif
void sigint_handler(int code)
{
/*
* Note that the only things that I am really allowed to do in a routine
* like this involve setting variables of type sig_atomic_t, which can not
* be viewed as much more than boolean. The code actually used here is
* somewhat more ambitious (== non-portable!) so must be viewed as delicate.
* ANSI guarantee that longjmp-ing out of a non-nested signal handler
* is valid, but some earlier C libraries have not supported this. Note that
* with C++ I will use throw rather than longjmp.
*/
/*
* tick_pending etc allow a steady stream of clock events to
* be handed to Lisp.
*/
interrupt_pending = 1;
signal(SIGINT, sigint_handler);
if (sigint_must_longjmp)
{
sigint_must_longjmp = NO;
#ifdef __cplusplus
throw((int *)0);
#else
longjmp(sigint_buf, 1);
#endif
}
/*
* If there is not a separate regular stream of ticks I will simulate
* the receipt of a tick here. Thus I need to be able to recognize "ticks"
* even on systems where there are no "real" ones.
*/
if (!tick_pending)
{
if (already_in_gc) tick_on_gc_exit = YES;
else
{
#ifndef NILSEG_EXTERNS
Lisp_Object nil = C_nil;
CSLbool xxx = NO;
if (exception_pending()) flip_exception(), xxx = YES;
#endif
tick_pending = YES;
saveheaplimit = heaplimit;
heaplimit = fringe;
savevheaplimit = vheaplimit;
vheaplimit = vfringe;
savecodelimit = codelimit;
codelimit = codefringe;
savestacklimit = stacklimit;
stacklimit = stackbase;
#ifndef NILSEG_EXTERNS
if (xxx) flip_exception();
#endif
}
}
return;
}
#endif /* UNDER_CE */
#endif /* HAVE_FWIN */
/*
* OK, I need to write a short essay on "software ticks". A major issue
* for me is synchronization between the worker and the GUI tasks. Lisp
* code can not easily be unilaterally interrupted since it needs to
* preserve GC safety. The easiest way of making progress that I have come up
* with is to arrange that the worker thead (ie the Lisp engine) arranges
* to poll the GUI on a fairly regular basis. I achieve this by making it
* count down in a variable called "countdown" and when that reaches zero
* it deems that a poll is due. I put instructions to decrement countdown in
* a number of places that I expect to be used often enough, and would like
* to have these within all possible loops and such that they are performed
* uniformly over time. These are IDEALS not reality! The countdown overflow
* may happen at somewhat irregular intervals and often at places in the
* code where I am not GC safe. So what I do is to set heap fringes and
* stack fringes so that the next time I try to allocate memory or check
* the stack the situation is noticed and I enter the GC. Once there I
* rapidly detect that this is not a genuine case of having run out of
* memory so I do not do a full GC: I just reset the varios fringes and
* proceed. But while there I know I am in a tidy situation and I can
* exchange information with the GUI. Perhaps as clear-cut case of
* consequence that can arise is that I may respond to a GUI request to
* interrupt what I was doing.
* I try to tune the value that I count down from to get a rate of polling
* that I count as "reasonable" - ie a few per second.
*
* deal_with_tick() is called when the countdown overflows. It resets the
* fringe variables to provoke a GC.
*
* handle_tick() is then a call back out from the GC and could do more
* as required.
*/
int32_t software_ticks = 3000;
int32_t number_of_ticks = 0;
int32_t countdown = 3000;
int deal_with_tick(void)
{
#ifdef PENDING_TICK_SUPPORT
printf("(!)"); fflush(stdout);
number_of_ticks++;
if (!tick_pending)
{
if (already_in_gc) tick_on_gc_exit = YES;
else
{
#ifndef NILSEG_EXTERNS
Lisp_Object nil = C_nil;
CSLbool xxx = NO;
if (exception_pending()) flip_exception(), xxx = YES;
#endif
tick_pending = YES;
saveheaplimit = heaplimit;
heaplimit = fringe;
savevheaplimit = vheaplimit;
vheaplimit = vfringe;
savecodelimit = codelimit;
codelimit = codefringe;
savestacklimit = stacklimit;
stacklimit = stackbase;
#ifndef NILSEG_EXTERNS
if (xxx) flip_exception();
#endif
}
}
#endif
countdown = software_ticks;
return 1;
}
static long int initial_random_seed, seed2;
char *files_to_read[MAX_INPUT_FILES],
*symbols_to_define[MAX_SYMBOLS_TO_DEFINE],
*fasl_paths[MAX_FASL_PATHS];
int output_directory;
character_reader *procedural_input;
character_writer *procedural_output;
CSLbool undefine_this_one[MAX_SYMBOLS_TO_DEFINE];
int number_of_input_files = 0,
number_of_symbols_to_define = 0,
number_of_fasl_paths = 0,
init_flags = 0;
#ifdef WINDOW_SYSTEM
FILE *alternative_stdout = NULL;
#endif
/*
* standard_directory holds the name of the default image file that CSL
* would load.
*/
char *standard_directory;
/*
* If non-NULL the string module_enquiry is a name presenetd on the
* command line in a "-T name" request, and this will cause the system
* to behave in a totally odd manner - it does not run Lisp at all but
* performs a directory enquiry within the image file.
*/
static char *module_enquiry = NULL;
/*
* The next lines mean that (if you can get in before cslstart is
* called) you can get memory allocation done in a custom way.
*/
static void *CSL_malloc(size_t n)
{
return malloc(n);
}
static void CSL_free(void *p)
{
free(p);
}
static void *CSL_realloc(void *p, size_t n)
{
return realloc(p, n);
}
malloc_function *malloc_hook = CSL_malloc;
realloc_function *realloc_hook = CSL_realloc;
free_function *free_hook = CSL_free;
CSLbool always_noisy = NO;
int load_count = 0, load_limit = 0x7fffffff;
void cslstart(int argc, char *argv[], character_writer *wout)
{
int i;
CSLbool restartp;
double store_size = 0.0;
#ifdef CONSERVATIVE
volatile Lisp_Object sp;
C_stackbase = (Lisp_Object *)&sp;
#endif
always_noisy = NO;
stack_segsize = 1;
module_enquiry = NULL;
countdown = 0x7fffffff;
/*
* Note that I will set up clock_stack AGAIN later on! The one further down
* happens after command line options have been decoded and is where I really
* want to consider Lisp to be starting. The setting here is because
* if I call ensure_screen() it can push and pop the clock stack, and
* especially if I have an error in my options I may print to the terminal
* and then flush it. Thus I need SOMETHING set up early to prevent any
* possible frivolous disasters in that area.
*/
base_time = read_clock();
consolidated_time[0] = gc_time = 0.0;
clock_stack = &consolidated_time[0];
use_wimp = YES;
#ifdef HAVE_FWIN
/*
* On fwin the "-w" flag should disable all attempts at use of the wimp.
*/
for (i=1; i<argc; i++)
{ char *opt = argv[i];
if (opt == NULL) continue;
if (opt[0] == '-' && tolower(opt[1] == 'w'))
{ use_wimp = !use_wimp;
break;
}
}
fwin_pause_at_end = 1;
#endif
#ifdef SOCKETS
sockets_ready = 0;
socket_server = 0;
#endif
/*
* Now that the window manager is active I can send output through
* xx_printf() and get it on the screen neatly.
*/
procedural_input = NULL;
procedural_output = wout;
standard_directory = find_image_directory(argc, argv);
restartp = YES;
ignore_restart_fn = NO;
spool_file = NULL;
spool_file_name[0] = 0;
output_directory = 0x80000000;
number_of_input_files = 0;
number_of_symbols_to_define = 0;
number_of_fasl_paths = 0;
fasl_output_file = NO;
initial_random_seed = seed2 = 0;
init_flags = INIT_EXPANDABLE;
return_code = EXIT_SUCCESS;
segvtrap = YES;
batch_flag = NO;
load_count = 0;
load_limit = 0x7fffffff;
{ char *s = REGISTRATION_VERSION;
#define hexval(c) ('0'<=c && c<='9' ? c - '0' : c - 'a' + 10)
#define gx() (s+=2, hexval(s[-1]) + 16*hexval(s[-2]))
unsigned char *p = registration_data;
memset(registration_data, 0, sizeof(REGISTRATION_SIZE));
while (*s != 0) *p++ = *s++;
s = REG1;
while (*s != 0) *p++ = gx();
s = REG2;
while (*s != 0) *p++ = gx();
CSL_MD5_Init();
CSL_MD5_Update((unsigned char *)errcode(err_registration), 32);
}
#ifdef MEMORY_TRACE
car_counter = 0x7fffffff;
car_low = 0;
car_high = 0xffffffff;
#endif
argc--;
for (i=1; i<=argc; i++)
{ char *opt = argv[i];
/*
* The next line ought never to be activated, but I have sometimes seen
* unwanted NULL args on the end of command lines so I filter them out
* here as a matter of security.
*/
if (opt == NULL || *opt == 0) continue;
if (opt[0] == '-')
{ char *w;
int c1 = opt[1], c2 = opt[2];
if (isupper(c1)) c1 = tolower(c1);
switch (c1)
{
/*
* -- <outfile> arranges that output is sent to the indicated file. It is
* intended to behave a little like "> outfile" as command-line output
* redirection, but is for use in windowed environments (in particular
* Windows NT) where this would not work. I had intended to use "->" here,
* but then the ">" tends to get spotted as a command-line request for
* redirection, and I would not be using this if command-line redirection
* worked properly! Actually use of "--" here was a BAD choice since it
* clashes with the tradition now common elsewhere that fully spelt-out
* options can be written as "--option". To start to mend that I will
* now make
* -- filename
* redirect the standard output, but detect
* --option
* as an extended option. This is, I guesss, an incompatible change to CSL's
* behaviour but I rather believe it will be a good one to make and I can
* issue a message about unrecognised options that will help anybody caught
* by it.
*/
case '-':
if (c2 != 0)
{ w = &opt[2];
/*
* The option "--texmacs" has been detected earlier in fwin.c, so I just
* detect and ignore it here.
*/
if (strcmp(w, "texmacs") == 0)
{ }
else
{
fwin_restore();
term_printf("Unknown extended option \"--%s\"\n", w);
term_printf("NB: use \"-- filename\" (with whitespace)\n");
term_printf(" for output redirection now.\n");
}
continue;
}
else if (i != argc) w = argv[++i];
else break; /* Illegal at end of command-line */
{ char filename[LONGEST_LEGAL_FILENAME];
FILE *f;
#ifdef WINDOW_SYSTEM
f = open_file(filename, w, strlen(w), "w", NULL);
if (f == NULL)
{
/*
* Under FWIN if there is a "--" among the arguments I will start off
* with the main window minimized. Thus if an error is detected at a
* stage that the transcript file is not properly opened I need to
* maximize the window so I can see the error! Note that I will need to
* ensure that fwin only uses "-- file" not "--option" to do this...
*/
fwin_restore();
term_printf("Unable to write to \"%s\"\n", filename);
continue;
}
else
{ term_printf("Output redirected to \"%s\"\n",
filename);
}
if (alternative_stdout != NULL)
fclose(alternative_stdout);
alternative_stdout = f;
#else
/*
* I use freopen() on stdout here to get my output sent elsewhere. Quite
* what sort of mess I am in if the freopen fails is hard to understand!
* Thus I write a message to stderr and exit promptly in case of trouble.
* I print a message explaining what I am doing BEFORE actually performing
* the redirection.
*/
fprintf(stderr, "Output to be redirected to \"%s\"\n", w);
f = open_file(filename, w, strlen(w), "w", stdout);
if (f == NULL)
{ fprintf(stderr, "Unable to write to \"%s\"\n",
filename);
#ifdef HAVE_FWIN
#ifdef __cplusplus
throw EXIT_FAILURE;
#else
my_return_code = EXIT_FAILURE;
longjmp(my_exit_buffer, 1);
#endif
#else
exit(EXIT_FAILURE);
#endif
}
#endif
}
continue;
/*
* -a is a curious option, not intended for general or casual use. If given
* it causes the (batchp) function to return the opposite result from
* normal! Without "-a" (batchp) returns T either if at least one file
* was specified on the command line, or if the standard input is "not
* a tty" (under some operating systems this makes sense - for instance
* the standard input might not be a "tty" if it is provided via file
* redirection). Otherwise (ie primary input is directly from a keyboard)
* (batchp) returns nil. Sometimes this judgement about how "batch" the
* current run is will be wrong or unhelpful, so "-a" allows the user to
* coax the system into better behaviour. I hope that this is never used!
* At one stage this option was called "-b" not "-a" (so I will now pretend
* that "-a" is for "alternate" or some such nonsense.
*/
case 'a':
batch_flag = YES;
continue;
/*
* -b tells the system to avoid any attempt to recolour prompts and
* input text. It will mainly be needed on X terminals that have been set up
* so that they use colours that make the defaults here unhelpful.
* Specifically white-on-black and so on.
* -b can be followed by colour specifications to make things yet
* more specific.
*/
case 'b':
/*
* Actually "-b" is detected and processed by fwin (if present) before
* this bit of the code is invoked (much as "-w" is). Thus I do not have
* to do anything here!
*/
continue;
/*
* The option "-C" just prints a dull and unimaginative copyright notice -
* having this option in there will tend to ensure that a copyright
* message is embedded in the object code somehow, while with luck nobody
* will be bothered too much by the fact that there is a stray option to get
* it displayed. Note that on some systems there is a proper character
* for the Copyright symbol... but there is little agreement about what
* that code is!
*/
case 'c':
fwin_restore();
term_printf("\nCopyright (C) Codemist Ltd, 1988-2006\n");
continue;
/*
* -D name=val defines a symbol at the start of a run
* I permit either
* -Dname=val
* or -D name=val
*/
case 'd':
if (c2 != 0) w = &opt[2];
else if (i != argc) w = argv[++i];
else break; /* Illegal at end of command-line */
if (number_of_symbols_to_define < MAX_SYMBOLS_TO_DEFINE)
symbols_to_define[number_of_symbols_to_define] = w,
undefine_this_one[number_of_symbols_to_define++] = NO;
else
{
fwin_restore();
term_printf("Too many \"-D\" requests: ignored\n");
}
continue;
#ifndef DEMO_MODE
/*
* -E
* This option is for an EXPERIMENT. It may do different things in different
* releases of CSL. In most cases it will not do anything! And certainly
* I may change what it does without notice or upwards compatibility. Right
* now it controls a way that can limit the loading of dynamically loadable
* native code, and I need that for performance measurement and debugging.
*/
case 'e':
if (c2 != 0) w = &opt[2];
else if (i != argc) w = argv[++i];
else break;
if (sscanf(w, "%d", &load_limit) != 1)
load_limit = 0x7fffffff;
continue;
#endif
#ifndef DEMO_MODE
#ifdef SOCKETS
case 'f':
/*
* -F
* This is used with syntax -Fnnn or -F nnn (with nnn a number above
* 1000 but less than 65536) to cause the system to run not as a normal
* interactive application but as a server listening on the indicated port.
* The case -F- (which could of course be "-F -") indicates use of the
* default port for CSL, which I hereby declare to be 1206. This number may
* need to be changed later if I find it conflicts with some other common
* package or usage, but was selected in memory of the project number
* at one time allocated to the Archimedeans Computing Group.
* On some systems if I want to set up a server that can serve multiple
* clients I may need to re-invoke CSL afresh for each new client, and in
* such cases the internally generated tasks can be passed information
* from their parent task using -F followed by non-numeric information.
* Any user who attempts such usage will get "what they deserve".
*/
if (c2 != 0) w = &opt[2];
else if (i != argc) w = argv[++i];
else break; /* Illegal at end of command-line */
port_number = default_csl_server_port;
remote_store = REMOTE_STORE;
max_users = MAX_USERS;
if (strcmp(w, "-") == 0)
port_number = default_csl_server_port;
else if (sscanf(w, "%d:%d:%d",
&port_number, &max_users, &remote_store) < 1 ||
port_number <= 1000 ||
port_number >= 65536 ||
max_users < 2 || max_users > 50 ||
remote_store < 4000 || remote_store > 20000)
{
fwin_restore();
term_printf("\"%s\" is valid (want port:users:store\n", w);
continue;
}
store_size = (double)remote_store;
init_flags &= ~INIT_EXPANDABLE;
current_users = 0;
/*
* The code here is probably a bit painfully system-specific, and so one
* could argue that it should go in a separate file. However a LOT of the
* socket interface is the same regardless of the host, or a few simple
* macros can have made it so. So if SOCKETS has been defined I will
* suppose I can continue here on that basis. I do quite want to put the
* basic socket code in csl.c since it is concerned with system startup and
* the selection of sources and sinks for IO.
*/
if (ensure_sockets_ready() == 0)
{ SOCKET sock1, sock2;
struct sockaddr_in server_address, client_address;
#ifdef HAVE_SOCKLEN_T
socklen_t sin_size;
#else
int sin_size;
#endif
sock1 = socket(AF_INET, SOCK_STREAM, 0);
if (sock1 == SOCKET_ERROR)
{
fwin_restore();
term_printf("Unable to create a socket\n");
continue;
}
server_address.sin_family = AF_INET;
server_address.sin_port = htons(port_number);
server_address.sin_addr.s_addr = INADDR_ANY;
memset((char *)&(server_address.sin_zero), 0, 8);
if (bind(sock1, (struct sockaddr *)&server_address,
sizeof(struct sockaddr)) == SOCKET_ERROR)
{
fwin_restore();
term_printf("Unable to bind socket to port %d\n",
port_number);
closesocket(sock1);
continue;
}
if (listen(sock1, PERMITTED_BACKLOG) == SOCKET_ERROR)
{
fwin_restore();
term_printf("Failure in listen() on port %d\n",
port_number);
closesocket(sock1);
continue;
}
for (;;)
{ struct hostent *h;
time_t t0;
sin_size = sizeof(struct sockaddr_in);
sock2 = accept(sock1,
(struct sockaddr *)&client_address,
&sin_size);
if (sock2 == SOCKET_ERROR)
{
fwin_restore();
term_printf("Trouble with accept()\n");
continue; /* NB local continue here */
}
t0 = time(NULL);
term_printf("%.24s from %s",
ctime(&t0),
inet_ntoa(client_address.sin_addr));
h = gethostbyaddr((char *)&client_address.sin_addr,
sizeof(client_address.sin_addr), AF_INET);
if (h != NULL)
term_printf(" = %s", h->h_name);
else term_printf(" [unknown host]");
/*
* Here I have a bit of a mess. Under Unix I can do a fork() so that the
* requests that are coming in are handled by a separate process. The
* code is pretty easy. However with Windows I can only create a fresh process
* by re-launching CSL from the file it was originally fetched from. I
* will try to do that in a while, but for now I will leave the
* Windows version of this code only able to handle a single client
* session.
*/
#ifdef WIN32
closesocket(sock1);
socket_server = sock2;
cpu_timeout = clock() + CLOCKS_PER_SEC*MAX_CPU_TIME;
elapsed_timeout = time(NULL) + 60*MAX_ELAPSED_TIME;
procedural_output = char_to_socket;
term_printf("Welcome to the Codemist server\n");
ensure_screen();
break;
#else /* WIN32 */
while (waitpid(-1, NULL, WNOHANG) > 0) current_users--;
if (current_users >= max_users)
{ term_printf(" refused\n");
socket_server = sock2;
ensure_screen();
procedural_output = char_to_socket;
term_printf(
"\nSorry, there are already %d people using this service\n",
current_users);
term_printf("Please try again later.\n");
ensure_screen();
procedural_output = NULL;
closesocket(socket_server);
socket_server = 0;
continue;
}
else term_printf(" %d of %d\n",
++current_users, max_users);
ensure_screen();
if (!fork())
{ /* Child process here */
closesocket(sock1);
fcntl(sock2, F_SETFL, O_NONBLOCK);
socket_server = sock2;
cpu_timeout = clock() + CLOCKS_PER_SEC*MAX_CPU_TIME;
elapsed_timeout = time(NULL) + 60*MAX_ELAPSED_TIME;
ensure_screen();
procedural_output = char_to_socket;
term_printf("Welcome, you are user %d of %d\n",
current_users, max_users);
term_printf(
"You have been allocated %d seconds CPU time"
" and %d minutes elapsed time\n",
MAX_CPU_TIME, MAX_ELAPSED_TIME);
break;
}
else
{ closesocket(sock2);
if (current_users < 0) current_users = 0;
continue;
/*
* This loops serving as many clients as happen to come along. Having said
* "csl -fnnn" it will be necessary (in due course) to kill the daemon
* by interrupting it with a ^C or some such. When the master process is
* terminated in that way any clients that remain active may continue to
* hang around until they have finished in the usual way.
*/
}
#endif /* WIN32 */
}
}
/*
* The "continue" here gets executed when I have been contacted by some
* client and have an active socket open. It parses the rest of the
* command line and then completes the process of getting CSL running.
*/
continue;
#endif
#endif /* DEMO_MODE */
/*
* -G
* is a debugging option - it sets !*backtrace to true, which applications
* may inspect when they want to do errorsets etc. These days I will
* make it FORCE all errors to be noisy whatever the user tries to do! The
* rationale for that is that some user code may have said
* (errorset X nil nil)
* and then errors within X become very hard to track. The "-g" option
* overrides the "nil nil" bit!
*/
case 'g':
if (number_of_symbols_to_define < MAX_SYMBOLS_TO_DEFINE)
symbols_to_define[number_of_symbols_to_define] =
"*backtrace",
undefine_this_one[number_of_symbols_to_define++] = NO;
else
{
fwin_restore();
term_printf("Too many requests: \"-G\" ignored\n");
}
always_noisy = YES;
continue;
/*
* -H
* render fonts on X host rather than X client (ie disable use of Xft and
* and Xrender if they might otherwise have been in use). This should have
* no effect on Windows and no effect if the system that the code was built
* on did not support Xft.
*/
case 'h':
fwin_use_xft = 0;
/*
* Actually, like the "-w" option, it is TOO LATE to do this here because
* lower-level parts of fwin may already have adjusted font paths using
* mechanisms based on whether Xft is to be activated or not. So fwin
* checks for "-h" and "-H" and interprets what it finds. So what I do here
* is just a redundant reminder. Ugh.
*/
continue;
/*
* -I is used to specify an image file to be used when CSL starts up.
* The case -I- indicated the "standard" file associated with this
* executable binary. Several images can be given.
*/
#ifndef DEMO_MODE
case 'i':
if (c2 != 0) w = &opt[2];
else if (i != argc) w = argv[++i];
else break; /* Illegal at end of command-line */
if (w[0] == '-' && w[1] == 0) w = standard_directory;
if (number_of_fasl_paths < MAX_FASL_PATHS-1)
fasl_paths[number_of_fasl_paths++] = w;
else
{
fwin_restore();
term_printf("Too many \"-I/-O\" requests: ignored\n");
}
continue;
#endif
/*
* -J
* unallocated. A rare and precious resource!!!!!!
*/
#ifndef DEMO_MODE
/* case 'j': */
continue;
#endif
/*
* -K nnn sets the size of heap to be used. If it is given then that much
* memory will be allocated and the heap will never expand. Without this
* option a default amount is used, and (on many machines) it will grow
* if space seems tight.
* The extended version of this option is "-K nnn/ss" and then ss is the
* number of "CSL pages" to be allocated to the Lisp stack. The default
* value (which is 1) should suffice for almost all users, and it should
* be noted that the C stack is separate from and independent of this one and
* it too could overflow.
* A form like -K6000K indicates that many kilobytes
* -K200M or just -K200 indicates that many megabytes
* -K1.6G indicates that many gigabytes
*/
#ifndef DEMO_MODE
case 'k':
if (c2 != 0) w = &opt[2];
else if (i != argc) w = argv[++i];
else break; /* Illegal at end of command-line */
{ char buffer[16];
int i = 0;
while ((*w != '/') &&
(*w != 'k') && (*w != 'K') &&
(*w != 'm') && (*w != 'M') &&
(*w != 'g') && (*w != 'G') &&
(*w != 0) &&
(i<sizeof(buffer)-1))
buffer[i++] = *w++;
buffer[i] = 0;
/*
* store size gets set here: 0.0 is left if either that is specified
* explictly or if no -K option is given. That will be treated as
* indicating "use default, and expand memory as you go"
*/
store_size = atof(buffer);
if (store_size == 0.0) init_flags |= INIT_EXPANDABLE;
else
{ init_flags &= ~INIT_EXPANDABLE;
/*
* If an explicit store size has been indicated I will see if it had one
* of the letters K, M or G after it (note that I allow it to be a floating
* point value.
*/
switch (*w)
{
case 'k': case 'K':
break;
case 'g': case 'G':
store_size *= 1024.0*1024.0;
break;
default:
store_size *= 1024.0;
break;
}
/*
* Now the measure is adjusted so it is in units of kilobytes. I will
* set a lower limit to how much can be asked for to try to prevent
* utter congestion. I will also set an upper limit to provide some minor
* protection.
*/
#if PAGE_BITS==18
if (store_size < 10000.0) store_size = 10000.0;
#else
if (store_size < 32000.0) store_size = 32000.0;
#endif
/*
* At present I limit even 64-bit systems to 50 Gbytes.
* ... and 32-bit systems to 1.9 Gbytes.
*/
if ((SIXTY_FOUR_BIT &&
(store_size > 50.0*1024.0*1024.0)) ||
(store_size > 1.9*1024.0*1024.0))
{
fwin_restore();
term_printf(
"Memory specifier \"-K%s\" is too large\n",
buffer);
term_printf("Please specify as -KnnnK, -KnnnM or -KnnnG\n");
term_printf("for Kilobytes, Megabytes or Gigabytes\n");
}
}
while (*w!=0 && *w!='/') w++;
if (*w == '/')
{ stack_segsize = atoi(w+1);
if (stack_segsize < 1 || stack_segsize > 10)
stack_segsize = 1;
}
}
continue;
#endif
/*
* -L <logfile> arranges that a transcript of the standard output is
* sent to the given file, just as if (spool '<logfile>) had been executed
* at the start of the run.
*/
case 'l':
if (c2 != 0) w = &opt[2];
else if (i != argc) w = argv[++i];
else break; /* Illegal at end of command-line */
{ char filename[LONGEST_LEGAL_FILENAME];
spool_file = open_file(filename, w,
strlen(w), "w", NULL);
if (spool_file == NULL)
{
fwin_restore();
term_printf("Unable to write to \"%s\"\n", filename);
}
else
{ time_t t0 = time(NULL);
strncpy(spool_file_name, filename, 32);
spool_file_name[31] = 0;
#ifdef COMMON
fprintf(spool_file,
"Starts dribbling to %s (%.24s).\n",
spool_file_name, ctime(&t0));
#else
fprintf(spool_file,
"+++ Transcript to %s started at %.24s +++\n",
spool_file_name, ctime(&t0));
#endif
}
}
continue;
#ifndef DEMO_MODE
#ifdef MEMORY_TRACE
/*
* If MEMORY_TRACE is set up then I can cause an exception by providing
* an option -M n:l:h
* This interrupts after n memory records when a reference in the (inclusive)
* range l..h is next made.
*/
case 'm':
if (c2 != 0) w = &opt[2];
else if (i != argc) w = argv[++i];
else break; /* Illegal at end of command-line */
switch(sscanf(w, "%ld:%lu:%lu",
&car_counter, &car_low, &car_high))
{
case 0: car_counter = 0x7fffffff;
case 1: car_low = 0;
case 2: car_high = 0xffffffff;
default:break;
}
continue;
#endif
#endif
/*
* -N tells CSL that even if the image being loaded contains a restart-
* function this should be ignored, and Lisp should run the default
* read-eval-print loop. The only expected use for this is when an image
* has been created but it is seriously broken, so the way it would
* usually restart would crash - then "-N" may allow a suitable expert to
* test and diagnose the trouble at the Lisp level. Ordinary users are
* NOT expected to want to know about this!
*/
#ifndef DEMO_MODE
case 'n': /* Ignore restart function (-N) */
ignore_restart_fn = YES;
continue;
#endif
/*
* -O <file> specifies an image file for output (via FASLOUT or PRESERVE).
*/
#ifndef DEMO_MODE
case 'o':
if (c2 != 0) w = &opt[2];
else if (i != argc) w = argv[++i];
else break; /* Illegal at end of command-line */
if (w[0] == '-' && w[1] == 0) w = standard_directory;
if (number_of_fasl_paths < MAX_FASL_PATHS-1)
{ output_directory = number_of_fasl_paths;
fasl_paths[number_of_fasl_paths++] = w;
}
else
{
fwin_restore();
term_printf("Too many \"-I/-O\" requests: ignored\n");
}
continue;
#endif
/*
* -P is reserved for profile options.
*/
case 'p':
/*
* Please implement something for your favourite system here... what I would
* like would be a call to monitor() or some such...
*/
#ifndef DEMO_MODE
fwin_restore();
term_printf("Unimplemented option \"-%c\"\n", c1);
continue;
#endif
/*
* -Q selects "quiet" mode. See -V for the converse.
*/
case 'q':
if (number_of_symbols_to_define < MAX_SYMBOLS_TO_DEFINE)
/*
* symbols_to_define[number_of_symbols_to_define] =
* "*echo=nil",
* undefine_this_one[number_of_symbols_to_define++] = NO,
*/
init_flags &= ~INIT_VERBOSE,
init_flags |= INIT_QUIET;
else
{
fwin_restore();
term_printf("Too many requests: \"-Q\" ignored\n");
}
continue;
/*
* -R nnn sets the initial random seed, for reproducible runs. -R 0
* (the default) sets the initial seed based on the time of day etc.
* The version -R nnn,mmm makes it possible to pass 64-bits of seed info.
*/
case 'r':
if (c2 != 0) w = &opt[2];
else if (i != argc) w = argv[++i];
else break; /* Illegal at end of command-line */
if (sscanf(w, "%ld,%ld", &initial_random_seed, &seed2) != 2)
{ initial_random_seed = seed2 = 0;
sscanf(w, "%ld", &initial_random_seed);
}
continue;
/*
* -S sets the variable !*plap, which causes the compiler to list the
* bytecodes that it generates. This is probably frivolous but is
* provided inspired by the typical C compilers "cc -S" option.
*/
case 's':
if (number_of_symbols_to_define < MAX_SYMBOLS_TO_DEFINE)
symbols_to_define[number_of_symbols_to_define] =
"*plap",
undefine_this_one[number_of_symbols_to_define++] = NO;
else
{
fwin_restore();
term_printf("Too many requests: \"-S\" ignored\n");
}
continue;
/*
* -T name reports the time-stamp on the named module, and then
* exits. This is for use in perl scripts and the like, and is
* needed because the stamps on modules within an image or
* library file are not otherwise instantly available.
*
* Note that especially on windowed systems it may be
* necessary to use this with "-- filename" since the information
* generated here goes to the default output unit, which in
* some cases is just the screen.
*/
#ifndef DEMO_MODE
case 't':
if (c2 != 0) w = &opt[2];
else if (i != argc) w = argv[++i];
else break; /* Illegal at end of command-line */
module_enquiry = w;
continue;
#endif
/*
* -U name undefines the symbol <name> at the start of the run
*/
case 'u':
if (c2 != 0) w = &opt[2];
else if (i != argc) w = argv[++i];
else break; /* Illegal at end of command-line */
if (number_of_symbols_to_define < MAX_SYMBOLS_TO_DEFINE)
symbols_to_define[number_of_symbols_to_define] = w,
undefine_this_one[number_of_symbols_to_define++] = YES;
else
{
fwin_restore();
term_printf("Too many \"-U\" requests: ignored\n");
}
continue;
/*
* -V selects "verbose" options at the start of the run
*/
#ifndef DEMO_MODE
case 'v':
if (number_of_symbols_to_define < MAX_SYMBOLS_TO_DEFINE)
/*
* symbols_to_define[number_of_symbols_to_define] =
* "*echo",
* undefine_this_one[number_of_symbols_to_define++] = NO,
*/
init_flags &= ~INIT_QUIET,
init_flags |= INIT_VERBOSE;
else
{
fwin_restore();
term_printf("Too many requests: \"-V\" ignored\n");
}
continue;
#endif
#ifdef WINDOW_SYSTEM
/*
* On systems where I can run in either windowed or command-line mode this
* flag controls that aspect of behaviour.
*/
case 'w':
/*
* I need to detect and process this flag especially early, and so by the time
* I get to regular command decoding there is nothing to be done.
* Within fwin the option "-w" says "do NOT try to use a window, ie
* run as a console style application", while "-w+" says "Even if
* all the rest of the schemes that I have indicate that you should
* run in console mode (eg if standard input is from a pipe, which it
* will be when running under some debuggers) try to create and use a
* window.
*/
continue;
#endif
/*
* -x is an "undocumented" option intended for use only by system
* support experts - it disables trapping if segment violations by
* errorset and so makes it easier to track down low level disasters -
* maybe! Only those who have access to the source code can make
* good use of the -X option, so it is only described here!
*/
#ifndef DEMO_MODE
case 'x':
segvtrap = NO;
continue;
#endif
/*
* -Y sets the variable !*hankaku , which causes the lisp reader convert
* a Zenkaku code to Hankaku one when read. I leave this option decoded
* on the command line even if the Kanji support code is not otherwise
* compiled into CSL just so I can reduce conditional compilation.
* This was part of the Internationalisation effort for CSL but I repeat
* that it is no longer supported.
*/
#ifndef DEMO_MODE
case 'y':
if (number_of_symbols_to_define < MAX_SYMBOLS_TO_DEFINE)
symbols_to_define[number_of_symbols_to_define] =
"*hankaku",
undefine_this_one[number_of_symbols_to_define++] = NO;
else
term_printf("Too many requests: \"-Y\" ignored\n");
continue;
#endif
/*
* -Z tells CSL that it should not load an initial heap image, but should
* run in "cold start" mode. This is only intended to be useful for
* system builders.
*/
#ifndef DEMO_MODE
case 'z': /* Cold start option -z */
restartp = NO;
continue;
#endif
default:
fwin_restore();
term_printf("Unrecognized option \"-%c\"\n", c1);
continue;
}
/*
* I do a "break" out of the switch() block if a key occurs at the end
* of the command line in an invalid manner.
*/
fwin_restore();
term_printf("Option \"-%c\" needs an argument: ignored\n", c1);
break;
}
else files_to_read[number_of_input_files++] = opt;
}
if (number_of_fasl_paths == 0)
{ char *p = standard_directory, *p1;
char cur[LONGEST_LEGAL_FILENAME];
/*
* If the user does not specify any image files then the behaviour
* defaults as follows:
* Suppose that the current executable is xxx/yyy/zzz then the
* system behaves as if the user had written
* zzz -o zzz.img -i xxx/yyy/zzz.img
* however if the executable seemed to be in the current directory
* already this is reduced to just
* zzz -o zzz.img
* so that I do not have two different handles on the same image file
* (with the potential muddle that that could result in).
*
* NOTE: this used very generally mean that you ended up with an empty image
* file (eg csl.img or r37.img) in whatever directory you run this
* code from. This could be avoided by running it as
* xxx -i-
* that explicitly sets up the normal image file as the one to use with
* no extras. However these days I try to arrange that an output image file
* only ever gets created if somebody calls FASLOUT or PRESERVE, so what
* I describe here will usually not cause confusion....
*/
if (standard_directory[0] == '.' &&
(standard_directory[1] == '/' ||
standard_directory[1] == '\\')) strcpy(cur, standard_directory);
else get_current_directory(cur, sizeof(cur));
p += strlen(p);
while (p != standard_directory &&
*--p != '/' &&
*p != '\\') /* nothing */;
if (strncmp(standard_directory, cur, p-standard_directory) != 0)
p1 = (char *)(*malloc_hook)(strlen(p));
else p1 = NULL;
if (p == standard_directory || p1 == NULL)
{ fasl_paths[0] = standard_directory;
/*
* If output_directory has the 0x40000000 bit set then the directory
* involved is one that should be opened now if it exists, but if
* it does not its creation should be deferred for as long as possible.
*/
output_directory = 0x40000000 + 0;
number_of_fasl_paths = 1;
if (p1 != NULL) (*free_hook)(p1);
}
else
{ strcpy(p1, p+1);
fasl_paths[0] = p1;
fasl_paths[1] = standard_directory;
output_directory = 0x40000000 + 0;
number_of_fasl_paths = 2;
}
}
Iinit();
if (module_enquiry != NULL)
{ char datestamp[32], fullname[LONGEST_LEGAL_FILENAME];
int32_t size;
int i;
Lisp_Object nil;
/*
* Imodulep expects input_libraries to be set up. So I will fudge the
* creation of something that looks sufficiently like a list to pass muster
* here despite the full system not being loaded. I use references to the
* nil-segment and cons().
*/
nilsegment = (Lisp_Object *)my_malloc(NIL_SEGMENT_SIZE);
#ifdef COMMON
nil = doubleword_align_up(nilsegment) + TAG_CONS + 8;
#else
nil = doubleword_align_up(nilsegment) + TAG_SYMBOL;
#endif
C_nil = nil;
pages_count = heap_pages_count = vheap_pages_count =
bps_pages_count = native_pages_count = 0;
stacksegment = (Lisp_Object *)my_malloc(CSL_PAGE_SIZE);
/*
* I am lazy about protection against malloc failure here.
*/
heaplimit = doubleword_align_up(stacksegment);
fringe = heaplimit + CSL_PAGE_SIZE - 16;
input_libraries = heaplimit + 16 + TAG_SYMBOL;
heaplimit += 64;
/*
* I have now fudged up enough simulation of a Lisp heap that maybe I can
* build the library search-list.
*/
qheader(input_libraries) |= SYM_SPECIAL_FORM;
qvalue(input_libraries) = nil;
for (i=number_of_fasl_paths-1; i>=0; i--)
qvalue(input_libraries) = cons(SPID_LIBRARY + (((int32_t)i)<<20),
qvalue(input_libraries));
if (Imodulep(module_enquiry, strlen(module_enquiry),
datestamp, &size, fullname))
{ strcpy(datestamp, "unknown");
size = 0;
strcpy(fullname, module_enquiry);
}
term_printf("%.24s size=%ld file=%s\n",
datestamp, (long)size, fullname);
init_flags &= ~INIT_VERBOSE;
#ifdef HAVE_FWIN
fwin_pause_at_end = 0;
#endif
}
else
{ base_time = read_clock();
consolidated_time[0] = gc_time = 0.0;
clock_stack = &consolidated_time[0];
push_clock();
if (init_flags & INIT_VERBOSE)
{
#ifndef WINDOW_SYSTEM
/*
* If I do NOT have a window system I will print a newline here so that I
* can be very certain that my banner appears at the start of a line.
* With a window system I should have a brand-new frash window for output
* and the newline would intrude as an initial blank line.
*/
term_printf("\n");
#endif
#ifndef COMMON
term_printf("Codemist Standard Lisp %s for %s: %s\n",
VERSION, IMPNAME, __DATE__);
#else
term_printf("Codemist Common Lisp %s for %s: %s\n",
VERSION, IMPNAME, __DATE__);
#endif
}
#ifdef MEMORY_TRACE
if (car_counter != 0x7fffffff)
term_printf("Stop after %ld %lu..%lu\n",
car_counter, car_low, car_high);
#endif
#ifdef WINDOW_SYSTEM
ensure_screen();
/* If the user hits the close button here I may be in trouble */
#endif
/*
* Now dynamic code detects the floating point representation that is in use.
* I thougt/hoped that doing it this way would be safer than relying on having
* pre-defined symbols that tracked the machine architecture.
*/
{ union fpch { double d; unsigned char c[8]; } d;
/*
* The following looks at the floating point representation of the
* number 1/7 (in double precision) and picks out two bytes from
* the middle of the first word - where I hope that rounding issues
* will be remote. Investigation shows that these two bytes can be
* used to discriminate among at least a worthwhile range of
* representations, and I will exploit this to help me re-load
* heap-images in a way that allows images to be portable across
* different architectures.
*/
d.d = 1.0/7.0;
switch ((d.c[1] << 8) | d.c[2])
{
case 0x2449: current_fp_rep = 0;
break; /* Intel, MIPS */
case 0x49c2: current_fp_rep = FP_WORD_ORDER;
break; /* ARM */
case 0x4924: current_fp_rep = FP_BYTE_ORDER;
break; /* may never happen? */
case 0xc249: current_fp_rep = FP_WORD_ORDER|FP_BYTE_ORDER;
break; /* SPARC */
/*
* The next line is probably not very good under a window manager, but
* it is a case that ought never to arise, so I will not bother.
*/
default: term_printf("Unknown floating point format\n");
my_exit(EXIT_FAILURE);
}
}
/*
* Up until the time I call setup() I may only use term_printf for
* output, because the other relevant streams will not have been set up.
*/
#ifdef DEMO_MODE
setup(7, 0.0); /* Force warm start, flag as demo mode */
#else
setup(restartp ? 3 : 2, store_size);
#endif
/*
* I need to set the NOISY flag after doing setup to avoid it getting
* reloaded from a heap image
*/
{ nil_as_base
if (always_noisy) miscflags |= (ALWAYS_NOISY | 3);
else miscflags &= ~ALWAYS_NOISY;
}
#ifndef COMMON
#ifdef HAVE_FWIN
fwin_menus(loadable_packages, switches);
#endif
#endif
/*
* Now that setup is complete (and I have done any authorisation I want to)
* I will seed the random number generator as requested by the user. The
* default will be to put it in an unpredictable (well hard to predict!)
* state
*/
Csrand((uint32_t)initial_random_seed, (uint32_t)seed2);
gc_time += pop_clock();
countdown = software_ticks;
interrupt_pending = already_in_gc = NO;
tick_pending = tick_on_gc_exit = NO;
#ifndef HAVE_FWIN
/*
* "^C" trapping and handling happens within fwin if that is available.
*/
#ifndef UNDER_CE
sigint_must_longjmp = NO;
signal(SIGINT, sigint_handler);
#endif
#endif
ensure_screen();
procedural_output = NULL;
#ifdef HAVE_FWIN
/*
* OK, if I get this far I will suppose that any messages that report utter
* disasters will have reached the user, so I can allow FWIN to terminate
* rather more promptly.
*/
fwin_pause_at_end = 0;
#endif
}
#ifdef HAVE_FWIN
#ifdef HAVE_LIBFOX
/*
* Activate the BREAK and BACKTRACE menu items. Note not needed unless
* FOX is used and so there is a prospect of theer actually being menus!
*/
/*
* The next line causes a MOAN using Sun's compiler, ending up with
* an undefined reference to fwin_callback_to_interrupt!
*/
fwin_callback_to_interrupt(async_interrupt);
#endif /* HAVE_LIBFOX */
#endif /* HAVE_FWIN */
}
#ifdef SOCKETS
#define SOCKET_BUFFER_SIZE 1024
/*
* The following two "character codes" are used when CSL is run as
* a socket server and wrap around prompt text. This could be in
* conflict with any code that tries to use these codes for other
* purposes or that handles prompts itself...
*/
#define CH_PROMPT 0x9a
#define CH_ENDPROMPT 0x9c
static char socket_in[SOCKET_BUFFER_SIZE], socket_out[SOCKET_BUFFER_SIZE];
static int socket_in_p = 0, socket_in_n = 0,
socket_out_p = 0, socket_prev = '\n';
static int char_from_socket(void)
{
int c;
clock_t c0;
time_t t0;
if (socket_server == 0)
{ socket_prev = ' ';
return EOF;
}
/*
* I generate a prompt whenever I am about to read the character that
* follows a newline. The prompt is issued surrounded by control
* characters 0x9a and 0x9c. That curious arrangement is inherited from
* internal behaviour in my Windows interface code and could be altered
* if something truly better could be invented.
*/
if (socket_prev == '\n')
{ term_printf("%c%s%c", CH_PROMPT, prompt_string, CH_ENDPROMPT);
ensure_screen();
}
if (socket_in_n == 0)
{ for (;;)
{ socket_in_n = recv(socket_server, socket_in, SOCKET_BUFFER_SIZE, 0);
c0 = clock();
t0 = time(NULL);
if (c0 > cpu_timeout || t0 > elapsed_timeout)
{ cpu_timeout = c0 + 20;
elapsed_timeout = t0 + 20;
term_printf(
"\nSorry: timeout on this session. Closing down.\n");
socket_prev = ' ';
return EOF;
}
if (socket_in_n <= 0)
#ifndef EWOULDBLOCK
# define EWOULDBLOCK WSAEWOULDBLOCK
#endif
{ if (errno == EWOULDBLOCK)
{
#ifdef WIN32
Sleep(1000); /* Arg in milliseconds here */
#else
sleep(1); /* Delay 1 second before re-polling */
#endif
continue;
}
closesocket(socket_server);
socket_server = 0;
socket_prev = ' ';
return EOF;
}
else break;
}
socket_in_p = 0;
}
c = socket_in[socket_in_p++];
if (c == 0x0a || c == 0x0d) c = '\n';
socket_in_n--;
socket_prev = c;
return c & 0xff;
}
static int char_to_socket(int c)
{
if (socket_server == 0) return 1;
socket_out[socket_out_p++] = (char)c;
if (c == '\n' || socket_out_p == SOCKET_BUFFER_SIZE)
{ if (send(socket_server, socket_out, socket_out_p, 0) < 0)
{ closesocket(socket_server);
socket_server = 0;
return 1;
}
socket_out_p = 0;
}
return 0;
}
void flush_socket(void)
{
if (socket_server == 0) return;
if (send(socket_server, socket_out, socket_out_p, 0) < 0)
{ closesocket(socket_server);
socket_server = 0;
}
socket_out_p = 0;
}
#endif
static void cslaction(void)
/*
* This is the "standard" route into CSL activity - it uses file-names
* from the decoded command-line as files to be read and processed
* unless the system was launched with the flag that says it ought to try
* to provide a network service on some socket.
*/
{
#ifdef CONSERVATIVE
volatile Lisp_Object sp;
C_stackbase = (Lisp_Object *)&sp;
#endif
#ifdef __cplusplus
errorset_msg = NULL;
try
#else
jmp_buf this_level;
errorset_buffer = &this_level;
errorset_msg = NULL;
if (!setjmp(this_level))
#endif
{
#ifndef UNDER_CE
signal(SIGFPE, low_level_signal_handler);
if (segvtrap) signal(SIGSEGV, low_level_signal_handler);
#ifdef SIGBUS
if (segvtrap) signal(SIGBUS, low_level_signal_handler);
#endif
#ifdef SIGILL
if (segvtrap) signal(SIGILL, low_level_signal_handler);
#endif
#endif
non_terminal_input = NULL;
#ifdef SOCKETS
if (socket_server)
{ ensure_screen();
procedural_input = char_from_socket;
procedural_output = char_to_socket;
lisp_main();
ensure_screen();
procedural_input = NULL;
procedural_output = NULL;
}
else
#endif
if (number_of_input_files == 0) lisp_main();
else
{ int i;
for (i=0; i<number_of_input_files; i++)
{ char filename[LONGEST_LEGAL_FILENAME];
FILE *f = open_file(filename, files_to_read[i],
strlen(files_to_read[i]), "r", NULL);
if (f == NULL)
err_printf("\n+++ Could not read file \"%s\"\n",
files_to_read[i]);
else
{ if (init_flags & INIT_VERBOSE)
term_printf("\n+++ About to read file \"%s\"\n",
files_to_read[i]);
non_terminal_input = f;
lisp_main();
fclose(f);
}
}
}
}
#ifdef __cplusplus
catch (char *)
#else
else
#endif
{ if (errorset_msg != NULL)
{ term_printf("\n%s detected\n", errorset_msg);
errorset_msg = NULL;
}
return;
}
}
int cslfinish(character_writer *w)
{
#ifdef CONSERVATIVE
volatile Lisp_Object sp;
C_stackbase = (Lisp_Object *)&sp;
#endif
procedural_output = w;
if (Ifinished())
term_printf("\n+++ Errors on checkpoint-image file\n");
#ifdef TRACED_EQUAL
dump_equals();
#endif
/*
* clock_t is an arithmetic type but I do not know what sort - so I
* widen to double to do arithmetic on it. Actually what I MUST do is
* to compute a time difference in the type clock_t and hope I never
* get a difference that that overflows. The worst case I know of overflows
* after 35 minutes.
*/
if (init_flags & INIT_VERBOSE)
{ long int t = (long int)(100.0 * (consolidated_time[0] +
(double)(read_clock() - base_time)/
(double)CLOCKS_PER_SEC));
long int gct = (long int)(100.0 * gc_time);
term_printf("\n\nEnd of Lisp run after %ld.%.2ld+%ld.%.2ld seconds\n",
t/100, t%100, gct/100, gct%100);
}
#ifdef DEBUG_SOFTWARE_TICKS
term_printf("%d ticks processed (%d)\n",
number_of_ticks, SOFTWARE_TICKS);
#endif
drop_heap_segments();
if (spool_file != NULL)
{
#ifdef COMMON
fprintf(spool_file, "\nFinished dribbling to %s.\n", spool_file_name);
#else
fprintf(spool_file, "\n+++ Transcript closed at end of run +++\n");
#endif
#ifndef DEBUG
fclose(spool_file);
spool_file = NULL;
#endif
}
ensure_screen();
procedural_output = NULL;
return return_code;
}
/*
* People who want to use this in an embedded context can predefine
* NO_STARTUP_CODE and provide their own entrypoint...
*/
#ifndef NO_STARTUP_CODE
/*
* The next fragment of code is to help with the use of CSL (and hence
* packages written in Lisp and supported under CSL) as OEM products
* embedded within larger C-coded packages. There is (of course) a
* significant issue about clashes between the names of external symbols
* if CSL is to be linked with anything else, but I will not worry about that
* just yet.
* The protocol for calling Lisp code from C is as follows:
*
* cslstart(argc, argv, writer);allocate memory and Lisp heap etc. Args
* should be "as if" CSL was being called
* directly and this was the main entrypoint.
* The extra arg accepts output from this
* stage. Use NULL to get standard I/O.
* execute_lisp_function(fname, reader, writer);
* fname is a (C) string that names a Lisp
* function of 0 args. This is called with
* stdin/stdout access redirected to use the
* two character-at-a-time functions passed
* down. [Value returned indicates if
* the evaluation succeeded?]
* cslfinish(writer); Tidies up ready to stop.
*/
int execute_lisp_function(char *fname,
character_reader *r, character_writer *w)
{
Lisp_Object nil;
Lisp_Object ff;
#ifdef CONSERVATIVE
volatile Lisp_Object sp;
C_stackbase = (Lisp_Object *)&sp;
#endif
ff = make_undefined_symbol(fname);
nil = C_nil;
if (exception_pending())
{ flip_exception();
return 1; /* Failed to make the symbol */
}
procedural_input = r;
procedural_output = w;
Lapply0(nil, ff);
ensure_screen();
procedural_input = NULL;
procedural_output = NULL;
nil = C_nil;
if (exception_pending())
{ flip_exception();
return 2; /* Failure during evaluation */
}
return 0;
}
#ifdef SAMPLE_OF_PROCEDURAL_INTERFACE
static char ibuff[100], obuff[100];
static int ibufp = 0, obufp = 0;
static int iget()
{
int c = ibuff[ibufp++];
if (c == 0) return EOF;
else return c;
}
static void iput(int c)
{
if (obufp < sizeof(obuff)-1)
{ obuff[obufp++] = c;
obuff[obufp] = 0;
}
}
#endif
static int submain(int argc, char *argv[])
{
cslstart(argc, argv, NULL);
#ifdef SAMPLE_OF_PROCEDURAL_INTERFACE
strcpy(ibuff, "(print '(a b c d))");
execute_lisp_function("oem-supervisor", iget, iput);
printf("Buffered output is <%s>\n", obuff);
#else
if (module_enquiry == NULL) cslaction();
#endif
my_exit(cslfinish(NULL));
/*
* The "return 0" here is unreachable but it still quietens down as many
* C compilers as it causes to moan noisily!
*/
return 0;
}
#if HAVE_FWIN
#define ENTRYPOINT fwin_main
#else
#define ENTRYPOINT main
#endif
int ENTRYPOINT(int argc, char *argv[])
{
int res;
#ifdef USE_MPI
MPI_Init(&argc,&argv);
MPI_Comm_rank(MPI_COMM_WORLD,&mpi_rank);
MPI_Comm_size(MPI_COMM_WORLD,&mpi_size);
printf("I am mpi instance %d of %d.\n", mpi_rank+1, mpi_size);
#endif
#ifdef HAVE_FWIN
strcpy(about_box_title, "About CSL");
strcpy(about_box_description, "Codemist Standard Lisp");
#endif
#ifdef __cplusplus
try { res = submain(argc, argv); }
catch(int r) { res = r; }
#else
if (!setjmp(my_exit_buffer)) res = submain(argc, argv);
else res = my_return_code;
#endif
#ifdef USE_MPI
MPI_Finalize();
#endif
return res;
}
#endif /* NO_STARTUP_CODE */
/* End of csl.c */