/*****************************************************************-*- C -*-**** * * s t k . h * * 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: 12-May-1993 10:34 * Last file update: 4-Sep-1999 12:38 (eg) * ******************************************************************************/ #ifndef _STK_H #define _STK_H #include #ifdef WIN32 # define MACHINE "Ms-Win32" # include /* for the panic procedure */ #endif #include #ifdef __cplusplus extern "C" { #endif #include #include #include #include #include #include #include #include #ifndef WIN32 # include #endif #ifdef HAVE_UNISTD_H # include #endif #include #include #ifdef WIN32 # 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 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 #include /* ------------------------------------------------------------------------------ */ #define COMPACT_SMALL_CST /* compact coding for small const */ #ifndef FALSE # define FALSE 0 #endif #ifndef TRUE # define TRUE (!FALSE) #endif #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 # 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 */ 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))) #define CELLINFO(x) ((*x).cell_info) #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 CELL_INFO_UNINTERNED 04 /* Symbol is not interned */ #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 ---- ------------------------------------------------------------------------------ */ #if defined(WIN32) && defined(USE_DYNLOAD) && defined(MSC_VER) # ifdef EXPORT_DLL_GLOBALS # define extern __declspec( dllexport ) # else # ifdef IMPORT_DLL_GLOBALS # define extern __declspec( dllimport ) # else # define extern extern # endif # endif #endif #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); PRIMITIVE STk_string2usymbol(SCM string); /* ------------------------------------------------------------------------------ ---- ---- 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); SCM STk_apply0(SCM fct); SCM STk_apply1(SCM fct, SCM param); SCM STk_apply2(SCM fct, SCM param1, SCM param2); PRIMITIVE STk_user_eval (SCM expr, SCM env); PRIMITIVE STk_eval_string(SCM str, SCM env); #define EVAL(x) (STk_eval((x), env)) #define EVALCAR(x) (SYMBOLP(CAR(x)) ? *STk_varlookup((x),env,1):EVAL(CAR(x))) #define Apply STk_apply #define Apply0 STk_apply0 #define Apply1 STk_apply1 #define Apply2 STk_apply2 #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); PRIMITIVE STk_all_modules(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_input_file_portp(SCM port); PRIMITIVE STk_output_file_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_port_closedp(SCM expr); 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 ---- ------------------------------------------------------------------------------ */ #if defined(WIN32) && defined(USE_DYNLOAD) && defined(MSC_VER) # ifdef EXPORT_DLL_GLOBALS # define Extern __declspec( dllexport ) # include # else # ifdef IMPORT_DLL_GLOBALS # define Extern __declspec( dllimport ) # else # define Extern extern # endif # endif #else /* Unix */ # ifdef STK_MAIN # define Extern # else # define Extern extern # endif #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 #if defined(WIN32) && defined(USE_DYNLOAD) && defined(MSC_VER) # undef extern #endif #endif /* ifndef _STK_H */