stk/Src/extend.c

313 lines
7.7 KiB
C
Raw Normal View History

1996-09-27 06:29:02 -04:00
/*
*
* e x t e n d . c -- All the stuff dealing with
* extended types
*
1999-09-05 07:16:41 -04:00
* Copyright <EFBFBD> 1993-1999 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
1996-09-27 06:29:02 -04:00
*
*
1999-09-05 07:16:41 -04:00
* 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.
1996-09-27 06:29:02 -04:00
*
* Author: Erick Gallesio [eg@kaolin.unice.fr]
* Creation date: 15-Mar-1995 11:31
1999-09-05 07:16:41 -04:00
* Last file update: 3-Sep-1999 20:19 (eg)
1996-09-27 06:29:02 -04:00
*/
#include "stk.h"
1998-04-10 06:59:06 -04:00
#include "stklos.h"
1996-09-27 06:29:02 -04:00
#include "extend.h"
#define EXT_TYPE_DESCR(x) (xtypes[TYPE(x)- tc_start_extd])
static int extended_type_stamp = tc_start_extd;
1998-04-10 06:59:06 -04:00
static STk_extended_scheme_type *xtypes[tc_stop_extd-tc_start_extd+1];
1996-09-27 06:29:02 -04:00
1998-04-10 06:59:06 -04:00
#ifdef USE_STKLOS
static SCM xclasses[tc_stop_extd-tc_start_extd+1];
#endif
1996-09-27 06:29:02 -04:00
/******************************************************************************
*
* Extended Types
*
******************************************************************************/
/***
***
*** Default functions
***
***/
static void internal_display(SCM obj, SCM port, int mode)
{
sprintf(STk_tkbuffer, "#<%s %lx>", (EXT_TYPE_DESCR(obj))->type_name,
(unsigned long) obj);
1999-02-02 06:13:40 -05:00
Puts(STk_tkbuffer, port);
1996-09-27 06:29:02 -04:00
}
static SCM internal_apply(SCM obj, SCM args, SCM env)
{
Err("apply: bad procedure", obj);
return UNDEFINED; /* to make the compiler happy */
}
static SCM internal_compare(SCM x, SCM y, int equalp)
{
return Ntruth;
}
/***
***
*** Utilities
***
***/
void STk_extended_mark(SCM x)
{
STk_extended_scheme_type *p= EXT_TYPE_DESCR(x);
if (p->gc_mark_fct) (*(p->gc_mark_fct))(x);
}
void STk_extended_sweep(SCM x)
{
STk_extended_scheme_type *p = EXT_TYPE_DESCR(x);
if (p->gc_sweep_fct) (*(p->gc_sweep_fct))(x);
}
SCM STk_extended_apply(SCM x, SCM args, SCM env)
{
return (*(EXT_TYPE_DESCR(x)->apply_fct))(x, args, env);
}
void STk_extended_display(SCM x, SCM port, int mode)
{
(*(EXT_TYPE_DESCR(x)->display_fct))(x, port, mode);
}
int STk_extended_procedurep(SCM x)
{
return (EXT_TYPE_DESCR(x)->flags && EXT_ISPROC);
}
int STk_extended_eval_parameters(SCM x)
{
return (EXT_TYPE_DESCR(x)->flags && EXT_EVALPARAM);
}
SCM STk_extended_compare(SCM x, SCM y, int equalp)
{
/* One of x or y (at least) is extended. */
return EXTENDEDP(x) ? (*(EXT_TYPE_DESCR(x)->compare_fct))(x, y, equalp)
: (*(EXT_TYPE_DESCR(y)->compare_fct))(x, y, equalp);
}
1998-04-10 06:59:06 -04:00
char *STk_get_extended_name(int i)
{
return ((i>=tc_start_extd) && (i<extended_type_stamp)) ?
(xtypes[i - tc_start_extd])->type_name :
NULL;
}
#ifdef USE_STKLOS
void STk_register_extended_class(SCM c, int type_index)
{
if (NNULLP(c)) {
int i = type_index - tc_start_extd;
xclasses[i] = c;
STk_gc_protect(xclasses+i);
}
}
SCM STk_extended_class_of(SCM obj) /* Warning: obj MUST be an extd type */
{
return xclasses[TYPE(obj)-tc_start_extd];
}
#endif
1996-09-27 06:29:02 -04:00
/******************************************************************************
*
* C-pointer
*
******************************************************************************/
typedef void (*STk_disp_function)(SCM x, SCM port, int mode);
1998-04-10 06:59:06 -04:00
static int Cpointer_id = ANONYMOUS_DYN_PTR_ID + 1;
1996-09-27 06:29:02 -04:00
static int size = 0;
static STk_disp_function *display_array = NULL;
static void Cpointer_default_display(SCM obj, SCM port, int mode)
{
1998-09-30 07:11:02 -04:00
sprintf(STk_tkbuffer, "#<C-pointer %d %lx>", EXTID(obj),
(unsigned long) EXTDATA(obj));
1999-02-02 06:13:40 -05:00
Puts(STk_tkbuffer, port);
1996-09-27 06:29:02 -04:00
}
void STk_Cpointer_display(SCM obj, SCM port, int mode)
{
1998-04-10 06:59:06 -04:00
int id = EXTID(obj);
if (id <= ANONYMOUS_DYN_PTR_ID)
Cpointer_default_display(obj, port, mode);
else
(*(display_array[id]))(obj, port, mode);
1996-09-27 06:29:02 -04:00
}
/******************************************************************************
*
* C variable
*
******************************************************************************/
static Tcl_HashTable Cvars;
static C_hash_table_initialized = 0;
struct get_n_set_box {
SCM (*getter)();
void (*setter)();
};
SCM STk_apply_getter_C_variable(char *var)
{
Tcl_HashEntry *entry;
1998-04-10 06:59:06 -04:00
1999-02-02 06:13:40 -05:00
if ((entry = Tcl_FindHashEntry(&Cvars, var))) {
1996-09-27 06:29:02 -04:00
struct get_n_set_box *p = (struct get_n_set_box *) Tcl_GetHashValue(entry);
return (*(p->getter))(var);
}
else {
1999-02-02 06:13:40 -05:00
Fprintf(STk_curr_eport, "internal error: %s variable has no getter!!\n", var);
1996-09-27 06:29:02 -04:00
return UNDEFINED;
}
}
void STk_apply_setter_C_variable(char *var, SCM value)
{
Tcl_HashEntry *entry;
1998-04-10 06:59:06 -04:00
1999-02-02 06:13:40 -05:00
if ((entry = Tcl_FindHashEntry(&Cvars, var))) {
1996-09-27 06:29:02 -04:00
struct get_n_set_box *p = (struct get_n_set_box *) Tcl_GetHashValue(entry);
(*(p->setter))(var, value);
}
else
1999-02-02 06:13:40 -05:00
Fprintf(STk_curr_eport, "internal error: %s variable has no setter!!\n", var);
1996-09-27 06:29:02 -04:00
}
/******************************************************************************
*
* Extended types and C-pointer User interface
*
******************************************************************************/
int STk_add_new_type(STk_extended_scheme_type *p)
{
if (!p) Err("bad new type description", NIL);
/* Set the apply procedure if not defined */
if (!p->apply_fct) p->apply_fct = internal_apply;
/* Replace NULL display function by a default function */
if (!p->display_fct) p->display_fct = internal_display;
/* Replace NULL compare function by a default function */
if (!p->compare_fct) p->compare_fct = internal_compare;
/* Store the new type descriptor in the xtypes array */
xtypes[extended_type_stamp - tc_start_extd] = p;
1998-04-10 06:59:06 -04:00
#ifdef USE_STKLOS
/* Create a new class for this type and register it */
STk_register_extended_class(STk_make_extended_class(p->type_name),
extended_type_stamp);
#endif
1996-09-27 06:29:02 -04:00
return extended_type_stamp++;
}
void STk_add_new_primitive(char *fct_name, int fct_type, struct obj * (*fct_ptr)())
{
SCM z;
NEWCELL(z, fct_type);
z->storage_as.subr0.name = fct_name;
z->storage_as.subr0.f = fct_ptr;
1998-04-10 06:59:06 -04:00
STk_define_public_var(STk_selected_module, Intern(fct_name), z);
1996-09-27 06:29:02 -04:00
}
SCM STk_eval_C_string(char *s, SCM env)
{
SCM tmp = STk_internal_eval_string(s, ERR_OK, env);
return tmp == EVAL_ERROR ? NULL: tmp;
}
/*************************/
int STk_new_Cpointer_id(void (*display_func)(SCM x, SCM port, int mode))
{
if (++Cpointer_id >= size) {
if (display_array == NULL) {
display_array = must_malloc(10*sizeof (STk_disp_function));
size = 10;
}
else {
size += size / 2;
display_array = must_realloc(display_array,
size * sizeof (STk_disp_function));
}
}
/* store function in array */
display_array[Cpointer_id]= display_func? display_func : Cpointer_default_display;
return Cpointer_id;
}
SCM STk_make_Cpointer(int Cpointer_id, void *ptr, int staticp)
{
register SCM z;
NEWCELL(z, tc_Cpointer);
EXTDATA(z) = ptr;
EXTID(z) = Cpointer_id;
EXTSTATICP(z) = staticp;
return z;
}
/*************************/
void STk_define_C_variable(char *var, SCM (*getter)(), void (*setter)())
{
Tcl_HashEntry *entry;
int new;
struct get_n_set_box *p;
if (!C_hash_table_initialized) {
/* First C-var. Create Hash table */
Tcl_InitHashTable(&Cvars, TCL_STRING_KEYS);
C_hash_table_initialized = 1;
}
p = must_malloc(sizeof(struct get_n_set_box));
p->getter = getter;
p->setter = setter;
entry = Tcl_CreateHashEntry(&Cvars, var, &new);
if (!new) {
1999-02-02 06:13:40 -05:00
Fprintf(STk_curr_eport, "Attempt to multi-define C variable `%s' !!\n", var);
1996-09-27 06:29:02 -04:00
return;
}
Tcl_SetHashValue(entry, p);
/* Now enter variable in obarray and set its info field to C variable */
Intern(var)->cell_info = CELL_INFO_C_VAR;
}