conservatory
/
stk
4
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity
stk/Src/slib.c

478 lines
12 KiB
C
Raw Permalink Blame History

/*
* s l i b . c -- Misc functions
*
* Copyright © 1993-1999 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
*
*
* 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 <windows.h>
#endif
#include "stk.h"
#include "gc.h"
#include <sys/types.h>
#include <sys/stat.h>
#ifdef WIN32
# include <time.h>
# ifndef CYGWIN32
# include <dos.h>
# endif
# include <process.h>
# include <tclWinPort.h>
#else
# include <stdarg.h>
# include <sys/times.h>
#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
* <hjstein@MATH.HUJI.AC.IL>. 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
Reference in New Issue View Git Blame Copy Permalink