/* * s l i b . c -- Misc functions * * Copyright © 1993-1999 Erick Gallesio - I3S-CNRS/ESSI * * * Permission to use, copy, modify, distribute,and license this * software and its documentation for any purpose is hereby granted, * provided that existing copyright notices are retained in all * copies and that this notice is included verbatim in any * distributions. No written agreement, license, or royalty fee is * required for any of the authorized uses. * This software is provided ``AS IS'' without express or implied * warranty. * * Author: Erick Gallesio [eg@unice.fr] * Creation date: ??-Oct-1993 ??:?? * Last file update: 3-Sep-1999 20:22 (eg) * */ #ifdef WIN32 # include #endif #include "stk.h" #include "gc.h" #include #include #ifdef WIN32 # include # ifndef CYGWIN32 # include # endif # include # include #else # include # include #endif #ifdef USE_TK # include "tk-glue.h" #endif #ifndef _DEBUG_MALLOC_INC #ifdef malloc #undef malloc #endif #ifdef realloc #undef realloc #endif #define MAX_MALLOC_BEFORE_GC 1<<20 /* 1 Mb should suffice before calling GC */ static size_t malloc_count = 0; static void cannot_allocate() { Puts("**** Storage allocation from system failed\n", STk_curr_eport); Puts("**** Evaluation aborted\n", STk_curr_eport); STk_gc_requested = 1; STk_allow_signals(); /* Use a null message to avoid a call to report-error (which uses conses) */ Err("", NIL); } void *STk_must_malloc(size_t size) { void *tmp; /* STk_ignore_signals(); */ tmp = (void *) malloc(size); /* Test for size because some libc return NULL when doing malloc(0) */ if (tmp == NULL && size) cannot_allocate(); /* Idea of malloc limitation comes from Harvey J. Stein * . The following code provoke a GC when * MAX_MALLOC_BEFORE_GC have been allocated by must_malloc. This * allows to GC before all cells have been exhausted */ malloc_count +=size; if (malloc_count > MAX_MALLOC_BEFORE_GC) { malloc_count = 0; STk_gc_requested = 1; } /* STk_allow_signals(); */ return tmp; } void *STk_must_realloc(void *ptr, size_t size) { void *tmp; STk_ignore_signals(); tmp = (void *) realloc(ptr, size); /* Since we cannot know (in a portable way) the size of area pointed by ptr, * we will make the assumption that it is half the new requested size. * Of course, we are probably false here, but it seems more reasonable than * brutally increment it with size. */ malloc_count +=size/2; if (malloc_count > MAX_MALLOC_BEFORE_GC) { malloc_count = 0; STk_gc_requested = 1; } if (tmp == NULL) cannot_allocate(); STk_allow_signals(); return tmp; } #endif SCM STk_internal_eval_string(char *s, long context, SCM env) { SCM result, port; PUSH_ERROR_HANDLER { /* Create a string port to read the sexpr and evaluate it in a new context */ STk_err_handler->context |= context; port = STk_internal_open_input_string(s); result = STk_eval(STk_readf(port, FALSE), env); } WHEN_ERROR { /* Two cases: * - if we are in a catch, propagate the error to go back in the * context of the catch * - otherwise error has already been signaled, do nothing */ if ((STk_err_handler->context & ERR_TCL_BACKGROUND) && STk_control_C) result = Ntruth; else { if (STk_err_handler->context & ERR_IGNORED) PROPAGATE_ERROR(); result = EVAL_ERROR; } } POP_ERROR_HANDLER; return result; } PRIMITIVE STk_catch(SCM expr, SCM env, int unused_len) { SCM result; SCM l; PUSH_ERROR_HANDLER { /* Evaluate the list of expressions in a context where errors are ignored */ STk_err_handler->context |= ERR_IGNORED; for (l = expr; NNULLP(l); l = CDR(l)) STk_eval(CAR(l), env); result = Ntruth; } WHEN_ERROR { result = Truth; } POP_ERROR_HANDLER; return result; } PRIMITIVE STk_quit_interpreter(SCM retcode) { long ret = 0; if (retcode != UNBOUND) { if ((ret=STk_integer_value(retcode)) == LONG_MIN) Err("quit: bad return code", retcode); } /* Execute all the terminal thunks of pending dynamic-wind */ STk_unwind_all(); /* call user finalization code */ STk_user_cleanup(); #ifdef USE_TK /* Unregister the interpreter from X server */ if (Tk_initialized) Tcl_DeleteCommand(STk_main_interp, "."); #endif #if defined(WIN32) && defined(USE_SOCKET) /* Unregister the interpreter from Winsock */ WSACleanup(); #endif exit(ret); return UNDEFINED; /* never reached */ } PRIMITIVE STk_version(void) { return STk_makestring(STK_VERSION); } PRIMITIVE STk_machine_type(void) { return STk_makestring(MACHINE); } PRIMITIVE STk_library_location(void) { return STk_makestring(STk_library_path); } PRIMITIVE STk_random(SCM n) { if (NEXACTP(n) || STk_negativep(n) == Truth || STk_zerop(n) == Truth) Err("random: bad number", n); return STk_modulo(STk_makeinteger(rand()), n); } PRIMITIVE STk_set_random_seed(SCM n) { if (NEXACTP(n)) Err("set-random-seed!: bad number", n); srand((unsigned int) STk_integer_value_no_overflow(n)); return UNDEFINED; } #ifndef HZ #define HZ 60.0 #endif #ifdef CLOCKS_PER_SEC # define TIC CLOCKS_PER_SEC #else # define TIC HZ #endif double STk_my_time(void) { #ifdef WIN32 return (long) 1000*(clock()/CLK_TCK); #else struct tms time_buffer; times(&time_buffer); return 1000 * (time_buffer.tms_utime + time_buffer.tms_stime) / TIC; #endif } PRIMITIVE STk_get_internal_info(void) { SCM z = STk_makevect(7, NIL); long allocated, used, calls; /* The result is a vector which contains * 0 The total cpu used in ms * 1 The number of cells currently in use. * 2 Total number of allocated cells * 3 The number of cells used since the last call to get-internal-info * 4 Number of gc calls * 5 Total time used in the gc * 6 A boolean indicating if Tk is initialized */ STk_gc_count_cells(&allocated, &used, &calls); VECT(z)[0] = STk_makenumber(STk_my_time()); VECT(z)[1] = STk_makeinteger(used); VECT(z)[2] = STk_makeinteger(allocated); VECT(z)[3] = STk_makenumber((double) STk_alloc_cells); VECT(z)[4] = STk_makeinteger(calls); VECT(z)[5] = STk_makenumber((double) STk_total_gc_time); #ifdef USE_TK VECT(z)[6] = Tk_initialized ? Truth: Ntruth; #else VECT(z)[6] = Ntruth; #endif STk_alloc_cells = 0; return z; } PRIMITIVE STk_time(SCM expr, SCM env, int len) { double rt, gc_time; SCM res; if (len != 1) Err("time: bad expression" , expr); STk_alloc_cells = 0; gc_time = STk_total_gc_time; rt = STk_my_time(); res = EVALCAR(expr); Fprintf(STk_curr_eport, ";; Time: %.2fms\n;; GC time: %.2fms\n;; Cells: %ld\n", STk_my_time()-rt, STk_total_gc_time-gc_time, STk_alloc_cells); return res; } /* * STk_delete_Tcl_child_Interp * * This function must be called by a child process just after a fork * It deletes the Tk commands associated to the interpreter (except send, * to avoid interpreter unregistering). * * This must probably rewritten */ void STk_delete_Tcl_child_Interp(void) { #ifdef USE_TK if (Tk_initialized) { struct Tk_command *W; Interp *iPtr = (Interp *) STk_main_interp; Tcl_HashEntry *hPtr; /* Try to find "send". Modify it's delproc to point NULL */ hPtr = Tcl_FindHashEntry(&iPtr->globalNsPtr->cmdTable, "send"); if (hPtr != NULL) { W = (struct Tk_command *) Tcl_GetHashValue(hPtr); W->delproc = NULL; } /* Now we can destroy the interpreter (send will not be destroyed) */ Tcl_DeleteInterp(STk_main_interp); /* Report-error points to a graphical procedure. Undefine it * to display error messages on stderr in the child process */ STk_define_variable(REPORT_ERROR, UNBOUND, NIL); /* Redefine exit to the standard STk exit function */ STk_add_new_primitive("exit", tc_subr_0_or_1, STk_quit_interpreter); } #else /* Nothing to do for Snow */ #endif } /* When STk evaluates an expression, it recodes it in a manner which permits it to be more efficient for further evaluations. The uncode functions permits to do the reverse job: it takes an exppression and returns a form similar to the original one. Warning: when a macro has been expanded, there is no mean to "revert" it to its original form */ static SCM associate(SCM l1, SCM l2) { SCM z; if (NULLP(l1)) return NIL; for(z= NIL; NNULLP(l1); l1=CDR(l1), l2=CDR(l2)) z = Cons(LIST2(CAR(l1), STk_uncode(CAR(l2))), z); return Reverse(z); } static SCM uncode_let(char *type, SCM expr) { return Cons(Intern(type), Cons(associate(CAR(expr), CAR(CDR(expr))), STk_uncode(CDR(CDR(expr))))); } PRIMITIVE STk_uncode(SCM expr) { switch (TYPE(expr)) { case tc_cons: switch (TYPE(CAR(expr))) { case tc_let: return uncode_let("let", CDR(expr)); case tc_letstar: return uncode_let("let*", CDR(expr)); case tc_letrec: return uncode_let("letrec", CDR(expr)); case tc_if: expr = CDR(expr); if (EQ(CAR(CDR(CDR(expr))), UNDEFINED)) return Cons(Intern("if"), LIST2(STk_uncode(CAR(expr)), STk_uncode(CAR(CDR(expr))))); else return Cons(Intern("if"), LIST3(STk_uncode(CAR(expr)), STk_uncode(CAR(CDR(expr))), STk_uncode(CAR(CDR(CDR(expr)))))); default: return Cons(STk_uncode(CAR(expr)), STk_uncode(CDR(expr))); } case tc_quote: return Intern("quote"); case tc_lambda: return Intern("lambda"); case tc_if: return Intern("if"); case tc_setq: return Intern("set!"); case tc_cond: return Intern("cond"); case tc_and: return Intern("and"); case tc_or: return Intern("or"); case tc_let: return Intern("let"); case tc_letstar: return Intern("letstar"); case tc_letrec: return Intern("letrec"); case tc_begin: return Intern("begin"); case tc_globalvar: return VCELL(expr); case tc_localvar: return expr->storage_as.localvar.symbol; case tc_modulevar: return CAR(CAR(expr)); case tc_apply: return Intern("apply"); case tc_call_cc: return Intern("call-with-current-continuation"); case tc_dynwind: return Intern("dynamic-wind"); case tc_extend_env: return Intern("extend-environment"); default: return expr; } } #ifdef DEBUG_STK /* Debug code to use with debugger */ void dbg(SCM obj); void dbgeval(void); void dbg(SCM obj) { Fprintf(STk_curr_eport, " <<#p%lx>> ", (unsigned long) obj); STk_print(obj, STk_curr_eport, WRT_MODE); Putc('\n', STk_curr_eport); } void dbgeval(void) { SCM x; for ( ; ; ) { Fprintf(STk_curr_eport, "Debug STk> "); Flush(STk_curr_eport); if (EQ(x=STk_readf(STk_stdin, FALSE), STk_eof_object)) return; dbg(STk_eval(x, STk_selected_module)); } } void Debug(char *message, SCM obj) { Flush(STk_curr_oport); Flush(STk_curr_eport); Puts("****", STk_curr_eport); Puts(message, STk_curr_eport); dbg(obj); Flush(STk_curr_oport); Flush(STk_curr_eport); } #endif /****************************************************************************** * * The following declarations serve only for referencing symbols which are used * by Tcl or Tk and which are defined in this directory. Otherwise, the ld will * not find them and report an error * ******************************************************************************/ #ifndef WIN32 typedef void (*dumb)(); dumb STk_dumb[] = { (dumb) Tcl_TildeSubst, (dumb) Tcl_SetVar2, (dumb) Tcl_NewListObj }; #endif