/* * stklos.h -- stklos.h * * Copyright © 1999-2011 Erick Gallesio - I3S-CNRS/ESSI * * * This program is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by * the Free Software Foundation; either version 2 of the License, or * (at your option) any later version. * * This program is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * * You should have received a copy of the GNU General Public License * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, * USA. * * Author: Erick Gallesio [eg@unice.fr] * Creation date: 28-Dec-1999 22:58 (eg) * Last file update: 9-Sep-2011 15:37 (eg) */ #ifndef STKLOS_H #define STKLOS_H #ifdef __cplusplus extern "C" { #endif #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include "stklosconf.h" #include "extraconf.h" /* To debug the GC uncomment the following line */ /* #define GC_DEBUG 1*/ #ifdef HAVE_GC # include #else # include #endif #ifndef THEADS_NONE # include #endif /*===========================================================================*\ * * Declaration of some constants (mainly maxima) * \*===========================================================================*/ #ifndef FALSE # define FALSE 0 #endif #ifndef TRUE # define TRUE (!FALSE) #endif #ifdef _POSIX_PATH_MAX # define MAX_PATH_LENGTH _POSIX_PATH_MAX #else # define MAX_PATH_LENGTH 256 #endif #define MAX_TOKEN_SIZE 1024 /* max size of a token */ #define CPP_CONCAT(x, y) x##y #define Inline inline #define AS_LONG(x) ((unsigned long) (x)) #define AS_SCM(x) ((SCM) ((unsigned long) (x))) /*===========================================================================*\ * * Threads stuff * \*===========================================================================*/ #ifdef THREADS_NONE # define MUT_DECL(lck) # define MUT_LOCK(lck) # define MUT_UNLOCK(lck) #else # define MUT_DECL(lck) static pthread_mutex_t lck = PTHREAD_MUTEX_INITIALIZER; # define MUT_LOCK(lck) { pthread_mutex_lock(&lck); } # define MUT_UNLOCK(lck) { pthread_mutex_unlock(&lck); } #endif /*===========================================================================*\ * * Memory allocation * \*===========================================================================*/ /* * This code is an excerpt of the function used in Boehm GC (i.e. all the * functions of the GC used in the interpreter must be declared here since * the file is not included in the source file in order to simplify * header file management (i.e. only this header file is necessary to use * the stklos library. * Don't use the functions GC_* they can be changed. The only allocation * functions that must be used are functions of the form STk_* */ /* GC interface. *** DON'T USE IT DIRECTLY *** */ // // #define GC_API extern // // typedef void (*GC_finalization_proc) (void * obj, void * client_data); // // GC_API void * GC_malloc(size_t size_in_bytes); // GC_API void * GC_malloc_atomic(size_t size_in_bytes); // GC_API void * GC_realloc(void * old_object, size_t new_size_in_bytes); // GC_API void GC_free(void * object_addr); // // GC_API void GC_register_finalizer(void * obj, GC_finalization_proc fn, // void * cd, GC_finalization_proc *ofn, // void * *ocd); // // GC_API void GC_gcollect(void); // GC_API void GC_init(void); /* Scheme interface. *** THIS IS THE INTERFACE TO USE *** */ #define STk_must_malloc(size) GC_MALLOC(size) #define STk_must_malloc_atomic(size) GC_MALLOC_ATOMIC(size) #define STk_must_realloc(ptr, size) GC_REALLOC((ptr), (size)) #define STk_free(ptr) GC_FREE(ptr) #define STk_register_finalizer(ptr, f) GC_REGISTER_FINALIZER((void *) (ptr), \ (GC_finalization_proc)(f), 0, 0, 0) #define STk_gc() GC_gcollect() void STk_gc_init(void); /*===========================================================================*\ * * Declaration of the SCM type * \*===========================================================================*/ #define MAX_CELL_TYPES 256 typedef void* SCM; typedef enum { tc_not_boxed=-1, tc_cons, tc_integer, tc_real, tc_bignum, tc_rational, /* 0 */ tc_complex, tc_symbol, tc_keyword, tc_string, tc_module, /* 5 */ tc_instance, tc_closure, tc_subr0, tc_subr1, tc_subr2, /* 10 */ tc_subr3, tc_subr4, tc_subr5, tc_subr01, tc_subr12, /* 15 */ tc_subr23, tc_vsubr, tc_apply, tc_vector, tc_uvector, /* 20 */ tc_hash_table, tc_port, tc_frame, tc_next_method, tc_promise, /* 25 */ tc_regexp, tc_process, tc_continuation, tc_values, tc_parameter, /* 30 */ tc_socket, tc_struct_type, tc_struct, tc_thread, tc_mutex, /* 35 */ tc_condv, tc_box, tc_ext_func, tc_pointer, tc_callback, /* 40 */ tc_last_standard /* must be last as indicated by its name */ } type_cell; /* * Internal representation of SCM object. Object use the two least * significant bit as tag. We have the following representation * * .........00 pointer on an object descriptor (a box) * .........01 integer * .........10 small object (see below for more detail) * .........11 small constant (#t #f '() ... see below for details) */ #define MAKE_SCONST(n) (AS_SCM(n << 2 | 3)) #define SCONSTP(n) ((AS_LONG(n) & 0x3) == 3) /* * Header which must always be put in front of the various boxed types * used by STklos. This field must be declared as the first field of * the structure. */ typedef struct { /* Order is important, changing it can improve the perfomances depending * on the compiler. If you change this definition, change DEFINE_PRIMITIVE * accordingly */ short type, cell_info; } stk_header; #define BOXED_TYPE(x) (((stk_header *) x)->type) #define BOXED_INFO(x) (((stk_header *) x)->cell_info) #define BOXED_OBJP(x) (!(AS_LONG(x) & 3)) #define BOXED_TYPE_EQ(x, y) (BOXED_OBJP(x) && BOXED_TYPE(x) == y) #define STYPE(x) (BOXED_OBJP(x)? BOXED_TYPE(x): tc_not_boxed) #define NEWCELL(_var, _type) { \ _var = (SCM) STk_must_malloc(sizeof(struct CPP_CONCAT(_type,_obj))); \ BOXED_TYPE(_var) = CPP_CONCAT(tc_, _type); \ BOXED_INFO(_var) = 0; \ } #define NEWCELL_WITH_LEN(_var, _type, _len) { \ _var = (SCM) STk_must_malloc(_len); \ BOXED_TYPE(_var) = CPP_CONCAT(tc_, _type); \ BOXED_INFO(_var) = 0; \ } #define NEWCELL_ATOMIC(_var, _type, _len) { \ _var = (SCM) STk_must_malloc_atomic(_len); \ BOXED_TYPE(_var) = CPP_CONCAT(tc_, _type); \ BOXED_INFO(_var) = 0; \ } /* * PRIMITIVES * * Primitives are defined with the macro DEFINE_PRIMITIVE. An example of * usage of this macro is given below: * DEFINE_PRIMITIVE("pair?", pairp, subr1, (SCM obj)) { * * } * It will be expansed in * SCM STk_pairp(SCM obj); * static struct obj_primitive obj_pairp = { "pair?", tc_subr1, STk_pairp}; * SCM STk_pairp(SCM obj){ * * } */ struct primitive_obj { stk_header header; char *name; SCM (*code)(); SCM plist; }; #define PRIMITIVE_NAME(p) (((struct primitive_obj *) (p))->name) #define PRIMITIVE_FUNC(p) (((struct primitive_obj *) (p))->code) #define PRIMITIVE_PLIST(p) (((struct primitive_obj *) (p))->plist) #define DEFINE_PRIMITIVE(_sname, _cname, _type, _params) \ SCM CPP_CONCAT(STk_, _cname) _params; \ struct primitive_obj CPP_CONCAT(STk_o_, _cname) = { \ {CPP_CONCAT(tc_, _type), 0}, \ _sname, CPP_CONCAT(STk_, _cname), STk_nil}; \ SCM CPP_CONCAT(STk_, _cname) _params #define EXTERN_PRIMITIVE(_sname, _cname, _type, _params) \ /* the same one as before but without function definition */ \ extern SCM CPP_CONCAT(STk_, _cname) _params; \ extern struct primitive_obj CPP_CONCAT(STk_o_, _cname) #define ENTER_PRIMITIVE(x) /* here for compability with pre 0.62 version */ #define THE_PRIMITIVE(_name) ((SCM) CPP_CONCAT(&STk_o_, _name)) #define ADD_PRIMITIVE(_name) STk_add_primitive(CPP_CONCAT(&STk_o_, _name)) #define ADD_PRIMITIVE_IN_MODULE(_name, _mod) \ STk_add_primitive_in_module(CPP_CONCAT(&STk_o_, _name), _mod) /* ------------------------------------------------------------------------------ ---- ---- B A S E 6 4 . C ---- ------------------------------------------------------------------------------ */ int STk_init_base64(void); /* ------------------------------------------------------------------------------ ---- ---- B O O L E A N . C ---- ------------------------------------------------------------------------------ */ #define MAKE_BOOLEAN(_cond) ((_cond) ? STk_true : STk_false) #define BOOLEANP(o) (((o) == STk_true) || ((o) == STk_false)) EXTERN_PRIMITIVE("eq?", eq, subr2, (SCM x,SCM y)); EXTERN_PRIMITIVE("eqv?", eqv, subr2, (SCM x,SCM y)); EXTERN_PRIMITIVE("equal?", equal, subr2, (SCM x,SCM y)); int STk_init_boolean(void); /* ------------------------------------------------------------------------------ ---- ---- B O X . C ---- ------------------------------------------------------------------------------ */ struct box_obj { stk_header header; SCM value; }; #define BOXP(p) (BOXED_TYPE_EQ((p), tc_box)) #define BOX_VALUE(p) (((struct box_obj *) (p))->value) #define BOX_CONST (1 << 0) EXTERN_PRIMITIVE("make-box", make_box, subr1, (SCM x)); int STk_init_box(void); /* ------------------------------------------------------------------------------ ---- ---- B Y T E V E C T O R . C ---- ------------------------------------------------------------------------------ */ SCM STk_bytevector2u8list(SCM obj); SCM STk_u8list2bytevector(SCM obj); int STk_init_bytevector(void); /* ------------------------------------------------------------------------------ ---- ---- C H A R . C ---- ------------------------------------------------------------------------------ */ /* * characters are coded as .....XXXXX110 where XXXXX is the code of the * character. Consequently, we can have 29 bits long characters (on a 32 bits * machine) */ #define MAKE_CHARACTER(n) (AS_SCM((n) << 3 | 0x6)) #define CHARACTER_VAL(n) ((AS_LONG(n) >> 3)) #define CHARACTERP(n) ((AS_LONG(n) & 7) == 6) char *STk_char2string(int c); int STk_string2char(char *s); int STk_casefold_char(int ch); int STk_init_char(void); /* ------------------------------------------------------------------------------ ---- ---- C O N D . C ---- ------------------------------------------------------------------------------ */ extern SCM STk_message_condition, STk_err_mess_condition; SCM STk_make_C_cond(SCM type, int nargs, ...); EXTERN_PRIMITIVE("make-condition-type", make_cond_type, subr3, (SCM name, SCM parent, SCM slots)); SCM STk_defcond_type(char *name, SCM parent, SCM slots, SCM module); SCM STk_condition_type_is_a(SCM type, SCM t); int STk_init_cond(void); /* ------------------------------------------------------------------------------ ---- ---- C P O I N T E R . C ---- ------------------------------------------------------------------------------ */ struct pointer_obj { stk_header header; void *value; SCM type; SCM data; }; #define CPOINTERP(p) (BOXED_TYPE_EQ((p), tc_pointer)) #define CPOINTER_VALUE(p) (((struct pointer_obj *) (p))->value) #define CPOINTER_TYPE(p) (((struct pointer_obj *) (p))->type) #define CPOINTER_DATA(p) (((struct pointer_obj *) (p))->data) SCM STk_make_Cpointer(void *ptr, SCM type, SCM data); int STk_init_cpointer(void); /* ------------------------------------------------------------------------------ ---- ---- D Y N L O A D . C ---- ------------------------------------------------------------------------------ */ #define MODULE_ENTRY_START(_name) \ void STk_module_main(void) { \ static int __already_loaded = 0; \ if (__already_loaded++) { \ STk_error("module %S already loaded", (_name)); \ return; \ } { #define MODULE_ENTRY_END } } #define MODULE_ENTRY_INFO() SCM STk_module_info(void) void *STk_find_external_function(char *path, char *fname, int error_if_absent); SCM STk_load_object_file(SCM f, char *fname); SCM STk_info_object_file(char *fname); /* ------------------------------------------------------------------------------ ---- ---- E R R O R . C ---- ------------------------------------------------------------------------------ */ void STk_signal_error(SCM type, SCM who, SCM str); void STk_error(char *format, ...); SCM STk_make_error(char *format, ...); SCM STk_format_error(char *format, ...); void STk_warning(char *format, ...); void STk_panic(char *format, ...); void STk_signal(char *str); #ifdef STK_DEBUG void STk_debug(char *format, ...); # define Debug STk_debug #endif /* ------------------------------------------------------------------------------ ---- ---- E N V . C ---- ------------------------------------------------------------------------------ */ struct frame_obj { stk_header header; SCM next_frame; SCM owner; SCM locals[1]; /* the values associated to the names */ }; /* Note: boxes are used for global variables */ #define FRAME_LENGTH(p) (BOXED_INFO(p)) #define FRAME_NEXT(p) (((struct frame_obj *) (p))->next_frame) #define FRAME_OWNER(p) (((struct frame_obj *) (p))->owner) #define FRAME_LOCALS(p) (((struct frame_obj *) (p))->locals) #define FRAME_LOCAL(p, i) (FRAME_LOCALS(p)[i]) #define FRAMEP(p) (BOXED_TYPE_EQ((p), tc_frame)) /* modules are defined in env.c but are private */ #define MODULEP(p) (BOXED_TYPE_EQ((p), tc_module)) SCM STk_make_frame(int len); SCM STk_clone_frame(SCM f); SCM STk_lookup(SCM symbol, SCM env, SCM *ref, int err_if_unbound); void STk_define_variable(SCM symbol, SCM value, SCM module); int STk_init_env(void); int STk_late_init_env(void); /* must be done after symbol initialization */ extern SCM STk_STklos_module; EXTERN_PRIMITIVE("%create-module", create_module, subr1, (SCM name)); EXTERN_PRIMITIVE("current-module", current_module, subr0, (void)); EXTERN_PRIMITIVE("%select-module", select_module, subr1, (SCM module)); /* ------------------------------------------------------------------------------ ---- ---- E X T E N D . C ---- ------------------------------------------------------------------------------ */ /* The `extended_type_descr' structure is used for the types which need * more information (such as modules, ports, ....). All the extended * descriptors are stored in the STk_xtypes array. */ struct extended_type_descr { char *name; void (*print)(SCM exp, SCM port, int mode); }; extern struct extended_type_descr *STk_xtypes[]; #define BOXED_XTYPE(o) (STk_xtypes[((stk_header *) o)->type]) #define XTYPE_NAME(d) (d->name) #define XTYPE_PRINT(d) (d->print) #define DEFINE_XTYPE(_type, _descr) (STk_xtypes[CPP_CONCAT(tc_, _type)]=_descr) #define DEFINE_USER_TYPE(_type, _descr) { _type = STk_new_user_type(_descr); } int STk_new_user_type(struct extended_type_descr *); int STk_init_extend(void); /* ------------------------------------------------------------------------------ ---- ---- F F I . C ---- ------------------------------------------------------------------------------ */ SCM STk_call_ext_function(SCM fct, int argc, SCM *argv); SCM STk_ext_func_name(SCM fct); int STk_init_ffi(void); /* ------------------------------------------------------------------------------ ---- ---- F I X N U M . C ---- ------------------------------------------------------------------------------ */ EXTERN_PRIMITIVE("fx+", fxplus, subr2, (SCM o1, SCM o2)); EXTERN_PRIMITIVE("fx-", fxminus, subr2, (SCM o1, SCM o2)); EXTERN_PRIMITIVE("fx*", fxtime, subr2, (SCM o1, SCM o2)); EXTERN_PRIMITIVE("fxdiv", fxdiv, subr2, (SCM o1, SCM o2)); int STk_init_fixnum(void); /* ------------------------------------------------------------------------------ ---- ---- K E Y W O R D . C ---- ------------------------------------------------------------------------------ */ struct keyword_obj { stk_header header; char *pname; /* must be at the same offset than for symbols */ }; #define KEYWORD_PNAME(p) (((struct keyword_obj *) (p))->pname) #define KEYWORDP(p) (BOXED_TYPE_EQ((p),tc_keyword)) #define KEYWORD_NEEDS_BARS (1 << 0) /* Info flag */ #define KEYWORD_HAS_UPPER (1 << 1) EXTERN_PRIMITIVE("key-set!", key_set, subr3, (SCM l, SCM key, SCM val)); EXTERN_PRIMITIVE("key-get", key_get, subr23, (SCM l, SCM key, SCM dflt)); SCM STk_makekey(char *tok); int STk_init_keyword(void); /* ------------------------------------------------------------------------------ ---- ---- L I B . C ---- ------------------------------------------------------------------------------ */ extern int STk_library_initialized; /* True when successfully initialized */ int STk_init_library(int *argc, char ***argv, int stack_size); /* ------------------------------------------------------------------------------ ---- ---- L I S T . C ---- ------------------------------------------------------------------------------ */ struct cons_obj { stk_header header; SCM car; SCM cdr; }; #define CAR(p) (((struct cons_obj *) (p))->car) #define CDR(p) (((struct cons_obj *) (p))->cdr) #define CONSP(p) (BOXED_TYPE_EQ((p), tc_cons)) #define NULLP(p) ((p) == STk_nil) #define CONS_CONST (1 << 0) #define CONS_PLACEHOLDER (1 << 1) /* used for #n= and #n# notation */ #define CONS_ECONS (1 << 2) /* used for extended conses */ #define LIST1(a) STk_cons((a), STk_nil) #define LIST2(a,b) STk_cons((a), LIST1(b)) #define LIST3(a,b,c) STk_cons((a), LIST2((b),(c))) #define LIST4(a,b,c,d) STk_cons((a), LIST3((b),(c),(d))) #define LIST5(a,b,c,d,e) STk_cons((a), LIST4((b),(c),(d),(e))) #define LIST6(a,b,c,d,e,f) STk_cons((a), LIST5((b),(c),(d),(e),(f))) #define LIST7(a,b,c,d,e,f,g) STk_cons((a), LIST6((b),(c),(d),(e),(f),(g))) #define LIST8(a,b,c,d,e,f,g,h) STk_cons((a), LIST7((b),(c),(d),(e),(f),(g),(h))) #define LIST9(a,b,c,d,e,f,g,h,i) \ STk_cons((a), LIST8((b),(c),(d),(e),(f),(g),(h),(i))) #define LIST10(a,b,c,d,e,f,g,h,i,j) \ STk_cons((a), LIST9((b),(c),(d),(e),(f),(g),(h),(i),(j))) int STk_int_length(SCM l); /* len of a list -1 if badly formed */ SCM STk_int_assq(SCM obj, SCM alist); /* internal version of assq */ SCM STk_argv2list(int argc, SCM *argv); SCM STk_append2(SCM l1, SCM l2); SCM STk_dappend2(SCM l1, SCM l2); /* destructive append */ SCM STk_dremq(SCM obj, SCM list); /* destructive remove with eq? */ SCM STk_econs(SCM car, SCM cdr, char *file, int line, int pos); EXTERN_PRIMITIVE("cons", cons, subr2, (SCM x, SCM y)); EXTERN_PRIMITIVE("car", car, subr1, (SCM x)); EXTERN_PRIMITIVE("cdr", cdr, subr1, (SCM x)); EXTERN_PRIMITIVE("list", list, vsubr, (int argc, SCM * argv)); EXTERN_PRIMITIVE("memq", memq, subr2, (SCM obj, SCM list)); EXTERN_PRIMITIVE("reverse", reverse, subr1, (SCM l)); EXTERN_PRIMITIVE("reverse!", dreverse, subr1, (SCM l)); EXTERN_PRIMITIVE("copy-tree", copy_tree, subr1, (SCM l)); EXTERN_PRIMITIVE("assq", assq, subr2, (SCM obj, SCM alist)); EXTERN_PRIMITIVE("assv", assv, subr2, (SCM obj, SCM alist)); EXTERN_PRIMITIVE("assoc", assoc, subr2, (SCM obj, SCM alist)); int STk_init_list(void); /* ------------------------------------------------------------------------------ ---- ---- M D 5 . C ---- ------------------------------------------------------------------------------ */ int STk_init_md5(void); /* ------------------------------------------------------------------------------ ---- ---- M I S C . C ---- ------------------------------------------------------------------------------ */ #ifdef STK_DEBUG extern int STk_interactive_debug; #endif char *STk_strdup(const char *s); void STk_add_primitive(struct primitive_obj *o); void STk_add_primitive_in_module(struct primitive_obj *o, SCM module); SCM STk_eval_C_string(char *str, SCM module); SCM STk_read_from_C_string(char *str); int STk_init_misc(void); /* ------------------------------------------------------------------------------ ---- ---- N U M B E R . C ---- ------------------------------------------------------------------------------ */ /**** **** Integer ****/ /* As said before, integers are not allocated but have their two * least significant bits set to 01. */ #define INT_VAL(p) (((long) p) >> 2) #define INTP(p) ((((unsigned long) p) & 3) == 1) #define SCM_LONG(n) (((n) << 2) | 1) #define MAKE_INT(n) (AS_SCM(SCM_LONG(n))) #define INT_MIN_VAL ((LONG_MIN & ~3) >> 2) #define INT_MAX_VAL ((LONG_MAX & ~3) >> 2) long STk_integer_value(SCM x); /* Returns LONG_MIN if not representable as long */ unsigned long STk_uinteger_value(SCM x); /* Returns ULONG_MAX if not an ulong */ /**** **** Real ****/ #define REAL_FORMAT_SIZE 15 /* default format for real */ struct real_obj { stk_header header; double val; }; #define REAL_VAL(p) (((struct real_obj *) (p))->val) #define REALP(p) (BOXED_TYPE_EQ((p), tc_real)) extern double STk_NaN; /* IEEE NaN special value */ /**** **** Bignum ****/ struct bignum_obj; /* complete deflaration is in number.c */ #define BIGNUMP(p) (BOXED_TYPE_EQ((p), tc_bignum)) /**** **** Rational ****/ struct rational_obj { stk_header header; SCM num, den; }; #define RATIONAL_NUM(p) (((struct rational_obj *) (p))->num) #define RATIONAL_DEN(p) (((struct rational_obj *) (p))->den) #define RATIONALP(p) (BOXED_TYPE_EQ((p), tc_rational)) #define EXACT_RATIONALP(p) (RATIONALP(p) && \ !REALP(RATIONAL_NUM(p)) && \ !REALP(RATIONAL_DEN(p))) /**** **** Complex ****/ struct complex_obj { stk_header header; SCM real, imag; }; #define COMPLEX_REAL(p) (((struct complex_obj *) (p))->real) #define COMPLEX_IMAG(p) (((struct complex_obj *) (p))->imag) #define COMPLEXP(p) (BOXED_TYPE_EQ((p), tc_complex)) #define EXACT_COMPLEXP(p) (COMPLEXP(p) && \ !REALP(COMPLEX_REAL(p)) && \ !REALP(COMPLEX_IMAG(p))) /**** **** Conversions ****/ SCM STk_Cstr2number(char *str, long base); char *STk_bignum2Cstring(SCM n, int base); SCM STk_long2integer(long n); SCM STk_ulong2integer(unsigned long n); SCM STk_double2real(double d); double STk_number2double(SCM n); long STk_integer2int32(SCM n, int *overflow); unsigned long STk_integer2uint32(SCM n, int *overflow); /**** **** Arithmetic ****/ SCM STk_add2(SCM o1, SCM o2); SCM STk_sub2(SCM o1, SCM o2); SCM STk_mul2(SCM o1, SCM o2); SCM STk_div2(SCM o1, SCM o2); long STk_numeq2(SCM o1, SCM o2); long STk_numdiff2(SCM o1, SCM o2); long STk_numlt2(SCM o1, SCM o2); long STk_numgt2(SCM o1, SCM o2); long STk_numle2(SCM o1, SCM o2); long STk_numge2(SCM o1, SCM o2); void STk_double2Cstr(char *buffer, double n); EXTERN_PRIMITIVE("number->string", number2string, subr12, (SCM n, SCM base)); int STk_init_number(void); #define NUMBERP(x) (INTP(x) || BIGNUMP(x) || REALP(x) || RATIONALP(x) || \ COMPLEXP(x)) #define EXACTP(x) (INTP(x) || BIGNUMP(x) || EXACT_RATIONALP(x) || \ EXACT_COMPLEXP(x)) /* ------------------------------------------------------------------------------ ---- ---- O B J E C T . C ---- ------------------------------------------------------------------------------ */ int STk_init_object(void); /* ------------------------------------------------------------------------------ ---- ---- P A R A M E T E R . C ---- ------------------------------------------------------------------------------ */ int STk_init_parameter(void); SCM STk_get_parameter(SCM param); SCM STk_set_parameter(SCM param, SCM value); SCM STk_make_C_parameter(SCM symbol, SCM value, SCM (*proc)(SCM new_value), SCM module); SCM STk_make_C_parameter2(SCM symbol,SCM (*value)(void),SCM (*proc)(SCM new_value), SCM module); /* ------------------------------------------------------------------------------ ---- ---- P A T H . C ---- ------------------------------------------------------------------------------ */ char *STk_expand_file_name(char *s); SCM STk_do_glob(int argc, SCM *argv); SCM STk_resolve_link(char *path, int count); /* ------------------------------------------------------------------------------ ---- ---- P O R T . C ---- ---- (and sio.c, fport.c, sport.c, vport.c) ---- ------------------------------------------------------------------------------ */ /* Code for port is splitted in several files: * - sio.c contains the low level IO functions which mimic the C IO. All * these functions take Scheme ports as parameter instead of FILE * * - fport.c contains the specific code for port associated to files * - sport.c contains the specific code for port associated to string ports * - vport.c contains the specific code for port associated to virtual ports * - port.c contains the code which can be used on any kind of port */ struct port_obj { stk_header header; void *stream; /* stream descriptor != for strings, file, virt. */ int flags; /* associated flags */ int ungetted_char; /* character ungetted, EOF if none */ char *filename; /* File name (for file port, a const otherwise) */ int line; /* Line number (unused when writing) */ int pos; /* position from the start of file */ SCM close_hook; /* hook called when a file is closed */ /* virtual functions (in the object 'cause the # of ports should be low ) */ void (*print_it) (SCM obj, SCM port); /* used to display or print object */ void (*release_it)(SCM obj); int (*creadyp) (void *stream); int (*cgetc) (void *stream); int (*ceofp) (void *stream); int (*cclose) (void *stream); int (*cputc) (int c, void * stream); int (*cputs) (char *s, void * stream); int (*cnputs) (void *stream, char *str, int len); int (*cputstring)(void *stream, SCM str); int (*cflush) (void *stream); int (*read_buff) (void *stream, void *buf, int count); int (*write_buff)(void *stream, void *buf, int count); off_t (*seek) (void *stream, off_t offset, int whence); }; #define PORT_MAX_PRINTF 1024 /* max size for sprintf buffer */ #define PORT_READ (1<<0) #define PORT_WRITE (1<<1) #define PORT_RW (1<<2) #define PORT_CLOSED (1<<3) #define PORT_IS_PIPE (1<<4) #define PORT_IS_FILE (1<<5) #define PORT_IS_STRING (1<<6) #define PORT_IS_VIRTUAL (1<<7) #define PORT_IS_INTERACTIVE (1<<8) #define PORT_STREAM(x) (((struct port_obj *) (x))->stream) #define PORT_FLAGS(x) (((struct port_obj *) (x))->flags) #define PORT_UNGETC(x) (((struct port_obj *) (x))->ungetted_char) #define PORT_LINE(x) (((struct port_obj *) (x))->line) #define PORT_POS(x) (((struct port_obj *) (x))->pos) #define PORT_FNAME(x) (((struct port_obj *) (x))->filename) #define PORT_CLOSEHOOK(x) (((struct port_obj *) (x))->close_hook) #define PORT_PRINT(x) (((struct port_obj *) (x))->print_it) #define PORT_RELEASE(x) (((struct port_obj *) (x))->release_it) #define PORT_READY(x) (((struct port_obj *) (x))->creadyp) #define PORT_GETC(x) (((struct port_obj *) (x))->cgetc) #define PORT_EOFP(x) (((struct port_obj *) (x))->ceofp) #define PORT_CLOSE(x) (((struct port_obj *) (x))->cclose) #define PORT_PUTC(x) (((struct port_obj *) (x))->cputc) #define PORT_PUTS(x) (((struct port_obj *) (x))->cputs) #define PORT_PUTSTRING(x) (((struct port_obj *) (x))->cputstring) #define PORT_NPUTS(x) (((struct port_obj *) (x))->cnputs) #define PORT_FLUSH(x) (((struct port_obj *) (x))->cflush) #define PORT_BREAD(x) (((struct port_obj *) (x))->read_buff) #define PORT_BWRITE(x) (((struct port_obj *) (x))->write_buff) #define PORT_SEEK(x) (((struct port_obj *) (x))->seek) #define PORTP(x) (BOXED_TYPE_EQ((x), tc_port)) #define IPORTP(x) (PORTP(x) && (PORT_FLAGS(x) & (PORT_READ|PORT_RW))) #define OPORTP(x) (PORTP(x) && (PORT_FLAGS(x) & (PORT_WRITE|PORT_RW))) #define FPORTP(x) (PORTP(x) && (PORT_FLAGS(x) & (PORT_IS_FILE|PORT_IS_PIPE))) #define IFPORTP(x) (FPORTP(x) && (PORT_FLAGS(x) & (PORT_READ|PORT_RW))) #define OFPORTP(x) (FPORTP(x) && (PORT_FLAGS(x) & (PORT_WRITE|PORT_RW))) #define SPORTP(x) (PORTP(x) && (PORT_FLAGS(x) & PORT_IS_STRING)) #define ISPORTP(x) (SPORTP(x) && (PORT_FLAGS(x) & (PORT_READ|PORT_RW))) #define OSPORTP(x) (SPORTP(x) && (PORT_FLAGS(x) & (PORT_WRITE|PORT_RW))) #define VPORTP(x) (PORTP(x) && (PORT_FLAGS(x) & PORT_IS_VIRTUAL)) #define IVPORTP(x) (VPORTP(x) && (PORT_FLAGS(x) & (PORT_READ|PORT_RW))) #define OVPORTP(x) (VPORTP(x) && (PORT_FLAGS(x) & (PORT_WRITE|PORT_RW))) #define PORT_IS_CLOSEDP(x) (PORT_FLAGS(x) & PORT_CLOSED) /**** **** sio.h primitives ****/ int STk_readyp(SCM port); int STk_getc(SCM port); int STk_get_character(SCM port); /* result may be a wide char */ int STk_ungetc(int c, SCM port); int STk_close(SCM port); int STk_putc(int c, SCM port); int STk_puts(char *s, SCM port); int STk_putstring(SCM s, SCM port); int STk_nputs(SCM port, char *s, int len); off_t STk_seek(SCM port, off_t offset, int whence); off_t STk_tell(SCM port); void STk_rewind(SCM port); int STk_flush(SCM port); int STk_feof(SCM port); int STk_fprintf(SCM port, char *format, ...); int STk_read_buffer(SCM port, void *buff, int count); int STk_write_buffer(SCM port, void *buff, int count); /**** **** fport.h primitives ****/ SCM STk_rewind_file_port(SCM port); SCM STk_open_file(char *filename, char *mode); SCM STk_add_port_idle(SCM port, SCM idle_func); SCM STk_fd2scheme_port(int fd, char *mode, char *identification); void STk_set_line_buffered_mode(SCM port); int STk_init_fport(void); SCM STk_current_input_port(void); SCM STk_current_output_port(void); SCM STk_current_error_port(void); void STk_close_all_ports(void); /**** **** sport.h primitives ****/ EXTERN_PRIMITIVE("open-output-string", open_output_string, subr0, (void)); SCM STk_get_output_string(SCM port); SCM STk_open_C_string(char *str); int STk_init_sport(void); /**** **** vport.h primitives ****/ int STk_init_vport(void); /**** **** port.h primitives ****/ EXTERN_PRIMITIVE("close-port", close_port, subr1, (SCM port)); EXTERN_PRIMITIVE("read-line", read_line, subr01, (SCM port)); void STk_error_bad_port(SCM p); void STk_error_bad_file_name(SCM f); void STk_error_cannot_load(SCM f); void STk_error_bad_io_param(char *fmt, SCM p); void STk_error_file_name(char *fmt, SCM fn); int STk_init_port(void); /**** **** Port global variables ****/ extern char *STk_current_filename; /* Name of the file we read */ extern SCM STk_stdin, STk_stdout, STk_stderr; /* unredirected ports */ extern int STk_interactive; /* We are in intearctive mode */ /* ------------------------------------------------------------------------------ ---- ---- P R I N T . C ---- ------------------------------------------------------------------------------ */ void STk_print(SCM exp, SCM port, int mode); void STk_print_star(SCM exp, SCM port); #define DSP_MODE 0 #define WRT_MODE 1 int STk_init_printer(void); /* ------------------------------------------------------------------------------ ---- ---- P R O C E S S . C ---- ------------------------------------------------------------------------------ */ int STk_init_process(void); /* ------------------------------------------------------------------------------ ---- ---- P R O M I S E . C ---- ------------------------------------------------------------------------------ */ int STk_init_promise(void); /* ------------------------------------------------------------------------------ ---- ---- P R O C . C ---- ------------------------------------------------------------------------------ */ typedef short STk_instr; struct closure_obj { stk_header header; short arity; unsigned short code_size; /* SCM formals; */ SCM env; SCM plist; SCM name; SCM* constants; SCM doc; STk_instr *bcode; }; /* FIXME: #define CLOSURE_FORMALS(p) (((struct closure_obj *) (p))->formals) #define CLOSURE_CODE(p) (((struct closure_obj *) (p))->code) */ #define CLOSURE_ARITY(p) (((struct closure_obj *) (p))->arity) #define CLOSURE_SIZE(p) (((struct closure_obj *) (p))->code_size) #define CLOSURE_ENV(p) (((struct closure_obj *) (p))->env) #define CLOSURE_PLIST(p) (((struct closure_obj *) (p))->plist) #define CLOSURE_NAME(p) (((struct closure_obj *) (p))->name) #define CLOSURE_CONST(p) (((struct closure_obj *) (p))->constants) #define CLOSURE_DOC(p) (((struct closure_obj *) (p))->doc) #define CLOSURE_BCODE(p) (((struct closure_obj *) (p))->bcode) #define CLOSUREP(p) (BOXED_TYPE_EQ((p), tc_closure)) EXTERN_PRIMITIVE("procedure?", procedurep, subr1, (SCM obj)); EXTERN_PRIMITIVE("%procedure-arity", proc_arity, subr1, (SCM proc)); SCM STk_make_closure(STk_instr *code, int size, int arity, SCM *cst, SCM env); int STk_init_proc(void); /* ------------------------------------------------------------------------------ ---- ---- R E A D . C ---- ------------------------------------------------------------------------------ */ SCM STk_read(SCM port, int case_significant); SCM STk_read_constant(SCM port, int case_significant); char *STk_quote2str(SCM symb); int STk_init_reader(void); extern int STk_read_case_sensitive; /* ------------------------------------------------------------------------------ ---- ---- R E G E X P . C ---- ------------------------------------------------------------------------------ */ int STk_init_regexp(void); EXTERN_PRIMITIVE("string->regexp", str2regexp, subr1, (SCM re)); EXTERN_PRIMITIVE("regexp-match", regexec, subr2, (SCM re, SCM str)); /* ------------------------------------------------------------------------------ ---- ---- S I G N A L . C ---- ------------------------------------------------------------------------------ */ int STk_get_signal_value(SCM sig); int STk_init_signal(void); /* ------------------------------------------------------------------------------ ---- ---- S O C K E T . C ---- ------------------------------------------------------------------------------ */ int STk_init_socket(void); /* ------------------------------------------------------------------------------ ---- ---- S T R . C ---- ------------------------------------------------------------------------------ */ struct string_obj { stk_header header; int space; /* allocated size */ int size; /* # of bytes used */ int length; /* "external" length of the string */ char *chars; }; #define STRING_SPACE(p) (((struct string_obj *) (p))->space) #define STRING_SIZE(p) (((struct string_obj *) (p))->size) #define STRING_LENGTH(p) (((struct string_obj *) (p))->length) #define STRING_CHARS(p) (((struct string_obj *) (p))->chars) #define STRINGP(p) (BOXED_TYPE_EQ((p), tc_string)) #define STRING_CONST (1 << 0) #define STRING_MONOBYTE(str) (STRING_LENGTH(str) == STRING_SIZE(str)) SCM STk_makestring(int len, char *init); SCM STk_Cstring2string(char *str); /* Embed a C string in Scheme world */ EXTERN_PRIMITIVE("string=?", streq, subr2, (SCM s1, SCM s2)); EXTERN_PRIMITIVE("string-ref", string_ref, subr2, (SCM str, SCM index)); EXTERN_PRIMITIVE("string-set!", string_set, subr3, (SCM str, SCM index, SCM value)); EXTERN_PRIMITIVE("string-downcase!", string_ddowncase, vsubr, (int argc, SCM *argv)); int STk_init_string(void); /* ------------------------------------------------------------------------------ ---- ---- S T R U C T . C ---- ------------------------------------------------------------------------------ */ int STk_init_struct(void); /* ------------------------------------------------------------------------------ ---- ---- S Y M B O L . C ---- ------------------------------------------------------------------------------ */ struct symbol_obj { stk_header header; /* must be at the same offset than for keywords */ char *pname; }; #define SYMBOL_PNAME(p) (((struct symbol_obj *) (p))->pname) #define SYMBOLP(p) (BOXED_TYPE_EQ((p),tc_symbol)) #define SYMBOL_NEEDS_BARS (1 << 0) /* Info flag */ #define SYMBOL_HAS_UPPER (1 << 1) EXTERN_PRIMITIVE("string->symbol", string2symbol, subr1, (SCM string)); int STk_symbol_flags(register char *s); SCM STk_intern(char *name); SCM STk_intern_ci(char *name); SCM STk_make_uninterned_symbol(char *name); int STk_init_symbol(void); /* ------------------------------------------------------------------------------ ---- ---- S Y S T E M . C ---- ------------------------------------------------------------------------------ */ int STk_dirp(const char *path); int STk_init_system(); EXTERN_PRIMITIVE("%pre-exit", pre_exit, subr1, (SCM retcode)); EXTERN_PRIMITIVE("exit", exit, subr01, (SCM retcode)); /* ------------------------------------------------------------------------------ ---- ---- T H R E A D . C ---- ------------------------------------------------------------------------------ */ EXTERN_PRIMITIVE("current-thread", current_thread, subr0, (void)); int STk_init_threads(int stack_size, void *start_stack); int STk_init_mutexes(void); /* ------------------------------------------------------------------------------ ---- ---- U T F 8 . C ---- ------------------------------------------------------------------------------ */ #define UTF8_INCORRECT_SEQUENCE (-2) extern int STk_use_utf8; #define VALID_UTF8_VALUE(c) \ /* Unicode defines characters in the range [0, #xd7FF] U [#xE000, #x10FFFF] */ \ ((0 <= (c) && (c) <= 0xd7ff) || (0xE000 <=(c) && (c) <= 0x10FFFF)) char *STk_utf8_grab_char(char *str, uint32_t *c);/* result = pos. after current one */ int STk_char2utf8(int ch, char *str); /* result = length of the UTF-8 repr. */ int STk_utf8_strlen(char *s, int max); int STk_utf8_read_char(SCM port); int STk_utf8_sequence_length(char *str); /* # of bytes of sequence starting at str */ int STk_utf8_char_bytes_needed(unsigned int ch);/* # of bytes needed to represent ch*/ char *STk_utf8_index(char *s, int i, int max);/* return the address of ith char of s*/ int STk_utf8_char_from_byte(char *s, int i, int max); /* byte index => char index */ int STk_init_utf8(void); /* ------------------------------------------------------------------------------ ---- ---- U V E C T O R . C ---- ------------------------------------------------------------------------------ */ extern int STk_uvectors_allowed; int STk_uniform_vector_tag(char *s); int STk_uvector_equal(SCM u1, SCM u2); SCM STk_list2uvector(int type, SCM l); int STk_init_uniform_vector(void); /* ------------------------------------------------------------------------------ ---- ---- V E C T O R . C ---- ------------------------------------------------------------------------------ */ struct vector_obj { stk_header header; int size; SCM data[1]; }; #define VECTOR_SIZE(p) (((struct vector_obj *) (p))->size) #define VECTOR_DATA(p) (((struct vector_obj *) (p))->data) #define VECTORP(p) (BOXED_TYPE_EQ((p), tc_vector)) #define VECTOR_CONST (1 << 0) EXTERN_PRIMITIVE("vector-ref", vector_ref, subr2, (SCM v, SCM index)); EXTERN_PRIMITIVE("vector-set!", vector_set, subr3, (SCM v, SCM index, SCM value)); EXTERN_PRIMITIVE("vector->list", vector2list, subr1, (SCM v)); EXTERN_PRIMITIVE("list->vector", list2vector, subr1, (SCM l)); SCM STk_makevect(int len, SCM init); int STk_init_vector(void); /* ------------------------------------------------------------------------------ ---- ---- V M . C ---- ------------------------------------------------------------------------------ */ #define DEFAULT_STACK_SIZE 100000 void STk_execute_current_handler(SCM kind, SCM location, SCM message); void STk_raise_exception(SCM cond); SCM STk_C_apply(SCM func, int nargs, ...); SCM STk_C_apply_list(SCM func, SCM l); void STk_get_stack_pointer(void **addr); SCM STk_n_values(int n, ...); SCM STk_values2vector(SCM obj, SCM vect); EXTERN_PRIMITIVE("%vm-backtrace", vm_bt, subr0, (void)); SCM STk_load_bcode_file(SCM f); int STk_load_boot(char *s); int STk_boot_from_C(void); SCM STk_execute_C_bytecode(SCM consts, STk_instr *instr); int STk_init_vm(); /*****************************************************************************/ extern char *STk_boot_consts; extern STk_instr STk_boot_code[]; /* Special constants */ #define STk_nil ((SCM) MAKE_SCONST(0)) #define STk_false ((SCM) MAKE_SCONST(1)) #define STk_true ((SCM) MAKE_SCONST(2)) #define STk_eof ((SCM) MAKE_SCONST(3)) #define STk_void ((SCM) MAKE_SCONST(4)) #define STk_dot ((SCM) MAKE_SCONST(5)) /* special pupose value see read.c */ #define STk_close_par ((SCM) MAKE_SCONST(6)) /* special pupose value see read.c */ /* Misc */ #ifdef __cplusplus } #endif #endif /* STKLOS_H */