stk/Src/stk.h

1689 lines
51 KiB
C

/******************************************************************************
*
* s t k . h
*
* Copyright © 1993-1999 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
*
*
* 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
*
* $Id: stk.h 1.29 Tue, 02 Feb 1999 15:29:27 +0100 eg $
*
* Author: Erick Gallesio [eg@unice.fr]
* Creation date: 12-May-1993 10:34
* Last file update: 2-Feb-1999 13:44
*
******************************************************************************/
#ifndef _STK_H
#define _STK_H
#ifdef WIN32
# define MACHINE "Ms-Win32"
# define STK_DEBUG // FIXME
# define STK_VERSION "3.99.4" // FIXME
# include <windows.h> /* for the panic procedure */
#endif
#ifdef __cplusplus
extern "C" {
#endif
#include <stdio.h>
#include <setjmp.h>
#include <assert.h>
#include <math.h>
#include <signal.h>
#include <limits.h>
#include <string.h>
#include <sys/types.h>
#include <errno.h>
#ifndef WIN32
# include <memory.h>
#endif
#ifdef HAVE_UNISTD_H
# include <unistd.h>
#endif
#include <stdlib.h>
#include <gmp.h>
#ifdef WIN32 // FIXME
# define USE_HASH
//#define USE_SOCKET
# define USE_REGEXP
//#define USE_PROCESS
//#define USE_POSIX
# define USE_HTML
# define USE_PIXMAP
//#define USE_JPEG
# define USE_BASE64
# define USE_LOCALE
#endif
/*
* Headers <tcl*.h> are always included (even if not USE_TK) for the hash table
* function prototypes, and for implementing the crazy Tcl_Obj type.
*/
#ifdef STk_CODE
# ifdef OSF1
# define HAS_STDARG /* Hacky */
# endif
#endif
#include <tcl.h>
#include <tclInt.h>
/* ------------------------------------------------------------------------------ */
#define COMPACT_SMALL_CST /* compact coding for small const */
#define FALSE 0
#define TRUE 1
#define TKBUFFERN 1024 /* max size of a token */
#define MAX_CHAR_CODE 255 /* Max code for a char */
#ifdef USE_TK
# ifdef WIN32
# define INITIAL_HEAP_SIZE 40000 /* size of heap Win32 (in cells) */
# else
# define INITIAL_HEAP_SIZE 25000 /* size of heap X11 (in cells) */
# endif
#else
# define INITIAL_HEAP_SIZE 10000 /* size of heap snow (in cells) */
#endif
#ifdef _POSIX_PATH_MAX
#define MAX_PATH_LENGTH _POSIX_PATH_MAX
#else
#define MAX_PATH_LENGTH 256
#endif
#define GC_VERBOSE "*gc-verbose*"
#define ARGC "*argc*"
#define ARGV "*argv*"
#define PROG_NAME "*program-name*"
#define DEBUG_MODE "*debug*"
#define EVAL_HOOK "*eval-hook*"
#define PRINT_BANNER "*print-banner*"
#define LOAD_PATH "*load-path*"
#define LOAD_SUFFIXES "*load-suffixes*"
#define LOAD_VERBOSE "*load-verbose*"
#define LAST_DEFINED "*last-defined*"
#define STK_LIBRARY "*stk-library*"
#define REPORT_ERROR "report-error"
#ifdef USE_TK
# include <tk.h>
# define ROOT_WINDOW "*root*" /* Scheme name of main window */
# define ERROR_INFO "*error-info*"
# define USE_THREAD /* Very very experimental */
struct Tk_command {
ClientData ptr; /* pointer associated to the widget command */
Tcl_CmdProc *fct; /* Tk lib function associated to widget */
Tcl_CmdDeleteProc *delproc; /* procedure to call when command is destroyed */
ClientData deldata; /* value to pass to delproc */
short deleted; /* 1 if command has already been deleted */
short objproc; /* 1 if command is an tcl_Obj procedure */
char Id[1]; /* must be last field */
};
#endif
struct obj { /* most alignment constraining type first */
union {struct {struct obj * car; struct obj * cdr;} cons;
struct {double data;} flonum;
struct {char *pname; struct obj * vcell;} symbol;
struct {char *name; struct obj * (*f)(void);} subr0;
struct {char *name; struct obj * (*f)(void *,...);} subr;
struct {struct obj *env; struct obj *code;} closure;
struct {struct obj *code; struct obj* env;} macro;
struct {long dim; char *data;} string;
struct {long dim; struct obj **data;} vector;
struct {struct port_descr *p; int ungetted_char;} port;
struct {char *data;} keyword;
struct {MP_INT *data;} bignum;
struct {short level, position; struct obj *symbol;} localvar;
struct {struct obj *expr; int resultknown; } promise;
struct {void *data; } cont;
struct {struct obj *data;} env;
struct {short id; char staticp; void *data; } extension;
struct {struct Tcl_HashTable *t; void *data; } module;
struct {struct obj *data; } tcl;
#ifdef USE_STKLOS
struct {int type_flags; struct stklos_instance *data;} instance;
#endif
#ifdef USE_TK
/* Idea of l_data comes from Alexander Taranov <tay@jet.msk.edu> */
struct {struct Tk_command *data; struct obj *l_data;} tk;
#endif
} storage_as;
unsigned char type;
unsigned char gc_mark;
short cell_info;
};
typedef struct obj* SCM;
typedef struct obj* PRIMITIVE;
#define tc_nil 0
#define tc_cons 1
#define tc_flonum 2
#define tc_integer 3
#define tc_bignum 4
#define tc_symbol 5
#define tc_keyword 6
#define tc_subr_0 7
#define tc_subr_1 8
#define tc_subr_2 9
#define tc_subr_3 10
#define tc_subr_0_or_1 11
#define tc_subr_1_or_2 12
#define tc_subr_2_or_3 13
#define tc_lsubr 14
#define tc_ssubr 15
#define tc_fsubr 16
#define tc_syntax 17
#define tc_closure 18
#define tc_free_cell 19
#define tc_char 20
#define tc_string 21
#define tc_vector 22
#define tc_eof 23
#define tc_undefined 24
#define tc_iport 25
#define tc_oport 26
#define tc_isport 27
#define tc_osport 28
#define tc_ivport 29
#define tc_ovport 30
#define tc_boolean 31
#define tc_macro 32
#define tc_localvar 33
#define tc_globalvar 34
#define tc_modulevar 35
#define tc_cont 36
#define tc_env 37
#define tc_address 38
#define tc_autoload 39
#define tc_Cpointer 40
#define tc_module 41
#define tc_frame 42
#define tc_values 43
#ifdef USE_STKLOS
# define tc_instance 45
# define tc_next_method 46
#endif
#ifdef USE_TK
# define tc_tkcommand 50
#endif
#define tc_tclobject 51 /* always defined, even if NO_TK */
#define tc_quote 61
#define tc_lambda 62
#define tc_if 63
#define tc_setq 64
#define tc_cond 65
#define tc_and 66
#define tc_or 67
#define tc_let 68
#define tc_letstar 69
#define tc_letrec 70
#define tc_begin 71
#define tc_promise 72
#define tc_apply 73
#define tc_call_cc 74
#define tc_dynwind 75
#define tc_extend_env 76
#define tc_unbound 80
#define tc_start_extd 90 /* Number of first extended type */
#define tc_stop_extd 127 /* Number of last extended type */
#define CAR(x) ((*x).storage_as.cons.car)
#define CDR(x) ((*x).storage_as.cons.cdr)
#define PNAME(x) ((*x).storage_as.symbol.pname)
#define KEYVAL(x) ((*x).storage_as.keyword.data)
#define VCELL(x) ((*x).storage_as.symbol.vcell)
#define SUBR0(x) (*((*x).storage_as.subr0.f))
#define SUBRF(x) (*((*x).storage_as.subr.f))
#define FLONM(x) ((*x).storage_as.flonum.data)
#define CHARS(x) ((*x).storage_as.string.data)
#define STRSIZE(x) ((*x).storage_as.string.dim)
#define VECT(x) ((*x).storage_as.vector.data)
#define VECTSIZE(x) ((*x).storage_as.vector.dim)
#define BIGNUM(x) ((*x).storage_as.bignum.data)
#define EXTDATA(x) ((*x).storage_as.extension.data)
#define EXTID(x) ((*x).storage_as.extension.id)
#define EXTSTATICP(x) ((*x).storage_as.extension.staticp)
#define TCLOBJDATA(x) ((*x).storage_as.tcl.data)
#define CLOSENV(x) ((*x).storage_as.closure.env)
#define CLOSCODE(x) ((*x).storage_as.closure.code)
#define CLOSARITY(x) ((*x).cell_info)
#define CLOSPARAMS(x) (CAR(CLOSCODE(x)))
#define CLOSBODY(x) (CDR(CLOSCODE(x)))
#ifdef COMPACT_SMALL_CST
# define MAKE_SMALL_CST(x,type) (((long) (x) << 8) |((type) << 1) | 1)
# define SMALL_CST_TYPE(x) (((long) (x) >> 1) & 0x7F)
# define SMALL_CST_VALUE(x) ((long) (x) >> 8)
# define SMALL_CSTP(x) ((long) (x) & 1)
# define TYPE(x) (SMALL_CSTP(x) ? (int)SMALL_CST_TYPE(x):(x)->type)
# define INTEGER(x) SMALL_CST_VALUE(x)
# define SET_INTEGER(x, v) (x = (SCM) MAKE_SMALL_CST(v, tc_integer))
# define CHAR(x) ((unsigned char) SMALL_CST_VALUE(x))
# define SET_CHARACTER(x, v) (x = (SCM) MAKE_SMALL_CST(v, tc_char))
#else
# define SMALL_CSTP(x) FALSE
# define TYPE(x) ((x)->type)
# define INTEGER(x) ((long) ((x)->storage_as.extension.data))
# define SET_INTEGER(x, v) (INTEGER(x) = (v))
# define CHAR(x) ((unsigned char) ((x)->storage_as.extension.data)
# define SET_CHARACTER(x, v) (CHAR(x) = (v))
#endif
#define EQ(x,y) ((x) == (y))
#define NEQ(x,y) ((x) != (y))
#define NULLP(x) EQ(x,NIL)
#define NNULLP(x) NEQ(x,NIL)
#define TYPEP(x,y) (TYPE(x) == (y))
#define NTYPEP(x,y) (TYPE(x) != (y))
#define CONSP(x) TYPEP(x,tc_cons)
#define CLOSUREP(x) TYPEP(x,tc_closure)
#define FLONUMP(x) TYPEP(x,tc_flonum)
#define SYMBOLP(x) TYPEP(x,tc_symbol)
#define KEYWORDP(x) TYPEP(x,tc_keyword)
#define STRINGP(x) TYPEP(x,tc_string)
#define EOFP(x) TYPEP(x, tc_eof)
#define BOOLEANP(x) TYPEP(x, tc_boolean)
#define VECTORP(x) TYPEP(x,tc_vector)
#define IPORTP(x) TYPEP(x,tc_iport)
#define OPORTP(x) TYPEP(x,tc_oport)
#define ISPORTP(x) TYPEP(x,tc_isport)
#define OSPORTP(x) TYPEP(x,tc_ovport)
#define IVPORTP(x) TYPEP(x,tc_ivport)
#define OVPORTP(x) TYPEP(x,tc_osport)
#define SPORTP(x) (ISPORTP(x)||OSPORTP(x))
#define INTEGERP(x) TYPEP(x,tc_integer)
#define BIGNUMP(x) TYPEP(x,tc_bignum)
#define NUMBERP(x) (FLONUMP(x) || INTEGERP(x) || BIGNUMP(x))
#define EXACTP(x) (INTEGERP(x) || BIGNUMP(x))
#define INTP(x) (INTEGERP(x) || BIGNUMP(x))
#define CHARP(x) TYPEP(x,tc_char)
#define PROMISEP(x) TYPEP(x,tc_promise)
#define CONTINUATIONP(x) TYPEP(x,tc_cont)
#define ENVP(x) TYPEP(x,tc_env)
#define MACROP(x) TYPEP(x,tc_macro)
#define EXTENDEDP(x) (tc_start_extd <= TYPE(x))
#define CPOINTERP(x) TYPEP(x,tc_Cpointer)
#define MODULEP(x) TYPEP(x,tc_module)
#define FRAMEP(x) TYPEP(x,tc_frame)
#define VALUESP(x) TYPEP(x,tc_values)
#define NCONSP(x) NTYPEP(x,tc_cons)
#define NCLOSUREP(x) NTYPEP(x,tc_closure)
#define NFLONUMP(x) NTYPEP(x,tc_flonum)
#define NSYMBOLP(x) NTYPEP(x,tc_symbol)
#define NKEYWORDP(x) NTYPEP(x,tc_keyword)
#define NSTRINGP(x) NTYPEP(x,tc_string)
#define NEOFP(x) NTYPEP(x, tc_eof)
#define NBOOLEANP(x) NTYPEP(x, tc_boolean)
#define NVECTORP(x) NTYPEP(x,tc_vector)
#define NIPORTP(x) NTYPEP(x,tc_iport)
#define NOPORTP(x) NTYPEP(x,tc_oport)
#define NISPORTP(x) NTYPEP(x,tc_isport)
#define NOSPORTP(x) NTYPEP(x,tc_osport)
#define NSPORTP(x) (!SPORTP(x))
#define NINTEGERP(x) NTYPEP(x,tc_integer)
#define NBIGNUMP(x) NTYPEP(x,tc_bignum)
#define NNUMBERP(x) (NFLONUMP(x) && NINTEGERP(x) && NBIGNUMP(x))
#define NEXACTP(x) (NINTEGERP(x) && NBIGNUMP(x))
#define NINTP(x) (NINTEGERP(x) && NBIGNUMP(x))
#define NCHARP(x) NTYPEP(x,tc_char)
#define NPROMISEP(x) NTYPEP(x,tc_promise)
#define NCONTINUATIONP(x) NTYPEP(x,tc_cont)
#define NENVP(x) NTYPEP(x,tc_env)
#define NMACROP(x) NTYPEP(x,tc_macro)
#define NEXTENDEDP(x) (!EXTENDEDP(x))
#define NCPOINTERP(x) NTYPEP(x,tc_Cpointer)
#define NMODULEP(x) NTYPEP(x,tc_module)
#define NFRAMEP(x) NTYPEP(x,tc_frame)
#define NVALUESP(x) NTYPEP(x,tc_values)
#ifdef USE_TK
# define TKCOMMP(x) TYPEP(x,tc_tkcommand)
# define TCLOBJP(x) TYPEP(x,tc_tclobject)
# define NTKCOMMP(x) NTYPEP(x,tc_tkcommand)
# define NTCLOBJP(x) NTYPEP(x,tc_tclobject)
#endif
#define ModifyCode() NEQ(VCELL(STk_sym_debug), STk_truth)
#define SYNTAX_RETURN(x, need_eval) \
{ *pform = (x); return (need_eval); }
#ifdef _DEBUG_MALLOC_INC
#define must_malloc(n) malloc(n)
#define must_realloc(p, n) realloc(p, n)
#endif
#define CELL_INFO_C_VAR 01 /* Symbol is a C variable */
#define CELL_INFO_TRACED_VAR 02 /* Symbol is traced */
#define TRACED_VARP(var) (((var)->cell_info) & CELL_INFO_TRACED_VAR)
/******************************************************************************/
/******************************************************************************/
/******************************************************************************/
/******************************************************************************/
/*
------------------------------------------------------------------------------
----
---- A D D R E S S . C
----
------------------------------------------------------------------------------
*/
SCM STk_address2object(char *buffer);
PRIMITIVE STk_address_of(SCM obj);
PRIMITIVE STk_addressp(SCM address);
/*
------------------------------------------------------------------------------
----
---- A R G V . C
----
------------------------------------------------------------------------------
*/
#ifdef USE_TK
extern char *STk_arg_Xdisplay;
extern char *STk_arg_geometry;
extern char *STk_arg_name;
extern char *STk_arg_visual;
extern int STk_arg_colormap;
extern int STk_arg_sync;
extern int STk_arg_no_tk;
extern int STk_arg_console;
#endif
extern char *STk_arg_file;
extern char *STk_arg_load;
extern char *STk_arg_cells;
extern char *STk_arg_image;
extern int STk_arg_interactive;
char** STk_process_argc_argv(int argc, char **argv);
void STk_save_unix_args_and_environment(int argc, char **argv);
void STk_restore_unix_args_and_environment(int *argc, char ***argv);
void STk_initialize_scheme_args(char **argv);
/*
------------------------------------------------------------------------------
----
---- B O O L E A N . C
----
------------------------------------------------------------------------------
*/
PRIMITIVE STk_not(SCM x);
PRIMITIVE STk_booleanp(SCM x);
PRIMITIVE STk_eqv(SCM x, SCM y);
PRIMITIVE STk_eq(SCM x,SCM y);
PRIMITIVE STk_equal(SCM x, SCM y);
/*
------------------------------------------------------------------------------
----
---- C H A R . C
----
------------------------------------------------------------------------------
*/
unsigned char STk_string2char(char *s);
unsigned char *STk_char2string(unsigned char c);
SCM STk_makechar(unsigned char c);
PRIMITIVE STk_charp(SCM obj);
PRIMITIVE STk_chareq (SCM c1, SCM c2);
PRIMITIVE STk_charless (SCM c1, SCM c2);
PRIMITIVE STk_chargt (SCM c1, SCM c2);
PRIMITIVE STk_charlesse(SCM c1, SCM c2);
PRIMITIVE STk_chargte (SCM c1, SCM c2);
PRIMITIVE STk_chareqi (SCM c1, SCM c2);
PRIMITIVE STk_charlessi (SCM c1, SCM c2);
PRIMITIVE STk_chargti (SCM c1, SCM c2);
PRIMITIVE STk_charlessei(SCM c1, SCM c2);
PRIMITIVE STk_chargtei (SCM c1, SCM c2);
PRIMITIVE STk_char_alphap(SCM c);
PRIMITIVE STk_char_numericp(SCM c);
PRIMITIVE STk_char_whitep(SCM c);
PRIMITIVE STk_char_upperp(SCM c);
PRIMITIVE STk_char_lowerp(SCM c);
PRIMITIVE STk_char2integer(SCM c);
PRIMITIVE STk_integer2char(SCM i);
PRIMITIVE STk_char_upper(SCM c);
PRIMITIVE STk_char_lower(SCM c);
/*
------------------------------------------------------------------------------
----
---- C O N S O L E . C
----
------------------------------------------------------------------------------
*/
void STk_console_prompt(SCM env);
void STk_init_console(void);
/*
------------------------------------------------------------------------------
----
---- C O N T . C
----
------------------------------------------------------------------------------
*/
void STk_mark_continuation(SCM cont);
void STk_throw(SCM fct, SCM val);
SCM STk_do_call_cc(SCM *x);
PRIMITIVE STk_continuationp(SCM obj);
void STk_unwind_all(void);
PRIMITIVE STk_dynamic_wind(SCM thunk1, SCM thunk2, SCM thunk3);
/*
------------------------------------------------------------------------------
----
---- D U M P . C
----
------------------------------------------------------------------------------
*/
extern int STk_dumped_core;
void STk_restore_image(char *s);
PRIMITIVE STk_dump(SCM s);
/*
------------------------------------------------------------------------------
----
---- D Y N L O A D . C
----
------------------------------------------------------------------------------
*/
void STk_load_object_file(char *path);
PRIMITIVE STk_call_external(SCM l, int len);
PRIMITIVE STk_external_existsp(SCM entry_name, SCM library);
PRIMITIVE STk_cstring2string(SCM pointer);
/*
------------------------------------------------------------------------------
----
---- E N V . C
----
------------------------------------------------------------------------------
*/
SCM STk_makeframe(SCM formals, SCM actuals);
SCM STk_makeenv(SCM l, int create_if_null);
SCM *STk_value_in_env(SCM var, SCM env);
SCM *STk_varlookup(SCM x, SCM env, int err_if_unbound);
SCM STk_localvalue(SCM var, SCM env);
PRIMITIVE STk_symbol_boundp(SCM x, SCM env);
PRIMITIVE STk_the_environment(SCM args, SCM env, int len);
PRIMITIVE STk_parent_environment(SCM env);
PRIMITIVE STk_global_environment(void);
PRIMITIVE STk_environment2list(SCM env);
PRIMITIVE STk_environmentp(SCM obj);
PRIMITIVE STk_get_environment(SCM env);
/*
------------------------------------------------------------------------------
----
---- E R R O R . C
----
------------------------------------------------------------------------------
*/
#define EVAL_ERROR ((SCM) 1)
#define ERR_FATAL 0x01
#define ERR_OK 0x02
#define ERR_READ_FROM_STRING 0x04
#define ERR_IGNORED 0x08
#define ERR_TCL_BACKGROUND 0x10
#define ERR_IN_REPORT_ERROR 0x20
#define ERR_IN_LOAD 0x40
#define JMP_INIT 0
#define JMP_ERROR 1
#define JMP_THROW 2
#define JMP_RESTORE 3
#define JMP_INTERRUPT 4
struct error_handler {
jmp_buf j;
struct error_handler *prev;
int context;
SCM dynamic_handler;
};
#define PUSH_ERROR_HANDLER \
{ \
struct error_handler _local_handler; \
int _k; \
\
_local_handler.prev = STk_err_handler; \
_local_handler.context = STk_err_handler->context; \
_local_handler.dynamic_handler = NIL; \
STk_err_handler = &_local_handler; \
_k = setjmp(_local_handler.j); \
if (_k == 0) \
/* no closing brace. It will be in POP_ERROR_HANDLER */
#define WHEN_ERROR else
#define PROPAGATE_ERROR() { \
STk_err_handler = _local_handler.prev; \
longjmp(STk_err_handler->j, _k); \
}
#define POP_ERROR_HANDLER \
STk_err_handler = _local_handler.prev; \
/* close the brace opened by PUSH_ERROR_HANDLER */ \
}
extern struct error_handler *STk_err_handler;
void STk_err(char *message, SCM x);
void STk_procedure_error(char *procedure, char *message, SCM x);
#define Err STk_err
#define Serror(msg, who) STk_procedure_error(proc_name, msg, who)
/*
------------------------------------------------------------------------------
----
---- E V A L . C
----
------------------------------------------------------------------------------
*/
/* The eval flag which tells eval that it has something to do before
* evaluating the form
*/
extern int STk_eval_flag;
/* Eval stack. These are internals of the evaluator. Don't care*/
void STk_show_eval_stack(int depth, int uncode);
void STk_reset_eval_stack(void);
PRIMITIVE STk_user_get_eval_stack(void);
/* Eval hook management */
void STk_init_eval_hook(void);
void STk_reset_eval_hook(void);
PRIMITIVE STk_eval_hook(SCM x, SCM env, SCM hook);
/* Environment stack. These are internals of the evaluator. Don't care*/
PRIMITIVE STk_get_env_stack(void);
SCM STk_eval(SCM x,SCM env);
SCM STk_apply(SCM fct, SCM param);
PRIMITIVE STk_user_eval (SCM expr, SCM env);
PRIMITIVE STk_eval_string(SCM str, SCM env);
#define Apply STk_apply
#define EVAL(x) (STk_eval((x), env))
#define EVALCAR(x) (SYMBOLP(CAR(x)) ? *STk_varlookup((x),env,1):EVAL(CAR(x)))
#define add_frame(formals, actuals, env) Cons(STk_makeframe((formals), (actuals)),\
(env))
/*
------------------------------------------------------------------------------
----
---- E X T E N D . C
----
------------------------------------------------------------------------------
*/
#define EXT_ISPROC 01 /* procedure? should answer #t */
#define EXT_EVALPARAM 02 /* evaluates parameter list when apply */
/* Easy access to variables from C */
#define STk_define_variable(var, value, module) \
STk_define_public_var((module), Intern(var), (value))
#define STk_lookup_variable(var, module) \
*(STk_varlookup(Intern(var), (module), 0))
#define STk_define_scheme_variable(var, value) \
STk_define_variable((var), (value), STk_scheme_module)
#define STk_lookup_scheme_variable(var) \
STk_lookup_variable((var), STk_scheme_module)
/* Old interface for global variables. Don't use it anuymore */
#define STk_set_symbol_value(var,value) STk_define_variable((var), (value), NIL)
#define STk_get_symbol_value(var) STk_lookup_variable((var), NIL)
typedef struct {
char *type_name; /* The external name of this type */
int flags;
void (*gc_mark_fct)(SCM x);
void (*gc_sweep_fct)(SCM x);
SCM (*apply_fct)(SCM x, SCM args, SCM env);
void (*display_fct)(SCM x, SCM port, int mode);
SCM (*compare_fct)(SCM x, SCM y, int equalp);
void *Reserved[7]; /* should be sufficient for a while */
} STk_extended_scheme_type;
int STk_add_new_type(STk_extended_scheme_type *p);
void STk_add_new_primitive(char *fct_name, int fct_type, PRIMITIVE (*fct_ptr)());
SCM STk_eval_C_string(char *s, SCM env);
#define ANONYMOUS_STAT_PTR_ID 0
#define ANONYMOUS_DYN_PTR_ID 1
int STk_new_Cpointer_id(void (*display_func)(SCM x, SCM port, int mode));
SCM STk_make_Cpointer(int Cpointer_id, void *ptr, int staticp);
void STk_define_C_variable(char *var, SCM (*getter)(), void (*setter)());
/*
------------------------------------------------------------------------------
----
---- G C . C
----
------------------------------------------------------------------------------
*/
extern SCM STk_freelist;
extern long STk_alloc_cells;
extern int STk_gc_requested;
#define NEWCELL(_into,_type) \
{ \
if (STk_gc_requested || NULLP(STk_freelist)) \
STk_gc_for_newcell(); \
_into = STk_freelist; \
STk_freelist = CDR(STk_freelist); \
STk_alloc_cells += 1; \
_into->type = _type; \
}
void STk_gc_for_newcell(void);
void STk_gc_protect(SCM *location); /* protect against GC this cell */
void STk_gc_unprotect(SCM *location); /* un-protect against GC this cell */
void STk_gc_mark(SCM location); /* mark (recursively) this location */
PRIMITIVE STk_gc_stats(void); /* + */
PRIMITIVE STk_gc(void); /* + */
PRIMITIVE STk_find_cells(SCM type); /* + */
PRIMITIVE STk_expand_heap(SCM arg); /* + */
/*
------------------------------------------------------------------------------
----
---- I O . C
----
------------------------------------------------------------------------------
*/
#define MAX_FPRINTF 1000 /* Max # of char produced by 1 call to STk_fprintf */
void STk_StdinProc(void);
void STk_fill_stdin_buffer(char *s);
int STk_getc(SCM port);
int STk_ungetc(int c, SCM port);
int STk_putc(int c, SCM port);
int STk_puts(char *s, SCM port);
int STk_eof(SCM port);
int STk_internal_flush(SCM port);
int STk_internal_char_readyp(SCM port);
void STk_close(SCM port);
void STk_fprintf(SCM port, char *format, ...);
char * STk_line_bufferize_io(SCM port);
void STk_init_io(void);
#define Getc(f) (STk_getc(f))
#define Ungetc(c, f) (STk_ungetc((c), (f)))
#define Putc(c, f) (STk_putc((c), (f)))
#define Puts(s, f) (STk_puts((s), (f)))
#define Eof(f) (STk_eof(f))
#define Flush(f) (STk_internal_flush(f))
#define Fprintf STk_fprintf
/*
------------------------------------------------------------------------------
----
---- K E Y W O R D . C
----
------------------------------------------------------------------------------
*/
void STk_initialize_keyword_table(void);
void STk_free_keyword(SCM keyword);
SCM STk_makekey(char *token);
PRIMITIVE STk_make_keyword(SCM str);
PRIMITIVE STk_keywordp(SCM obj);
PRIMITIVE STk_keyword2string(SCM obj);
PRIMITIVE STk_get_keyword(SCM key, SCM l, SCM default_value);
/*
------------------------------------------------------------------------------
----
---- L I S T . C
----
------------------------------------------------------------------------------
*/
int STk_llength(SCM l); /* length of a list. -1 if not a proper list */
SCM STk_append2(SCM l1, SCM l2); /* append with only two lists */
SCM STk_dappend2(SCM l1, SCM l2); /* the same one but destructive this time */
PRIMITIVE STk_pairp(SCM x);
PRIMITIVE STk_cons(SCM x, SCM y);
PRIMITIVE STk_car(SCM x);
PRIMITIVE STk_cdr(SCM x);
PRIMITIVE STk_setcar(SCM cell, SCM value);
PRIMITIVE STk_setcdr(SCM cell, SCM value);
PRIMITIVE STk_caar (SCM l);
PRIMITIVE STk_cdar (SCM l);
PRIMITIVE STk_cadr (SCM l);
PRIMITIVE STk_cddr (SCM l);
PRIMITIVE STk_caaar (SCM l);
PRIMITIVE STk_cdaar (SCM l);
PRIMITIVE STk_cadar (SCM l);
PRIMITIVE STk_cddar (SCM l);
PRIMITIVE STk_caadr (SCM l);
PRIMITIVE STk_cdadr (SCM l);
PRIMITIVE STk_caddr (SCM l);
PRIMITIVE STk_cdddr (SCM l);
PRIMITIVE STk_caaaar(SCM l);
PRIMITIVE STk_cdaaar(SCM l);
PRIMITIVE STk_cadaar(SCM l);
PRIMITIVE STk_cddaar(SCM l);
PRIMITIVE STk_caadar(SCM l);
PRIMITIVE STk_cdadar(SCM l);
PRIMITIVE STk_caddar(SCM l);
PRIMITIVE STk_cdddar(SCM l);
PRIMITIVE STk_caaadr(SCM l);
PRIMITIVE STk_cdaadr(SCM l);
PRIMITIVE STk_cadadr(SCM l);
PRIMITIVE STk_cddadr(SCM l);
PRIMITIVE STk_caaddr(SCM l);
PRIMITIVE STk_cdaddr(SCM l);
PRIMITIVE STk_cadddr(SCM l);
PRIMITIVE STk_cddddr(SCM l);
PRIMITIVE STk_nullp (SCM x);
PRIMITIVE STk_listp (SCM x);
PRIMITIVE STk_list (SCM l, int len);
PRIMITIVE STk_list_length(SCM l);
PRIMITIVE STk_append(SCM l, int len);
PRIMITIVE STk_reverse(SCM l);
PRIMITIVE STk_list_tail(SCM list, SCM k);
PRIMITIVE STk_list_ref(SCM list, SCM k);
PRIMITIVE STk_memq (SCM obj, SCM list);
PRIMITIVE STk_memv (SCM obj, SCM list);
PRIMITIVE STk_member(SCM obj, SCM list);
PRIMITIVE STk_assq (SCM obj, SCM alist);
PRIMITIVE STk_assv (SCM obj, SCM alist);
PRIMITIVE STk_assoc (SCM obj, SCM alist);
PRIMITIVE STk_liststar(SCM l, int len); /* + */
PRIMITIVE STk_copy_tree(SCM l); /* + */
PRIMITIVE STk_last_pair(SCM l); /* + */
PRIMITIVE STk_remq (SCM obj, SCM list); /* + */
PRIMITIVE STk_remv (SCM obj, SCM list); /* + */
PRIMITIVE STk_remove (SCM obj, SCM list); /* + */
PRIMITIVE STk_dappend(SCM l, int len); /* + */
#define Cons STk_cons
#define Reverse STk_reverse
#define LIST1(a) Cons((a), NIL)
#define LIST2(a,b) Cons((a), LIST1(b))
#define LIST3(a,b,c) Cons((a), LIST2((b),(c)))
#define LIST4(a,b,c,d) Cons((a), LIST3((b),(c),(d)))
#define LIST5(a,b,c,d,e) Cons((a), LIST4((b),(c),(d),(e)))
#define LIST6(a,b,c,d,e,f) Cons((a), LIST5((b),(c),(d),(e),(f)))
#define LIST7(a,b,c,d,e,f,g) Cons((a), LIST6((b),(c),(d),(e),(f),(g)))
#define LIST8(a,b,c,d,e,f,g,h) Cons((a), LIST7((b),(c),(d),(e),(f),(g),(h)))
/*
------------------------------------------------------------------------------
----
---- M A C R O . C
----
------------------------------------------------------------------------------
*/
PRIMITIVE STk_macro(SCM args, SCM env, int len); /* + */
PRIMITIVE STk_macro_expand(SCM form, SCM env, int len); /* + */
PRIMITIVE STk_macro_expand_1(SCM form, SCM env, int len); /* + */
PRIMITIVE STk_macro_body(SCM form); /* + */
PRIMITIVE STk_macrop(SCM obj); /* + */
PRIMITIVE STk_macro_R5(SCM args, SCM env, int len); /* Undoc */
/*
------------------------------------------------------------------------------
----
---- M O D U L E . C
----
------------------------------------------------------------------------------
*/
extern SCM STk_global_module; /* Global module -- i.e STk pseudo-module */
extern SCM STk_scheme_module; /* The Scheme module */
extern SCM STk_selected_module; /* Selected module */
SCM STk_make_module(SCM name);
SCM STk_make_parent_module(SCM module);
void STk_mark_module(SCM m);
void STk_free_module(SCM m);
void STk_mark_module_table(void);
void STk_define_public_var(SCM module, SCM var, SCM value);
SCM* STk_module_lookup(SCM module, SCM var, SCM context);
SCM STk_modulevalue(SCM obj);
SCM STk_module_env2list(SCM module);
void STk_select_stk_module(void);
void STk_initialize_stk_module(void);
void STk_init_modules(void);
PRIMITIVE STk_define_module(SCM l, SCM env, int len);
PRIMITIVE STk_modulep(SCM obj);
PRIMITIVE STk_with_module(SCM l, SCM env, int len);
PRIMITIVE STk_import(SCM l, SCM env, int len);
PRIMITIVE STk_export_symbol(SCM symbol, SCM module);
PRIMITIVE STk_export_all_symbols(void);
PRIMITIVE STk_select_module(SCM l, SCM env, int len);
PRIMITIVE STk_get_module(SCM env);
PRIMITIVE STk_current_module(SCM l, SCM env, int len);
PRIMITIVE STk_find_module(SCM name, SCM default_value);
PRIMITIVE STk_module_name(SCM module);
PRIMITIVE STk_module_imports(SCM module);
PRIMITIVE STk_module_exports(SCM module);
PRIMITIVE STk_module_env(SCM module);
PRIMITIVE STk_module_symbols(SCM module);
PRIMITIVE STk_get_selected_module(void);
/*
------------------------------------------------------------------------------
----
---- N U M B E R . C
----
------------------------------------------------------------------------------
*/
#ifdef COMPACT_SMALL_CST
# define SMALLINT_MAX (LONG_MAX>>8)
#else
# define SMALLINT_MAX LONG_MAX
#endif
#define SMALLINT_MIN (-SMALLINT_MAX)
char *STk_number2Cstr(SCM n, long base, char buffer[]);
SCM STk_Cstr2number(char *str, long base);
SCM STk_makenumber(double x);
SCM STk_makeinteger(long x);
SCM STk_makeunsigned(unsigned long x);
long STk_integer_value(SCM x); /* Returns LONG_MIN if not representable as int */
long STk_integer_value_no_overflow(SCM x); /* Returns LONG_MIN if not an int */
int STk_equal_numbers(SCM number1, SCM number2); /* number1 = number2 */
long STk_integer2long(SCM x);
unsigned long STk_integer2ulong(SCM x);
#define STk_real2double(x) FLONM(x)
PRIMITIVE STk_numberp(SCM x);
PRIMITIVE STk_integerp(SCM x);
PRIMITIVE STk_exactp(SCM x);
PRIMITIVE STk_inexactp(SCM x);
PRIMITIVE STk_numequal(SCM l, SCM env, int from_eval);
PRIMITIVE STk_lessp(SCM l, SCM env, int from_eval);
PRIMITIVE STk_greaterp(SCM l, SCM env, int from_eval);
PRIMITIVE STk_lessep(SCM l, SCM env, int from_eval);
PRIMITIVE STk_greaterep(SCM l, SCM env, int from_eval);
PRIMITIVE STk_zerop(SCM n);
PRIMITIVE STk_positivep(SCM n);
PRIMITIVE STk_negativep(SCM n);
PRIMITIVE STk_oddp(SCM n);
PRIMITIVE STk_evenp(SCM n);
PRIMITIVE STk_max(SCM l, SCM env, int from_eval);
PRIMITIVE STk_min(SCM l, SCM env, int from_eval);
PRIMITIVE STk_plus(SCM l, SCM env, int from_eval);
PRIMITIVE STk_difference(SCM l, SCM env, int from_eval);
PRIMITIVE STk_times(SCM l, SCM env, int from_eval);
PRIMITIVE STk_division(SCM l, SCM env, int from_eval);
PRIMITIVE STk_absolute(SCM x);
PRIMITIVE STk_quotient(SCM n1, SCM n2);
PRIMITIVE STk_remainder(SCM n1, SCM n2);
PRIMITIVE STk_modulo(SCM n1, SCM n2);
PRIMITIVE STk_gcd(SCM l, SCM env, int from_eval);
PRIMITIVE STk_lcm(SCM l, SCM env, int from_eval);
PRIMITIVE STk_floor(SCM x);
PRIMITIVE STk_ceiling(SCM x);
PRIMITIVE STk_truncate(SCM x);
PRIMITIVE STk_round(SCM x);
PRIMITIVE STk_exp(SCM z);
PRIMITIVE STk_log(SCM z);
PRIMITIVE STk_sin(SCM z);
PRIMITIVE STk_cos(SCM z);
PRIMITIVE STk_tan(SCM z);
PRIMITIVE STk_asin(SCM z);
PRIMITIVE STk_acos(SCM z);
PRIMITIVE STk_atan(SCM y, SCM x);
PRIMITIVE STk_sqrt(SCM z);
PRIMITIVE STk_expt(SCM z1, SCM z2);
PRIMITIVE STk_exact2inexact(SCM z);
PRIMITIVE STk_inexact2exact(SCM z);
PRIMITIVE STk_string2number(SCM str, SCM base);
PRIMITIVE STk_number2string(SCM n, SCM base);
PRIMITIVE STk_bignump(SCM n);
/*
------------------------------------------------------------------------------
----
---- P O R T . C
----
------------------------------------------------------------------------------
*/
struct port_descr { /* Slot order is important (see sport_descr) */
FILE *file;
int flags;
char *filename;
SCM read_event;
SCM write_event;
};
#define PORT_FILE(x) ((x)->storage_as.port.p->file)
#define PORT_UNGETC(x) ((x)->storage_as.port.ungetted_char)
#define PORT_NAME(x) ((x)->storage_as.port.p->filename)
#define PORT_FLAGS(x) ((x)->storage_as.port.p->flags)
#define PORT_REVENT(x) ((x)->storage_as.port.p->read_event)
#define PORT_WEVENT(x) ((x)->storage_as.port.p->write_event)
#define PORT_CLOSED 01
#define PIPE_PORT 02
#define OUTP(p) (OPORTP(p) || OSPORTP(p) || OVPORTP(p))
#define INP(p) (IPORTP(p) || ISPORTP(p) || IVPORTP(p))
#define F_READ 01
#define F_WRITE 02
/* external vars */
extern SCM STk_curr_iport, STk_curr_oport, STk_curr_eport, STk_eof_object;
void STk_close_file_port(SCM port);
void STk_freeport(SCM port);
void STk_init_standard_ports(void);
SCM STk_load_file(char *fname, int err_if_absent, SCM module);
SCM STk_Cfile2port(char *name, FILE *f, int type, int flags);
SCM STk_redirect_input(SCM port, SCM thunk);
SCM STk_redirect_output(SCM port, SCM thunk);
SCM STk_redirect_error(SCM port, SCM thunk);
PRIMITIVE STk_input_portp(SCM port);
PRIMITIVE STk_output_portp(SCM port);
PRIMITIVE STk_current_input_port(void);
PRIMITIVE STk_current_output_port(void);
PRIMITIVE STk_current_error_port(void);
PRIMITIVE STk_with_input_from_file(SCM string, SCM thunk);
PRIMITIVE STk_with_output_to_file(SCM string, SCM thunk);
PRIMITIVE STk_open_input_file(SCM filename);
PRIMITIVE STk_open_output_file(SCM filename);
PRIMITIVE STk_close_input_port(SCM port);
PRIMITIVE STk_close_output_port(SCM port);
PRIMITIVE STk_read(SCM port);
PRIMITIVE STk_read_char(SCM port);
PRIMITIVE STk_peek_char(SCM port);
PRIMITIVE STk_eof_objectp(SCM obj);
PRIMITIVE STk_char_readyp(SCM port);
PRIMITIVE STk_write(SCM expr, SCM port);
PRIMITIVE STk_display(SCM expr, SCM port);
PRIMITIVE STk_newline(SCM port);
PRIMITIVE STk_write_char(SCM c, SCM port);
PRIMITIVE STk_load(SCM filename, SCM module);
/* Non standard functions */
PRIMITIVE STk_with_error_to_file(SCM string, SCM thunk);
PRIMITIVE STk_with_input_from_port(SCM port, SCM thunk);
PRIMITIVE STk_with_output_to_port(SCM port, SCM thunk);
PRIMITIVE STk_with_error_to_port(SCM port, SCM thunk);
PRIMITIVE STk_format(SCM l, int len);
PRIMITIVE STk_error(SCM l, int len);
PRIMITIVE STk_try_load(SCM filename, SCM module);
PRIMITIVE STk_open_file(SCM filename, SCM mode);
PRIMITIVE STk_close_port(SCM port);
PRIMITIVE STk_read_line(SCM port);
PRIMITIVE STk_copy_port(SCM in, SCM out);
PRIMITIVE STk_flush(SCM porSTk_t);
PRIMITIVE STk_write_star(SCM expr, SCM port);
void STk_do_autoload(SCM var, SCM autoload);
PRIMITIVE STk_autoload(SCM l, SCM env, int len);
PRIMITIVE STk_autoloadp(SCM symbol, SCM module);
PRIMITIVE STk_when_port_readable(SCM port, SCM closure);
PRIMITIVE STk_when_port_writable(SCM port, SCM closure);
PRIMITIVE STk_change_standard_ports(SCM in, SCM out, SCM err); /* Undoc */
/*
------------------------------------------------------------------------------
----
---- P R I M I T I V E S . C
----
------------------------------------------------------------------------------
*/
void STk_init_primitives(void);
/*
------------------------------------------------------------------------------
----
---- P R I N T . C
----
------------------------------------------------------------------------------
*/
#define DSP_MODE 0x1
#define WRT_MODE 0x2
#define TK_MODE 0x4 /* Always defined even if no Tk support */
#define PANIC_MODE 0x8 /* Printing in "panic" mode (i.e. don't cons) */
SCM STk_print(SCM exp, SCM port, int mode);
SCM STk_print_star(SCM exp, SCM port);
/*
------------------------------------------------------------------------------
----
---- P R O C . C
----
------------------------------------------------------------------------------
*/
int STk_is_thunk(SCM obj);
SCM STk_makeclosure(SCM code, SCM env);
PRIMITIVE STk_procedurep(SCM obj);
PRIMITIVE STk_map(SCM l, int len);
PRIMITIVE STk_for_each(SCM l, int len);
PRIMITIVE STk_procedure_body(SCM proc);
PRIMITIVE STk_procedure_environment(SCM proc);
PRIMITIVE STk_procedure_arity(SCM proc);
/*
------------------------------------------------------------------------------
----
---- P R O M I S E . C
----
------------------------------------------------------------------------------
*/
PRIMITIVE STk_force(SCM promise);
PRIMITIVE STk_promisep(SCM promise);
/*
------------------------------------------------------------------------------
----
---- R E A D . C
----
------------------------------------------------------------------------------
*/
SCM STk_readf(SCM port, int case_significant);
/*
------------------------------------------------------------------------------
----
---- S I G N A L . C
----
------------------------------------------------------------------------------
*/
#define MAX_SYSTEM_SIG 32 /* True for all systems? */
#define SIGHADGC MAX_SYSTEM_SIG /* End of a GC run */
#define MAX_SIGNAL (MAX_SYSTEM_SIG+1)
extern int STk_control_C;
void STk_handle_signal(int sig);
void STk_handle_sigint_signal(void);
PRIMITIVE STk_add_signal_handler(SCM sig, SCM proc);
PRIMITIVE STk_set_signal_handler(SCM sig, SCM proc);
PRIMITIVE STk_get_signal_handlers(SCM sig);
PRIMITIVE STk_send_signal(SCM sig);
void STk_init_signal(void);
void STk_mark_signal_table(void);
void STk_ignore_signals(void); /* Block all signals */
void STk_allow_signals(void); /* Restore signals as before block_signals */
void STk_signal_GC(void);
/*
------------------------------------------------------------------------------
----
---- S L I B . C
----
------------------------------------------------------------------------------
*/
#ifndef _DEBUG_MALLOC_INC
void *STk_must_malloc(size_t size);
void *STk_must_realloc(void *ptr, size_t size);
#endif
double STk_my_time(void);
SCM STk_internal_eval_string(char *s, long err_code, SCM env);
PRIMITIVE STk_catch(SCM expr, SCM env, int len);
PRIMITIVE STk_quit_interpreter(SCM retcode);
PRIMITIVE STk_version(void);
PRIMITIVE STk_machine_type(void);
PRIMITIVE STk_library_location(void);
PRIMITIVE STk_random(SCM n);
PRIMITIVE STk_set_random_seed(SCM n);
PRIMITIVE STk_get_internal_info(void);
PRIMITIVE STk_time(SCM expr, SCM env, int len);
PRIMITIVE STk_global_set(SCM var, SCM value);
PRIMITIVE STk_uncode(SCM expr);
#ifdef SIGSEGV
PRIMITIVE STk_default_SIGSEGV_handler(void);
#endif
void STk_delete_Tcl_child_Interp(void);
#define must_malloc STk_must_malloc
#define must_realloc STk_must_realloc
/*
------------------------------------------------------------------------------
----
---- S P O R T . C
----
------------------------------------------------------------------------------
*/
struct sport_descr { /* Slot order is important (see port_descr) */
FILE *file;
int flags;
};
SCM STk_internal_open_input_string(char *s);
void STk_free_string_port(SCM port);
SCM STk_internal_read_from_string(SCM port, int *eof, int case_significant);
PRIMITIVE STk_open_input_string(SCM s);
PRIMITIVE STk_open_output_string(void);
PRIMITIVE STk_get_output_string(SCM port);
PRIMITIVE STk_input_string_portp(SCM port);
PRIMITIVE STk_output_string_portp(SCM port);
PRIMITIVE STk_with_input_from_string(SCM string, SCM thunk);
PRIMITIVE STk_with_output_to_string(SCM thunk);
PRIMITIVE STk_with_error_to_string(SCM thunk);
PRIMITIVE STk_read_from_string(SCM str);
/*
------------------------------------------------------------------------------
----
---- S T K L O S . C
----
------------------------------------------------------------------------------
*/
#ifdef USE_STKLOS
PRIMITIVE STk_init_STklos(void);
#endif
/*
------------------------------------------------------------------------------
----
---- S T R I N G . C
----
------------------------------------------------------------------------------
*/
SCM STk_makestrg(int len, char *init);
SCM STk_embed_C_string(char *str);
PRIMITIVE STk_stringp(SCM obj);
PRIMITIVE STk_make_string(SCM len, SCM init_char);
PRIMITIVE STk_lstring(SCM l, int len);
PRIMITIVE STk_string_length(SCM str);
PRIMITIVE STk_string_ref(SCM str, SCM index);
PRIMITIVE STk_string_set(SCM str, SCM index, SCM value);
PRIMITIVE STk_streq (SCM s1, SCM s2);
PRIMITIVE STk_strless (SCM s1, SCM s2);
PRIMITIVE STk_strgt (SCM s1, SCM s2);
PRIMITIVE STk_strlesse(SCM s1, SCM s2);
PRIMITIVE STk_strgte (SCM s1, SCM s2);
PRIMITIVE STk_streqi (SCM s1, SCM s2);
PRIMITIVE STk_strlessi (SCM s1, SCM s2);
PRIMITIVE STk_strgti (SCM s1, SCM s2);
PRIMITIVE STk_strlessei(SCM s1, SCM s2);
PRIMITIVE STk_strgtei (SCM s1, SCM s2);
PRIMITIVE STk_substring(SCM string, SCM start, SCM end);
PRIMITIVE STk_string_append(SCM l, int len);
PRIMITIVE STk_string2list(SCM str);
PRIMITIVE STk_list2string(SCM l);
PRIMITIVE STk_string_copy(SCM str);
PRIMITIVE STk_string_fill(SCM str, SCM c);
PRIMITIVE STk_string_findp(SCM s1, SCM s2); /* + */
PRIMITIVE STk_string_index(SCM s1, SCM s2); /* + */
PRIMITIVE STk_string_lower(SCM s); /* + */
PRIMITIVE STk_string_upper(SCM s); /* + */
PRIMITIVE STk_split_string(SCM string, SCM delimiters); /* + */
#define STk_makestring(s) STk_makestrg((int) strlen(s), (s))
/*
------------------------------------------------------------------------------
----
---- S Y M B O L . C
----
------------------------------------------------------------------------------
*/
void STk_initialize_symbol_table(void);
void STk_mark_symbol_table(void);
void STk_free_symbol(SCM symbol);
SCM STk_global_env2list(void);
SCM STk_global_symbols(void);
SCM STk_intern(char *name);
PRIMITIVE STk_symbolp(SCM x);
PRIMITIVE STk_symbol2string(SCM symbol);
PRIMITIVE STk_string2symbol(SCM string);
#define Intern STk_intern
/*
------------------------------------------------------------------------------
----
---- S Y N T A X . C
----
------------------------------------------------------------------------------
*/
PRIMITIVE STk_syntax_quote (SCM *pform, SCM env, int len);
PRIMITIVE STk_syntax_lambda (SCM *pform, SCM env, int len);
PRIMITIVE STk_syntax_if (SCM *pform, SCM env, int len);
PRIMITIVE STk_syntax_setq (SCM *pform, SCM env, int len);
PRIMITIVE STk_syntax_cond (SCM *pform, SCM env, int len);
PRIMITIVE STk_syntax_and (SCM *pform, SCM env, int len);
PRIMITIVE STk_syntax_or (SCM *pform, SCM env, int len);
PRIMITIVE STk_syntax_let (SCM *pform, SCM env, int len);
PRIMITIVE STk_syntax_letstar (SCM *pform, SCM env, int len);
PRIMITIVE STk_syntax_letrec (SCM *pform, SCM env, int len);
PRIMITIVE STk_syntax_begin (SCM *pform, SCM env, int len);
PRIMITIVE STk_syntax_delay (SCM *pform, SCM env, int len);
PRIMITIVE STk_syntax_quasiquote(SCM *pform, SCM env, int len);
PRIMITIVE STk_syntax_define (SCM *pform, SCM env, int len);
PRIMITIVE STk_while(SCM l, SCM env, int len);
PRIMITIVE STk_until(SCM l, SCM env, int len);
PRIMITIVE STk_syntax_extend_env(SCM *pform, SCM env, int len);
/*
------------------------------------------------------------------------------
----
---- T C L - L I B . C
----
------------------------------------------------------------------------------
*/
int STk_internal_Tcl_DeleteCommand(Tcl_Interp *interp, char *cmdName);
/*
------------------------------------------------------------------------------
----
---- T O P L E V E L . C
----
------------------------------------------------------------------------------
*/
void STk_toplevel(int argc, char **argv);
/*
------------------------------------------------------------------------------
----
---- T R A C E . C
----
------------------------------------------------------------------------------
*/
void STk_change_value (SCM var, SCM env);
void STk_mark_tracevar_table(void);
PRIMITIVE STk_trace_var (SCM var, SCM code);
PRIMITIVE STk_untrace_var (SCM var);
void STk_init_tracevar (void);
/*
------------------------------------------------------------------------------
----
---- U N I X . C
----
------------------------------------------------------------------------------
*/
#ifndef WIN32
# define ISDIRSEP(ch) ((ch)=='/')
# define ISABSOLUTE(cp) (ISDIRSEP(*cp))
# define DIRSEP '/'
# define SDIRSEP "/"
# define PATHSEP ':'
#else
# define ISDIRSEP(ch) ((ch)=='\\' || (ch)=='/')
# define ISABSOLUTE(cp) (ISDIRSEP(*cp) || \
((strlen(cp)>=3) && isalpha(*cp) &&(cp[1]==':') && \
ISDIRSEP(cp[2])))
# define DIRSEP '\\'
# define SDIRSEP "\\"
# define PATHSEP ';'
#endif
void STk_whence(char *exec, char *path);
SCM STk_internal_expand_file_name(char *s);
SCM STk_resolve_link(char *path, int count);
int STk_dirp(const char *path);
PRIMITIVE STk_expand_file_name(SCM s);
PRIMITIVE STk_canonical_path(SCM str);
PRIMITIVE STk_getcwd(void);
PRIMITIVE STk_chdir(SCM s);
PRIMITIVE STk_getpid(void);
PRIMITIVE STk_system(SCM com);
PRIMITIVE STk_getenv(SCM str);
PRIMITIVE STk_setenv(SCM var, SCM value);
PRIMITIVE STk_file_is_directoryp(SCM f);
PRIMITIVE STk_file_is_regularp(SCM f);
PRIMITIVE STk_file_is_readablep(SCM f);
PRIMITIVE STk_file_is_writablep(SCM f);
PRIMITIVE STk_file_is_executablep(SCM f);
PRIMITIVE STk_file_existp(SCM f);
PRIMITIVE STk_file_glob(SCM l, int len);
PRIMITIVE STk_remove_file(SCM filename);
PRIMITIVE STk_rename_file(SCM filename1, SCM filename2);
PRIMITIVE STk_temporary_file_name(void);
/*
------------------------------------------------------------------------------
----
---- V A L U E S . C
----
------------------------------------------------------------------------------
*/
PRIMITIVE STk_values(SCM l, int len);
PRIMITIVE STk_call_with_values(SCM producer, SCM consumer);
/*
------------------------------------------------------------------------------
----
---- V E C T O R . C
----
------------------------------------------------------------------------------
*/
SCM STk_makevect(int len, SCM init);
PRIMITIVE STk_vectorp(SCM obj);
PRIMITIVE STk_make_vector(SCM len, SCM init);
PRIMITIVE STk_vector(SCM l, int len);
PRIMITIVE STk_vector_length(SCM v);
PRIMITIVE STk_vector_ref(SCM v, SCM index);
PRIMITIVE STk_vector_set(SCM v, SCM index, SCM value);
PRIMITIVE STk_vector2list(SCM v);
PRIMITIVE STk_list2vector(SCM l);
PRIMITIVE STk_vector_fill(SCM v, SCM fill);
PRIMITIVE STk_vector_copy(SCM vect);
PRIMITIVE STk_vector_resize(SCM vect, SCM size);
PRIMITIVE STk_sort(SCM obj, SCM test);
/*
------------------------------------------------------------------------------
----
---- V P O R T . C
----
------------------------------------------------------------------------------
*/
struct vport_descr { /* Slot order is important (see port_descr) */
FILE *file; /* structure is (for now) identical to str ports */
int flags;
};
void STk_mark_virtual_port(SCM port);
void STk_free_virtual_port(SCM port);
PRIMITIVE STk_open_input_virtual(SCM l, int len);
PRIMITIVE STk_open_output_virtual(SCM l, int len);
PRIMITIVE STk_input_virtual_portp(SCM port);
PRIMITIVE STk_output_virtual_portp(SCM port);
/*
------------------------------------------------------------------------------
----
---- U S E R I N I T . C
----
------------------------------------------------------------------------------
*/
void STk_user_init(void);
void STk_user_cleanup(void);
/*
------------------------------------------------------------------------------
----
---- G L O B A L V A R I A B L E S
----
------------------------------------------------------------------------------
*/
#ifdef STK_MAIN
# define Extern
#else
# define Extern extern
#endif
/* Remember if we are running the stk or snow interpreter */
Extern int STk_snow_is_running;
/* Program name (expanded) */
Extern char STk_Argv0[MAX_PATH_LENGTH];
/* Is it an intearctive interpreter? */
Extern int STk_interactivep;
/* Scheme booleans #t and #f */
Extern SCM STk_truth, STk_ntruth;
/* Scheme () and the undefined value */
Extern SCM STk_nil, STk_undefined, STk_unbound;
/* read buffer */
Extern char *STk_tkbuffer;
Extern int STk_line_counter;
Extern SCM STk_current_filename;
/* Special symbols */
Extern SCM STk_sym_lambda, STk_sym_quote,STk_sym_dot, STk_sym_imply,
STk_sym_debug, STk_sym_else, STk_sym_quasiquote,
STk_sym_unquote, STk_sym_unquote_splicing, STk_sym_break;
/* Global environment */
Extern SCM STk_globenv;
/* Library location */
Extern char *STk_library_path;
/* Is the interpreter safe. Of course not!!! */
Extern int STk_is_safe;
/* The last variable defined with a DEFINE */
Extern SCM STk_last_defined;
/* Standard input/output/error ports */
Extern SCM STk_stdin, STk_stdout, STk_stderr;
#undef Extern
#define Truth STk_truth
#define Ntruth STk_ntruth
#define NIL STk_nil
#define UNBOUND STk_unbound
#define UNDEFINED STk_undefined
#define Sym_lambda STk_sym_lambda
#define Sym_quote STk_sym_quote
#define Sym_dot STk_sym_dot
#define Sym_imply STk_sym_imply
#define Sym_debug STk_sym_debug
#define Sym_else STk_sym_else
#define Sym_quasiquote STk_sym_quasiquote
#define Sym_unquote STk_sym_unquote
#define Sym_unq_splicing STk_sym_unquote_splicing
#define Sym_break STk_sym_break
#ifdef USE_TK
/*
------------------------------------------------------------------------------
----
---- T K - G L U E . C
----
------------------------------------------------------------------------------
*/
#include "tk-glue.h"
/*
------------------------------------------------------------------------------
----
---- T K - U T I L . C
----
------------------------------------------------------------------------------
*/
PRIMITIVE STk_string2widget(SCM str);
PRIMITIVE STk_widget2string(SCM widget);
PRIMITIVE STk_tk_commandp(SCM obj);
PRIMITIVE STk_widget_name(SCM obj);
PRIMITIVE STk_get_widget_data(SCM widget);
PRIMITIVE STk_set_widget_data(SCM widget, SCM value);
PRIMITIVE STk_widget_environment(SCM widget);
/*
------------------------------------------------------------------------------
----
---- T K - M A I N . C
----
------------------------------------------------------------------------------
*/
extern Tcl_Interp *STk_main_interp; /* Interpreter for this application. */
extern SCM STk_Tk_module; /* The Tk module */
extern int Tk_initialized ; /* 1 when Tk is fully initialized */
void Tk_main(int synchronize, char *name, char *fileName, char *Xdisplay,
char *geometry);
/*
------------------------------------------------------------------------------
----
---- BACKWARD COMPATIBILITY STUFF
----
---- Don't use these definitions
------------------------------------------------------------------------------
*/
#define err STk_err
#define STk_scheme_load(file) STk_load(file, UNBOUND)
#define STk_loadfile(file,err) STk_load_file(file, NIL, err)
#define CLOSURE_PARAMETERS CLOSPARAMS
#endif /* USE_TK */
/*
------------------------------------------------------------------------------
----
---- MISC
----
------------------------------------------------------------------------------
*/
#define ENTER_PRIMITIVE(name) static char* proc_name = name;
#define ENTER_SCM(name) ENTER_PRIMITIVE(name)
#ifdef DEBUG_STK
void Debug(char *message, SCM obj);
#else
#define Debug(message, obj)
#endif
#ifdef __cplusplus
};
#endif
#endif /* ifndef _STK_H */