Artifact 1c5e9ba963a87b2f7b6f7744c02d7a21b6a1ae59e74cde31b9d4116f293020f8:
- Executable file
r36/cslbase/csl.c
— part of check-in
[f2fda60abd]
at
2011-09-02 18:13:33
on branch master
— Some historical releases purely for archival purposes
git-svn-id: https://svn.code.sf.net/p/reduce-algebra/code/trunk/historical@1375 2bfe0521-f11c-4a00-b80e-6202646ff360 (user: arthurcnorman@users.sourceforge.net, size: 79735) [annotate] [blame] [check-ins using] [more...]
/* csl.c Copyright (C) 1989-99 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... */ /* Signature: 22abf0f6 07-Mar-2000 */ #include <stdarg.h> #include <string.h> #include <ctype.h> #include "machine.h" #include "tags.h" #include "externs.h" #include "arith.h" #include "read.h" #include "stream.h" #include "entries.h" #include "version.h" #define INCLUDE_ERROR_STRING_TABLE 1 #include "cslerror.h" #undef INCLUDE_ERROR_STRING_TABLE #ifdef TIMEOUT #include "timeout.h" #endif #ifdef OLD_THINK_C #include <console.h> #include <memory.h> #undef nil /* Yuk - this is defined by <types.h> which <memory.h> loads */ #endif #ifdef __WATCOMC__ #include <float.h> #endif #ifdef SOCKETS #include "sockhdr.h" #ifndef ms_windows #include <sys/wait.h> #endif 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 #ifdef WINDOW_SYSTEM CSLbool use_wimp; #endif #ifdef USE_MPI int32 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 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 temp = (int32)&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) { 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) ? 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) { 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) ? 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; #ifdef WINDOW_SYSTEM /* * 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. */ if (!use_wimp) #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. */ double delta = (double)(t0 - base_time)/(double)CLOCKS_PER_SEC; base_time = t0; consolidated_time[0] += delta; } term_printf( "\n+++ [%.2f+%.2f] Type C to continue, A to abort, X to exit\n", consolidated_time[0], gc_time); ensure_screen(); nil = C_nil; if (exception_pending()) return nil; push(prompt_thing); prompt_thing = CHAR_EOF; 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); return onevalue(p); case 'a': case 'A': /* raise an exception */ break; case 'x': case 'X': my_exit(EXIT_FAILURE); /* Rather abrupt */ case '\n': term_printf("C to continue, A to abort, X to exit: "); ensure_screen(); nil = C_nil; if (exception_pending()) return nil; continue; default: /* wait for A or C */ continue; } break; } pop(prompt_thing); } if (miscflags & HEADLINE_FLAG) 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) ? 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) 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) ? 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) 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) ? 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) { 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) ? 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) { 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) ? 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) && 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; #endif void my_exit(int n) { #ifdef USE_MPI MPI_Finalize(); #endif #if defined(FLEX) && defined(WINDOWS_NT) && defined(CWIN) && defined(NAG) extern void rlnag(); rlnag(); #endif #ifdef BUFFERED_STDOUT ensure_screen(); #endif #ifdef SOCKETS if (sockets_ready) WSACleanup(); #endif #ifdef WINDOW_SYSTEM pause_for_user(); #endif #ifdef CWIN #ifdef __cplusplus throw n; #else if (n == 0) n = 0x80000000; longjmp(my_exit_buffer, n); #endif #else #if defined(WINDOWS_NT) && defined(NAG) { extern void sys_abort(int); sys_abort(n); } #else #ifdef TICK_STREAM remove_ticker(); #endif 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 { 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 { 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(); signal(SIGFPE, low_level_signal_handler); #ifdef __WATCOMC__ _control87(_EM_OVERFLOW | _EM_INVALID | _EM_DENORMAL | _EM_ZERODIVIDE | _EM_INEXACT | _EM_UNDERFLOW, _MCW_EM); #endif 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 } 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 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); #ifdef TICK_STREAM remove_ticker(); /* * 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(); } #endif 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 len = length_of_header(h) - 4; if (len > 63) len = 63; memcpy(new_module, (char *)modname + (4 - 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 len = length_of_header(h) - 4; if (len > 63) len = 63; memcpy(new_fn, (char *)exit_value + (4 - 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! */ MD5_Init(); 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; polltick_pending = 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; } #ifdef TICK_STREAM add_ticker(); #endif 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 MS_DOS #ifndef WINDOWS_NT 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 } #ifndef TICK_STREAM /* * 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 } } #endif /* TICK_STREAM */ return; } #endif #endif #ifdef SOFTWARE_TICKS int32 number_of_ticks = 0; int32 countdown; int deal_with_tick() { 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 } } #ifdef SOFTWARE_TICKS countdown = SOFTWARE_TICKS; #endif return 1; } #endif 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; void cslstart(int argc, char *argv[], character_writer *wout) { int i; CSLbool restartp; double store_size = 0.0; stack_segsize = 1; module_enquiry = NULL; #ifdef SOFTWARE_TICKS countdown = 0x7fffffff; #endif /* * 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]; #ifdef WINDOW_SYSTEM /* * On some systems (Archimedes/RISCOS) the same executable * may run either under a window manager or using a command line. * I select which to use based on a command line option, which * I scan for VERY early since until I know what I am doing * I can not report errors etc etc */ #ifdef RISCOS use_wimp = NO; 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; /* Repeating "-w" flips the effect */ } } #else use_wimp = YES; /* Other than on RISCOS always enable window system */ #ifdef CWIN cwin_pause_at_end = 1; #endif #ifdef macintosh { extern int _w_font; extern void winit(void); extern int wgetargs(char ***); SetApplLimit(GetApplLimit() - 64000); /* Try to reserve plenty of stack space */ _w_font = 4; winit(); winitargs(&argc, &argv); /* THINK_C does not do arguments! */ argc = wgetargs(&argv); /* Use dialog box for arguments */ } #endif start_up_window_manager(use_wimp); #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. * On the Archimedes start_up_window_manager() hangs up until somebody * hits the right icon with a mouse click, so most of the mallocs etc * will not happen until then. */ #endif procedural_input = NULL; procedural_output = wout; standard_directory = find_image_directory(argc, argv); #ifdef OLD_THINK_C /* * Note amazingly well that on the Macintosh I identify the image directory * BEFORE I grab command-line options etc, since the Think C "ccommand" * function can reset the current directory, and I need access to same * (but not to the faked command line!) while establishing my image * location. */ argc = ccommand(&argv); #endif 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; gc_method = fasl_output_file = NO; initial_random_seed = seed2 = 0; init_flags = INIT_EXPANDABLE; return_code = EXIT_SUCCESS; segvtrap = YES; batch_flag = NO; { 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(); MD5_Init(); MD5_Update((unsigned char *)errcode(err_registration), 32); } #ifdef MEMORY_TRACE car_counter = 0x7fffffff; car_low = 0; car_high = 0xffffffff; #endif #ifdef __WATCOMC__ _control87(_EM_OVERFLOW | _EM_INVALID | _EM_DENORMAL | _EM_ZERODIVIDE | _EM_INEXACT | _EM_UNDERFLOW, _MCW_EM); #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 usin 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! */ case '-': 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]; FILE *f; #ifdef WINDOW_SYSTEM f = open_file(filename, w, strlen(w), "w", NULL); if (f == NULL) { #ifdef CWIN /* * Under CWIN 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! */ cwin_maximize(); #endif 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 CWIN #ifdef __cplusplus throw EXIT_FAILURE; #else longjmp(my_exit_buffer, EXIT_FAILURE); #endif #else exit(EXIT_FAILURE); #endif } #endif } continue; /* * -b 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 "-b" (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 "-b" allows the user to * coax the system into better behaviour. */ case 'b': batch_flag = YES; 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': #ifdef CWIN cwin_maximize(); #endif #ifdef macintosh term_printf("\nCopyright \231 Codemist Ltd, 1988-99\n"); #else term_printf("\nCopyright (C) Codemist Ltd, 1988-99\n"); #endif 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 { #ifdef CWIN cwin_maximize(); #endif term_printf("Too many \"-D\" requests: ignored\n"); } continue; case 'e': /* * -E * This option is for an EXPERIMENT. It may do different things in different * releases of CSL. */ continue; #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) { #ifdef CWIN cwin_maximize(); #endif 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; int sin_size; sock1 = socket(AF_INET, SOCK_STREAM, 0); if (sock1 == SOCKET_ERROR) { #ifdef CWIN cwin_maximize(); #endif 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) { #ifdef CWIN cwin_maximize(); #endif term_printf("Unable to bind socket to port %d\n", port_number); closesocket(sock1); continue; } if (listen(sock1, PERMITTED_BACKLOG) == SOCKET_ERROR) { #ifdef CWIN cwin_maximize(); #endif 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) { #ifdef CWIN cwin_maximize(); #endif 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 ms_windows 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 /* ms_windows */ 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 /* ms_windows */ } } /* * 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 /* * -G * is a debugging option - it sets !*backtrace to true, which applications * may inspect when they want to do errorsets etc. */ 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 { #ifdef CWIN cwin_maximize(); #endif term_printf("Too many requests: \"-G\" ignored\n"); } 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. */ 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 { #ifdef CWIN cwin_maximize(); #endif term_printf("Too many \"-I/-O\" requests: ignored\n"); } continue; /* * -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. */ 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 != 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. */ store_size = atof(buffer); if (store_size == 0.0) init_flags |= INIT_EXPANDABLE; else init_flags &= ~INIT_EXPANDABLE; if (*w == '/') { stack_segsize = atoi(w+1); if (stack_segsize < 1 || stack_segsize > 10) stack_segsize = 1; } } continue; /* * -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) { #ifdef CWIN cwin_maximize(); #endif 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; #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 /* * -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! */ case 'n': /* Ignore restart function (-N) */ ignore_restart_fn = YES; continue; /* * -O <file> specifies an image file for output (via FASLOUT or PRESERVE). */ 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 { #ifdef CWIN cwin_maximize(); #endif term_printf("Too many \"-I/-O\" requests: ignored\n"); } continue; /* * -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... */ #ifdef CWIN cwin_maximize(); #endif term_printf("Unimplemented option \"-%c\"\n", c1); continue; /* * -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 { #ifdef CWIN cwin_maximize(); #endif 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. */ 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 { #ifdef CWIN cwin_maximize(); #endif 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. */ 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; /* * -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 { #ifdef CWIN cwin_maximize(); #endif term_printf("Too many \"-U\" requests: ignored\n"); } continue; /* * -V selects "verbose" options at the start of the run */ 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 { #ifdef CWIN cwin_maximize(); #endif term_printf("Too many requests: \"-V\" ignored\n"); } continue; #ifdef WINDOW_SYSTEM /* * For the Archimedes I insist on a command-line option "-w" to enable * use of the windowed version of the code. For other window systems I * reserve the option for fine control over window 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. */ 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! */ case 'x': segvtrap = NO; continue; /* * -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. */ 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; /* * -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. */ case 'z': /* Cold start option -z */ restartp = NO; continue; default: #ifdef CWIN cwin_maximize(); #endif 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. */ #ifdef CWIN cwin_maximize(); #endif 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(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(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(); #ifdef WINDOW_SYSTEM #ifdef RISCOS /* * Under RISCOS I must delat starting up the window manager until about * here for two reasons. Firstly a command-line option might have been * used to decide whether or not it was wanted after all. Secondly a * side effect of find_image_directory() under RISCOS is the discovery * of the name that this application is being run as, and I want that to * go as the title in my window. */ start_up_window_manager(use_wimp); #endif #endif if (module_enquiry != NULL) { char datestamp[32], fullname[LONGEST_LEGAL_FILENAME]; int32 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)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 CWIN cwin_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 /* * Here (potentially) I could set qualifier information into native_code_tag * based on run-time checks. This might allow me to discriminate between * systems that are exactly the same as far as the CSL-controlled bits of C * code are concerned but have extra differences that a bit of system-specific * code here can detect. I will reserve the bits 0xe0 (3 bits) for such * information. Note that a system that does not support hard code MUST leave * hard_code_tag set to zero. */ native_code_tag = NATIVE_CODE_TAG; /* * 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 0x49c2: current_fp_rep = FP_ARM; break; case 0x2492: current_fp_rep = FP_370; break; case 0x2449: current_fp_rep = FP_MIPS; break; case 0x3f24: current_fp_rep = FP_VAX; break; case 0xc249: current_fp_rep = FP_88K; break; /* * 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. */ setup(restartp ? 3 : 2, store_size); #ifndef COMMON #ifdef CWIN /* * Note that it may make sense to enable this for windowed versions other * than CWIN-based ones... */ cwin_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((unsigned32)initial_random_seed, (unsigned32)seed2); gc_time += pop_clock(); interrupt_pending = already_in_gc = NO; polltick_pending = tick_pending = tick_on_gc_exit = NO; sigint_must_longjmp = NO; signal(SIGINT, sigint_handler); #ifdef TICK_STREAM /* * Now I have enough in place that I am prepared to accept regular clock- * tick events. */ add_ticker(); /* * atexit(remove_ticker); Maybe "atexit() is itself dangerous! * I should try (quite hard) to disable the * ticker at some earlier safer stage. */ #endif ensure_screen(); procedural_output = NULL; #ifdef CWIN /* * 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 CWIN to terminate * rather more promptly. */ cwin_pause_at_end = 0; #endif } } #ifdef SOCKETS #define SOCKET_BUFFER_SIZE 1024 #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 _MSC_VER Sleep(300); /* 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++] = 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() { 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 void cslaction() /* * 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 __cplusplus errorset_msg = NULL; try #else jmp_buf this_level; errorset_buffer = &this_level; errorset_msg = NULL; if (!setjmp(this_level)) #endif { signal(SIGFPE, low_level_signal_handler); #ifdef __WATCOMC__ _control87(_EM_OVERFLOW | _EM_INVALID | _EM_DENORMAL | _EM_ZERODIVIDE | _EM_INEXACT | _EM_UNDERFLOW, _MCW_EM); #endif 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 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 { nil_as_base 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) { 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 TICK_STREAM #ifdef SOFTWARE_TICKS #ifdef DEBUG_SOFTWARE_TICKS term_printf("%d ticks processed (%d)\n", number_of_ticks, SOFTWARE_TICKS); #endif #endif remove_ticker(); #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; } /* * 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 = 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)); return 0; } #if !defined(WINDOWS_NT) || defined(CWIN) || !defined(NAG) #ifdef CWIN #define ENTRYPOINT cwin_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 CWIN #ifdef NAG strcpy(about_box_title, "About AXIOM for Windows"); strcpy(about_box_description, "CWIN interface"); strcpy(about_box_rights_1,"Copyright NAG Ltd."); strcpy(about_box_rights_2,"1991-6"); #else strcpy(about_box_title, "About CSL"); strcpy(about_box_description, "Codemist Standard Lisp"); #endif #endif #ifdef __cplusplus try { res = submain(argc, argv); } catch(int r) { res = r; } #else res = setjmp(my_exit_buffer); if (res == 0) res = submain(argc, argv); if (res == 0x80000000) res = 0; #endif #ifdef TICK_STREAM remove_ticker(); #endif return res; #ifdef USE_MPI MPI_Finalize(); #endif } #endif /* NAG */ /* End of csl.c */