/* * s l i b . c -- Misc functions * * Copyright (C) 1993,1994,1995 Erick Gallesio - I3S-CNRS/ESSI * * * Permission to use, copy, and/or distribute this software and its * documentation for any purpose and without fee is hereby granted, provided * that both the above copyright notice and this permission notice appear in * all copies and derived works. Fees for distribution or use of this * software or derived works may only be charged with express written * permission of the copyright holder. * This software is provided ``as is'' without express or implied warranty. * * This software is a derivative work of other copyrighted softwares; the * copyright notices of these softwares are placed in the file COPYRIGHTS * * Author: Erick Gallesio [eg@unice.fr] * Creation date: ??-Oct-1993 ??:?? * Last file update: 16-Jul-1995 10:30 * */ #include "stk.h" #include "gc.h" #include #include #include #ifndef _DEBUG_MALLOC_INC #ifdef malloc #undef malloc #endif #ifdef realloc #undef realloc #endif void *STk_must_malloc(unsigned long size) { void *tmp; tmp = (void *) malloc(size); /* Test for size because some libc return NULL when doing malloc(0) */ if (tmp == NULL && size) Err("failed to allocate storage from system", NIL); return(tmp); } void *STk_must_realloc(void *ptr, unsigned long size) { void *tmp; tmp = (void *) realloc(ptr, size); if (tmp == NULL) Err("failed to re-allocate storage from system",NIL); return(tmp); } #endif int STk_strcmpi(register char *p1, register char *p2) { for( ; tolower(*p1) == tolower(*p2); p1++, p2++) if (!*p1) return 0; return tolower(*p1) - tolower(*p2); } SCM STk_internal_eval_string(char *s, long context, SCM env) { jmp_buf jb, *prev_jb = Top_jmp_buf; long prev_context = Error_context; SCM result, port; int k; /* Create a string port to read the command and evaluate it in a new context */ port = STk_internal_open_input_string(s); /* save normal error jmpbuf so that eval error don't lead to toplevel */ /* If in a "catch", keep the ERR_IGNORED bit set */ if ((k = setjmp(jb)) == 0) { Top_jmp_buf = &jb; Error_context = (Error_context & ERR_IGNORED) | context; result = STk_eval(STk_readf(port->storage_as.port.f, FALSE), env); } Top_jmp_buf = prev_jb;; Error_context = prev_context; if (k == 0) return result; /* if we are here, an error has occured during the string reading * Two cases: * - we are in a catch. Do a longjump to the catch to signal it a fail * - otherwise error has already signaled, just return EVAL_ERROR */ if (Error_context & ERR_IGNORED) longjmp(*Top_jmp_buf, k); return EVAL_ERROR; } PRIMITIVE STk_catch(SCM expr, SCM env, int unused_len) { jmp_buf jb, *prev_jb = Top_jmp_buf; long prev_context = Error_context; SCM l; int k; /* save normal error jmpbuf so that eval error don't lead to toplevel */ if ((k = setjmp(jb)) == 0) { Top_jmp_buf = &jb; Error_context |= ERR_IGNORED; /* Evaluate the list of expressions */ for (l = expr; NNULLP(l); l = CDR(l)) STk_eval(CAR(l), env); } Top_jmp_buf = prev_jb; Error_context = prev_context; /* Don't use a mask to allow nested call to catch */ return (k == 0)? Ntruth: Truth; } 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); } STk_unwind_all(); /* call user finalization code */ STk_user_cleanup(); #ifdef USE_TK Tcl_DeleteInterp(STk_main_interp); /* Unregister the interpreter from X server */ #endif exit(ret); } PRIMITIVE STk_version(void) { return STk_makestring(STK_VERSION); } PRIMITIVE STk_machine_type(void) { return STk_makestring(MACHINE); } 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(STk_integer_value_no_overflow(n)); return UNDEFINED; } #ifndef HZ #define HZ 60.0 #endif double STk_my_time(void) { struct tms time_buffer; times(&time_buffer); return 1000 * (time_buffer.tms_utime + time_buffer.tms_stime) / HZ; } PRIMITIVE STk_get_internal_info(void) { SCM z = STk_makevect(7, NULL); 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(stderr, ";; 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; } /* 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_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 USE_TK /****************************************************************************** * * Trace var * ******************************************************************************/ static char *TraceVarFct(ClientData clientData, Tcl_Interp *interp, char *name1, char *name2, int flags) { /* * ClientData is the only field which insterest us here. It contains a * string to evaluate */ Tcl_GlobalEval(interp, (char*) clientData); return NULL; /* to make the compiler happy */ } PRIMITIVE STk_trace_var(SCM var, SCM code) { char *s1, *s2; SCM dumb; if (NSYMBOLP(var)) Err("trace-var: bad variable name", var); s1 = STk_convert_for_tk(code, &dumb); /* * Build a copy of s1 and set it as the ClientData for Tcl_TraceVar * Duplication of s1 permits to be sure that the hash table has its * own copy of the code to evaluate since original code can be garbaged. * TCL_TRACE_READS flags is used here to indicate to untrace to free * the code string. */ s2 = (char *) must_malloc(strlen(s1) + 1); strcpy(s2, s1); Tcl_TraceVar(STk_main_interp, PNAME(var), TCL_TRACE_READS|TCL_TRACE_WRITES, TraceVarFct, (ClientData) s2); return UNDEFINED; } PRIMITIVE STk_untrace_var(SCM var) { if (NSYMBOLP(var)) Err("untrace-var: bad variable name", var); Tcl_CompleteUntraceVar(STk_main_interp, PNAME(var)); return UNDEFINED; } #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 * ******************************************************************************/ typedef void (*dumb)(); dumb STk_dumb[] = { (dumb) Tcl_TildeSubst, (dumb) Tcl_SetVar2 };