Back to index

plt-scheme  4.2.1
scheme.h
Go to the documentation of this file.
00001 /*
00002   MzScheme
00003   Copyright (c) 2004-2009 PLT Scheme Inc.
00004   Copyright (c) 1995-2001 Matthew Flatt
00005   All rights reserved.
00006 
00007   Please see the full copyright in the documentation.
00008 
00009   Originally based on:
00010   libscheme
00011   Copyright (c) 1994 Brent Benson
00012   All rights reserved.
00013 */
00014 
00015 #ifndef SCHEME_H
00016 #define SCHEME_H
00017 
00018 /* The next line is used and set during installation: */
00019 /*III*/
00020 
00021 /*========================================================================*/
00022 /*                           configuration                                */
00023 /*========================================================================*/
00024 
00025 /* The configuration is not intended to be adjusted here. Instead,
00026    modify sconfig.h. The code below simply draws a few more
00027    configuration conclusions and a few extra macros based on those
00028    settings. */
00029 
00030 #ifdef INCLUDE_WITHOUT_PATHS
00031 # include "sconfig.h"
00032 #else
00033 # include "../sconfig.h"
00034 #endif
00035 
00036 #if defined(__MWERKS__)
00037 # ifdef MZSCHEME_USES_NEAR_GLOBALS
00038 #  pragma far_data off
00039 # endif
00040 #endif
00041 
00042 #if SGC_STD_DEBUGGING
00043 # ifndef USE_SENORA_GC
00044 #  define USE_SENORA_GC
00045 # endif
00046 # define USE_MEMORY_TRACING
00047 #endif
00048 
00049 #ifdef MZ_PRECISE_GC
00050 # define MUST_REGISTER_GLOBALS
00051 # define MZTAG_REQUIRED
00052 # undef UNIX_IMAGE_DUMPS
00053 /* In case SGC is used to build PRECISE_GC: */
00054 # undef USE_SENORA_GC
00055 #endif
00056 
00057 #ifdef USE_SENORA_GC
00058 # define MUST_REGISTER_GLOBALS
00059 # undef UNIX_IMAGE_DUMPS
00060 #endif
00061 
00062 #ifdef USE_SINGLE_FLOATS
00063 # define MZ_USE_SINGLE_FLOATS
00064 #endif
00065 
00066 #ifdef DONT_ITIMER
00067 # undef USE_ITIMER
00068 #endif
00069 
00070 #if defined(USE_ITIMER) || defined(USE_WIN32_THREAD_TIMER) || defined(USE_PTHREAD_THREAD_TIMER)
00071 # define FUEL_AUTODECEREMENTS
00072 #endif
00073 
00074 #ifdef SIZEOF_LONG
00075 # if SIZEOF_LONG == 8
00076 #  define SIXTY_FOUR_BIT_INTEGERS
00077 #  ifdef USE_LONG_LONG_FOR_BIGDIG
00078      Don ot specify USE_LONG_LONG_FOR_BIGDIG on a platform with
00079      64-bit integers
00080 #  endif
00081 # endif
00082 #endif
00083 
00084 #ifdef MZ_PRECISE_GC
00085 # define MZ_HASH_KEY_EX  short keyex;
00086 # define MZ_OPT_HASH_KEY_EX 
00087 # define MZ_OPT_HASH_KEY(obj) (obj)->so.keyex
00088 #else
00089 # define MZ_HASH_KEY_EX 
00090 # define MZ_OPT_HASH_KEY_EX  short keyex;
00091 # define MZ_OPT_HASH_KEY(obj) (obj)->keyex
00092 #endif
00093 
00094 #ifdef PALMOS_STUFF
00095 # include <PalmOS.h>
00096 typedef long FILE;
00097 # define _LINUX_TYPES_H  /* Blocks types.h */
00098 #endif
00099 
00100 #ifndef SCHEME_DIRECT_EMBEDDED
00101 # define SCHEME_DIRECT_EMBEDDED 1
00102 #endif
00103 
00104 #ifndef MSC_IZE
00105 # define MSC_IZE(x) x
00106 #endif
00107 #ifndef MSCBOR_IZE
00108 # define MSCBOR_IZE(x) MSC_IZE(x)
00109 #endif
00110 
00111 #ifdef SIGSET_IS_SIGNAL
00112 # define MZ_SIGSET(s, f) signal(s, f)
00113 #else
00114 # define MZ_SIGSET(s, f) sigset(s, f)
00115 #endif
00116 
00117 #ifdef MZ_XFORM
00118 # define XFORM_NONGCING __xform_nongcing__
00119 #else
00120 # define XFORM_NONGCING /* empty */
00121 #endif
00122 
00123 #ifdef MZ_XFORM
00124 START_XFORM_SUSPEND;
00125 #endif
00126 
00127 #include <stdio.h>
00128 #include <setjmp.h>
00129 #include <stdarg.h>
00130 #include <stdlib.h>
00131 #include <string.h>
00132 #include <stddef.h>
00133 
00134 #ifdef MZ_XFORM
00135 END_XFORM_SUSPEND;
00136 #endif
00137 
00138 #ifdef PALMOS_STUFF
00139 typedef jmpbuf jmp_buf[1];
00140 #endif
00141 
00142 #define GC_MIGHT_USE_REGISTERED_STATICS
00143 
00144 #ifdef MACINTOSH_EVENTS
00145 /* We avoid #including the Carbon headers because we only
00146    need a few abstract struct types: */
00147 typedef struct FSSpec mzFSSpec;
00148 #endif
00149 
00150 /* Set up MZ_EXTERN for DLL build */
00151 #if defined(WINDOWS_DYNAMIC_LOAD) \
00152     && !defined(LINK_EXTENSIONS_BY_TABLE) \
00153     && !defined(SCHEME_EMBEDDED_NO_DLL)
00154 # define MZ_DLLIMPORT __declspec(dllimport)
00155 # define MZ_DLLEXPORT __declspec(dllexport)
00156 # ifdef __mzscheme_private__
00157 #  define MZ_DLLSPEC __declspec(dllexport)
00158 # else
00159 #  define MZ_DLLSPEC __declspec(dllimport)
00160 # endif
00161 #else
00162 # define MZ_DLLSPEC
00163 # define MZ_DLLIMPORT
00164 # define MZ_DLLEXPORT
00165 #endif
00166 
00167 #define MZ_EXTERN extern MZ_DLLSPEC
00168 
00169 #ifdef MZ_USE_PLACES
00170 # if _MSC_VER
00171 #  define THREAD_LOCAL __declspec(thread)
00172 # else
00173 #  define THREAD_LOCAL __thread
00174 # endif
00175 #else
00176 # define THREAD_LOCAL /* empty */
00177 #endif
00178 
00179 #if defined(MZ_USE_JIT_PPC) || defined(MZ_USE_JIT_I386) || defined(MZ_USE_JIT_X86_64)
00180 # define MZ_USE_JIT
00181 #endif
00182 
00183 /* Define _W64 for MSC if needed. */
00184 #if defined(_MSC_VER) && !defined(_W64)
00185 # if !defined(__midl) && (defined(_X86_) || defined(_M_IX86)) && _MSC_VER >= 1300
00186 # define _W64 __w64
00187 # else
00188 # define _W64
00189 # endif
00190 #endif
00191 
00192 /* PPC Linux plays a slimy trick: it defines strcpy() as a macro that
00193    uses __extension__. This breaks the 3m xform. */
00194 #if defined(MZ_XFORM) && defined(strcpy)
00195 START_XFORM_SKIP;
00196 static inline void _mzstrcpy(char *a, const char *b)
00197 {
00198   strcpy(a, b);
00199 }
00200 END_XFORM_SKIP;
00201 # undef strcpy
00202 # define strcpy _mzstrcpy
00203 #endif
00204 
00205 #ifdef __cplusplus
00206 extern "C"
00207 {
00208 #endif
00209 
00210 /*========================================================================*/
00211 /*                        basic Scheme values                             */
00212 /*========================================================================*/
00213 
00214 typedef short Scheme_Type;
00215 
00216 typedef int mzshort;
00217 
00218 typedef unsigned int mzchar;
00219 typedef int mzchar_int; /* includes EOF */
00220 
00221 #ifdef INT64_AS_LONG_LONG
00222 typedef _int64 mzlonglong;
00223 typedef unsigned _int64 umzlonglong;
00224 #else
00225 # if defined(NO_LONG_LONG_TYPE) || defined(SIXTY_FOUR_BIT_INTEGERS)
00226 typedef long mzlonglong;
00227 typedef unsigned long umzlonglong;
00228 # else
00229 typedef long long mzlonglong;
00230 typedef unsigned long long umzlonglong;
00231 # endif
00232 #endif
00233 
00234 /* MzScheme values have the type `Scheme_Object *'. The Scheme_Object
00235    structure declares just the header: a type tag and space for
00236    hashing or extra flags; actual object types will extend this
00237    structure.
00238 
00239    For example, Scheme_Simple_Object defines a few variants. The
00240    important thing is that it starts with a nested Scheme_Object
00241    record.
00242 
00243    The Scheme_Simple_Object struct is defined here, instead of in a
00244    private header, so that macros can provide quick access. Of course,
00245    don't access the fields of these structures directly; use the
00246    macros instead. */
00247 
00248 typedef struct Scheme_Object
00249 {
00250   Scheme_Type type; /* Anything that starts with a type field
00251                      can be a Scheme_Object */
00252 
00253   /* For precise GC, the keyex field is used for all object types to
00254      store a hash key extension. The low bit is not used for this
00255      purpose, though. For string, pair, vector, and box values in all
00256      variants of MzScheme, the low bit is set to 1 to indicate that
00257      the object is immutable. Thus, the keyex field is needed even in
00258      non-precise GC mode, so such structures embed
00259      Scheme_Inclhash_Object */
00260 
00261   MZ_HASH_KEY_EX
00262 } Scheme_Object;
00263 
00264   /* See note above on MZ_HASH_KEY_EX. To get the keyex field,
00265      use MZ_OPT_HASH_KEY(iso), where iso is a pointer to a
00266      Scheme_Inclhash_Object */
00267 typedef struct Scheme_Inclhash_Object
00268 {
00269   Scheme_Object so;
00270   MZ_OPT_HASH_KEY_EX
00271 } Scheme_Inclhash_Object;
00272 
00273 typedef struct Scheme_Simple_Object
00274 {
00275   Scheme_Inclhash_Object iso;
00276 
00277   union
00278     {
00279       struct { mzchar *string_val; int tag_val; } char_str_val;
00280       struct { char *string_val; int tag_val; } byte_str_val;
00281       struct { void *ptr1, *ptr2; } two_ptr_val;
00282       struct { int int1; int int2; } two_int_val;
00283       struct { void *ptr; int pint; } ptr_int_val;
00284       struct { void *ptr; long pint; } ptr_long_val;
00285       struct { struct Scheme_Object *car, *cdr; } pair_val;
00286       struct { mzshort len; mzshort *vec; } svector_val;
00287       struct { void *val; Scheme_Object *type; } cptr_val;
00288     } u;
00289 } Scheme_Simple_Object;
00290 
00291 typedef struct Scheme_Object *(*Scheme_Closure_Func)(struct Scheme_Object *);
00292 
00293 /* Scheme_Small_Object is used for several types of MzScheme values: */
00294 typedef struct {
00295   Scheme_Inclhash_Object iso;
00296   union {
00297     mzchar char_val;
00298     Scheme_Object *ptr_value;
00299     long int_val;
00300     Scheme_Object *ptr_val;
00301   } u;
00302 } Scheme_Small_Object;
00303 
00304 /* A floating-point number: */
00305 typedef struct {
00306   Scheme_Object so;
00307   double double_val;
00308 } Scheme_Double;
00309 
00310 #ifdef MZ_USE_SINGLE_FLOATS
00311 typedef struct {
00312   Scheme_Object so;
00313   float float_val;
00314 } Scheme_Float;
00315 #endif
00316 
00317 typedef struct Scheme_Symbol {
00318   Scheme_Inclhash_Object iso; /* 1 in low bit of keyex indicates uninterned */
00319   int len;
00320   char s[4]; /* Really, a number of chars to match `len' */
00321 } Scheme_Symbol;
00322 
00323 typedef struct Scheme_Vector {
00324   Scheme_Inclhash_Object iso; /* 1 in low bit of keyex indicates immutable */
00325   int size;
00326   Scheme_Object *els[1];
00327 } Scheme_Vector;
00328 
00329 typedef struct Scheme_Print_Params Scheme_Print_Params;
00330 typedef void (*Scheme_Type_Printer)(Scheme_Object *v, int for_display, Scheme_Print_Params *pp);
00331 
00332 typedef int (*Scheme_Equal_Proc)(Scheme_Object *obj1, Scheme_Object *obj2, void *cycle_data);
00333 typedef long (*Scheme_Primary_Hash_Proc)(Scheme_Object *obj, long base, void *cycle_data);
00334 typedef long (*Scheme_Secondary_Hash_Proc)(Scheme_Object *obj, void *cycle_data);
00335 
00336 /* This file defines all the built-in types */
00337 #ifdef INCLUDE_WITHOUT_PATHS
00338 # include "stypes.h"
00339 #else
00340 # include "../src/stypes.h"
00341 #endif
00342 
00343 /* This rather elaborate pair of NO-OPS is used to persuade the     */
00344 /* MSVC compiler that we really do want to convert between pointers */
00345 /* and integers. */
00346 
00347 #if defined(_MSC_VER)
00348 # define OBJ_TO_LONG(ptr) ((long)(_W64 long)(ptr))
00349 # define LONG_TO_OBJ(l)   ((Scheme_Object *)(void *)(_W64 long)(long)(l))
00350 #else
00351 # define OBJ_TO_LONG(ptr) ((long)(ptr))
00352 # define LONG_TO_OBJ(l) ((Scheme_Object *)(void *)(long)(l))
00353 #endif
00354 
00355 /* Scheme Objects are always aligned on 2-byte boundaries, so  */
00356 /* words of type Scheme_Object * will always have zero in the  */
00357 /* least significant bit.  Therefore, we can use this bit as a */
00358 /* tag to indicate that the `pointer' isn't really a pointer   */
00359 /* but a 31-bit signed immediate integer. */
00360 
00361 #define SCHEME_INTP(obj)     (OBJ_TO_LONG(obj) & 0x1)
00362 
00363 #define SAME_PTR(a, b) ((a) == (b))
00364 #define NOT_SAME_PTR(a, b) ((a) != (b))
00365 
00366 #define SAME_OBJ(a, b) SAME_PTR(a, b)
00367 #define NOT_SAME_OBJ(a, b) NOT_SAME_PTR(a, b)
00368 
00369 #define SAME_TYPE(a, b) ((Scheme_Type)(a) == (Scheme_Type)(b))
00370 #define NOT_SAME_TYPE(a, b) ((Scheme_Type)(a) != (Scheme_Type)(b))
00371 
00372 # define SCHEME_TYPE(obj)     (SCHEME_INTP(obj)?(Scheme_Type)scheme_integer_type:((Scheme_Object *)(obj))->type)
00373 # define _SCHEME_TYPE(obj) ((obj)->type) /* unsafe version */
00374 
00375 /*========================================================================*/
00376 /*                        basic Scheme predicates                         */
00377 /*========================================================================*/
00378 
00379 #define SCHEME_CHARP(obj)    SAME_TYPE(SCHEME_TYPE(obj), scheme_char_type)
00380 /* SCHEME_INTP defined above */
00381 #define SCHEME_DBLP(obj)     SAME_TYPE(SCHEME_TYPE(obj), scheme_double_type)
00382 #ifdef MZ_USE_SINGLE_FLOATS
00383 # define SCHEME_FLTP(obj)     SAME_TYPE(SCHEME_TYPE(obj), scheme_float_type)
00384 # define SCHEME_FLOATP(obj)     (SCHEME_FLTP(obj) || SCHEME_DBLP(obj))
00385 #else
00386 # define SCHEME_FLTP SCHEME_DBLP
00387 # define SCHEME_FLOATP SCHEME_DBLP
00388 #endif
00389 #define SCHEME_BIGNUMP(obj)     SAME_TYPE(SCHEME_TYPE(obj), scheme_bignum_type)
00390 #define SCHEME_RATIONALP(obj)     SAME_TYPE(SCHEME_TYPE(obj), scheme_rational_type)
00391 #define SCHEME_COMPLEXP(obj)     (!SCHEME_INTP(obj) && ((_SCHEME_TYPE(obj) == scheme_complex_type)))
00392 #define SCHEME_EXACT_INTEGERP(obj)  (SCHEME_INTP(obj) || (_SCHEME_TYPE(obj) == scheme_bignum_type))
00393 #define SCHEME_EXACT_REALP(obj)  (SCHEME_INTP(obj) || (_SCHEME_TYPE(obj) == scheme_bignum_type) || (_SCHEME_TYPE(obj) == scheme_rational_type))
00394 #define SCHEME_REALP(obj)  (SCHEME_INTP(obj) || ((_SCHEME_TYPE(obj) >= scheme_bignum_type) && (_SCHEME_TYPE(obj) < scheme_complex_type)))
00395 #define SCHEME_NUMBERP(obj)  (SCHEME_INTP(obj) || ((_SCHEME_TYPE(obj) >= scheme_bignum_type) && (_SCHEME_TYPE(obj) <= scheme_complex_type)))
00396 
00397 #define SCHEME_CHAR_STRINGP(obj)  SAME_TYPE(SCHEME_TYPE(obj), scheme_char_string_type)
00398 #define SCHEME_MUTABLE_CHAR_STRINGP(obj)  (SCHEME_CHAR_STRINGP(obj) && SCHEME_MUTABLEP(obj))
00399 #define SCHEME_IMMUTABLE_CHAR_STRINGP(obj)  (SCHEME_CHAR_STRINGP(obj) && SCHEME_IMMUTABLEP(obj))
00400 
00401 #define SCHEME_BYTE_STRINGP(obj)  SAME_TYPE(SCHEME_TYPE(obj), scheme_byte_string_type)
00402 #define SCHEME_MUTABLE_BYTE_STRINGP(obj)  (SCHEME_BYTE_STRINGP(obj) && SCHEME_MUTABLEP(obj))
00403 #define SCHEME_IMMUTABLE_BYTE_STRINGP(obj)  (SCHEME_BYTE_STRINGP(obj) && SCHEME_IMMUTABLEP(obj))
00404 
00405 #define SCHEME_PATHP(obj)  SAME_TYPE(SCHEME_TYPE(obj), SCHEME_PLATFORM_PATH_KIND)
00406 #define SCHEME_GENERAL_PATHP(obj)  ((SCHEME_TYPE(obj) >= scheme_unix_path_type) && (SCHEME_TYPE(obj) <= scheme_windows_path_type))
00407   /* A path is guranteed to have the same shape as a byte string */
00408 
00409 #define SCHEME_PATH_STRINGP(x) (SCHEME_CHAR_STRINGP(x) || SCHEME_PATHP(x))
00410 #define SCHEME_PATH_STRING_STR "path or string"
00411 
00412 #define SCHEME_GENERAL_PATH_STRINGP(x) (SCHEME_CHAR_STRINGP(x) || SCHEME_GENERAL_PATHP(x))
00413 #define SCHEME_GENERAL_PATH_STRING_STR "path (for any platform) or string"
00414 
00415 #define SCHEME_SYMBOLP(obj)  SAME_TYPE(SCHEME_TYPE(obj), scheme_symbol_type)
00416 #define SCHEME_KEYWORDP(obj)  SAME_TYPE(SCHEME_TYPE(obj), scheme_keyword_type)
00417 
00418 #define SCHEME_STRSYMP(obj) (SCHEME_CHAR_STRINGP(obj) || SCHEME_SYMBOLP(obj))
00419 
00420 #define SCHEME_BOOLP(obj)    (SAME_OBJ(obj, scheme_true) || SAME_OBJ(obj, scheme_false))
00421 #define SCHEME_FALSEP(obj)     SAME_OBJ((obj), scheme_false)
00422 #define SCHEME_TRUEP(obj)     (!SCHEME_FALSEP(obj))
00423 #define SCHEME_EOFP(obj)     SAME_OBJ((obj), scheme_eof)
00424 #define SCHEME_VOIDP(obj)     SAME_OBJ((obj), scheme_void)
00425 
00426 #define SCHEME_NULLP(obj)    SAME_OBJ(obj, scheme_null)
00427 #define SCHEME_PAIRP(obj)    SAME_TYPE(SCHEME_TYPE(obj), scheme_pair_type)
00428 #define SCHEME_MPAIRP(obj)    SAME_TYPE(SCHEME_TYPE(obj), scheme_mutable_pair_type)
00429 #define SCHEME_MUTABLE_PAIRP(obj)    SCHEME_MPAIRP(obj)
00430 #define SCHEME_LISTP(obj)    (SCHEME_NULLP(obj) || SCHEME_PAIRP(obj))
00431 
00432 #define SCHEME_RPAIRP(obj)    SAME_TYPE(SCHEME_TYPE(obj), scheme_raw_pair_type)
00433 
00434 #define SCHEME_BOXP(obj)     SAME_TYPE(SCHEME_TYPE(obj), scheme_box_type)
00435 #define SCHEME_MUTABLE_BOXP(obj)  (SCHEME_BOXP(obj) && SCHEME_MUTABLEP(obj))
00436 #define SCHEME_IMMUTABLE_BOXP(obj)  (SCHEME_BOXP(obj) && SCHEME_IMMUTABLEP(obj))
00437 
00438 #define SCHEME_BUCKTP(obj) SAME_TYPE(SCHEME_TYPE(obj),scheme_bucket_table_type)
00439 #define SCHEME_HASHTP(obj) SAME_TYPE(SCHEME_TYPE(obj),scheme_hash_table_type)
00440 #define SCHEME_HASHTRP(obj) SAME_TYPE(SCHEME_TYPE(obj),scheme_hash_tree_type)
00441 
00442 #define SCHEME_VECTORP(obj)  SAME_TYPE(SCHEME_TYPE(obj), scheme_vector_type)
00443 #define SCHEME_MUTABLE_VECTORP(obj)  (SCHEME_VECTORP(obj) && SCHEME_MUTABLEP(obj))
00444 #define SCHEME_IMMUTABLE_VECTORP(obj)  (SCHEME_VECTORP(obj) && SCHEME_IMMUTABLEP(obj))
00445 
00446 #define SCHEME_STRUCTP(obj) (SAME_TYPE(SCHEME_TYPE(obj), scheme_structure_type) || SAME_TYPE(SCHEME_TYPE(obj), scheme_proc_struct_type))
00447 #define SCHEME_STRUCT_TYPEP(obj) SAME_TYPE(SCHEME_TYPE(obj), scheme_struct_type_type)
00448 
00449 #define SCHEME_INPORTP(obj)  SAME_TYPE(SCHEME_TYPE(obj), scheme_input_port_type)
00450 #define SCHEME_OUTPORTP(obj) SAME_TYPE(SCHEME_TYPE(obj), scheme_output_port_type)
00451 
00452 #define SCHEME_INPUT_PORTP(obj)  scheme_is_input_port(obj)
00453 #define SCHEME_OUTPUT_PORTP(obj) scheme_is_output_port(obj)
00454 
00455 #define SCHEME_THREADP(obj)   SAME_TYPE(SCHEME_TYPE(obj), scheme_thread_type)
00456 #define SCHEME_CUSTODIANP(obj)   SAME_TYPE(SCHEME_TYPE(obj), scheme_custodian_type)
00457 #define SCHEME_SEMAP(obj)   SAME_TYPE(SCHEME_TYPE(obj), scheme_sema_type)
00458 #define SCHEME_CHANNELP(obj)   SAME_TYPE(SCHEME_TYPE(obj), scheme_channel_type)
00459 #define SCHEME_CHANNEL_PUTP(obj)   SAME_TYPE(SCHEME_TYPE(obj), scheme_channel_put_type)
00460 
00461 #define SCHEME_CONFIGP(obj) SAME_TYPE(SCHEME_TYPE(obj), scheme_config_type)
00462 #define SCHEME_NAMESPACEP(obj) SAME_TYPE(SCHEME_TYPE(obj), scheme_namespace_type)
00463 #define SCHEME_WEAKP(obj) SAME_TYPE(SCHEME_TYPE(obj), scheme_weak_box_type)
00464 
00465 #define SCHEME_STXP(obj) SAME_TYPE(SCHEME_TYPE(obj), scheme_stx_type)
00466 
00467 #define SCHEME_UDPP(obj) SAME_TYPE(SCHEME_TYPE(obj), scheme_udp_type)
00468 #define SCHEME_UDP_EVTP(obj) SAME_TYPE(SCHEME_TYPE(obj), scheme_udp_evt_type)
00469 
00470 #define SCHEME_CPTRP(obj) (SAME_TYPE(SCHEME_TYPE(obj), scheme_cpointer_type) || SAME_TYPE(SCHEME_TYPE(obj), scheme_offset_cpointer_type))
00471 
00472 #define SCHEME_MUTABLEP(obj) (!(MZ_OPT_HASH_KEY((Scheme_Inclhash_Object *)(obj)) & 0x1))
00473 #define SCHEME_IMMUTABLEP(obj) (MZ_OPT_HASH_KEY((Scheme_Inclhash_Object *)(obj)) & 0x1)
00474 
00475 #define GUARANTEE_TYPE(fname, argnum, typepred, typenam)                                \
00476    (typepred (argv [argnum])                                                            \
00477         ? argv [argnum]                                                                 \
00478         : (scheme_wrong_type (fname, typenam, argnum, argc, argv), argv [argnum]))
00479 
00480 #define GUARANTEE_BOOL(fname, argnum)        GUARANTEE_TYPE (fname, argnum, SCHEME_BOOLP, "boolean")
00481 #define GUARANTEE_CHAR(fname, argnum)        GUARANTEE_TYPE (fname, argnum, SCHEME_CHARP, "character")
00482 #define GUARANTEE_INTEGER(fname, argnum)     GUARANTEE_TYPE (fname, argnum, SCHEME_INTP, "integer")
00483 #define GUARANTEE_PAIR(fname, argnum)        GUARANTEE_TYPE (fname, argnum, SCHEME_PAIRP, "pair")
00484 #define GUARANTEE_PROCEDURE(fname, argnum)   GUARANTEE_TYPE (fname, argnum, SCHEME_PROCP, "procedure")
00485 #define GUARANTEE_CHAR_STRING(fname, argnum) GUARANTEE_TYPE (fname, argnum, SCHEME_CHAR_STRINGP, "string")
00486 #define GUARANTEE_STRSYM(fname, argnum)      GUARANTEE_TYPE (fname, argnum, SCHEME_STRSYMP, "string or symbol")
00487 #define GUARANTEE_SYMBOL(fname, argnum)      GUARANTEE_TYPE (fname, argnum, SCHEME_SYMBOLP, "symbol")
00488 
00489 #define SCHEME_UNIX_PATH_KIND scheme_unix_path_type
00490 #define SCHEME_WINDOWS_PATH_KIND scheme_windows_path_type
00491 
00492 #ifdef DOS_FILE_SYSTEM
00493 # define SCHEME_PLATFORM_PATH_KIND SCHEME_WINDOWS_PATH_KIND
00494 #else
00495 # define SCHEME_PLATFORM_PATH_KIND SCHEME_UNIX_PATH_KIND
00496 #endif
00497 
00498 #define SCHEME_PATH_KIND(p) SCHEME_TYPE(p)
00499 
00500 /*========================================================================*/
00501 /*                        basic Scheme accessors                          */
00502 /*========================================================================*/
00503 
00504 #define SCHEME_CHAR_VAL(obj) (((Scheme_Small_Object *)(obj))->u.char_val)
00505 #define SCHEME_INT_VAL(obj)  (OBJ_TO_LONG(obj)>>1)
00506 #define SCHEME_DBL_VAL(obj)  (((Scheme_Double *)(obj))->double_val)
00507 #ifdef MZ_USE_SINGLE_FLOATS
00508 # define SCHEME_FLT_VAL(obj)  (((Scheme_Float *)(obj))->float_val)
00509 # define SCHEME_FLOAT_VAL(obj) (SCHEME_DBLP(obj) ? SCHEME_DBL_VAL(obj) : SCHEME_FLT_VAL(obj))
00510 #else
00511 # define SCHEME_FLT_VAL(x) ((float)(SCHEME_DBL_VAL(x)))
00512 # define SCHEME_FLOAT_VAL SCHEME_DBL_VAL
00513 # define scheme_make_float(x) scheme_make_double((double)x)
00514 #endif
00515 
00516 #define SCHEME_CHAR_STR_VAL(obj)  (((Scheme_Simple_Object *)(obj))->u.char_str_val.string_val)
00517 #define SCHEME_CHAR_STRTAG_VAL(obj)  (((Scheme_Simple_Object *)(obj))->u.char_str_val.tag_val)
00518 #define SCHEME_CHAR_STRLEN_VAL(obj)  (((Scheme_Simple_Object *)(obj))->u.char_str_val.tag_val)
00519 #define SCHEME_BYTE_STR_VAL(obj)  (((Scheme_Simple_Object *)(obj))->u.byte_str_val.string_val)
00520 #define SCHEME_BYTE_STRTAG_VAL(obj)  (((Scheme_Simple_Object *)(obj))->u.byte_str_val.tag_val)
00521 #define SCHEME_BYTE_STRLEN_VAL(obj)  (((Scheme_Simple_Object *)(obj))->u.byte_str_val.tag_val)
00522 #define SCHEME_PATH_VAL(obj)  (((Scheme_Simple_Object *)(obj))->u.byte_str_val.string_val)
00523 #define SCHEME_PATH_LEN(obj)  (((Scheme_Simple_Object *)(obj))->u.byte_str_val.tag_val)
00524 #define SCHEME_SYM_VAL(obj)  (((Scheme_Symbol *)((Scheme_Simple_Object *)(obj)))->s)
00525 #define SCHEME_SYM_LEN(obj)  (((Scheme_Symbol *)((Scheme_Simple_Object *)(obj)))->len)
00526 #define SCHEME_KEYWORD_VAL(obj) SCHEME_SYM_VAL(obj)
00527 #define SCHEME_KEYWORD_LEN(obj) SCHEME_SYM_LEN(obj)
00528 
00529 #define SCHEME_SYMSTR_OFFSET(obj) ((unsigned long)SCHEME_SYM_VAL(obj)-(unsigned long)(obj))
00530 
00531 /* return a `char *' pointing to the string or the symbol name */
00532 #define SCHEME_STRSYM_VAL(obj) (SCHEME_SYMBOLP(obj) ? SCHEME_SYM_VAL(obj) : SCHEME_CHAR_STR_VAL(obj))
00533 
00534 #define SCHEME_BOX_VAL(obj)  (((Scheme_Small_Object *)(obj))->u.ptr_val)
00535 
00536 #define SCHEME_CAR(obj)      (((Scheme_Simple_Object *)(obj))->u.pair_val.car)
00537 #define SCHEME_CDR(obj)      (((Scheme_Simple_Object *)(obj))->u.pair_val.cdr)
00538 
00539 #define SCHEME_CADR(obj)     (SCHEME_CAR (SCHEME_CDR (obj)))
00540 #define SCHEME_CAAR(obj)     (SCHEME_CAR (SCHEME_CAR (obj)))
00541 #define SCHEME_CDDR(obj)     (SCHEME_CDR (SCHEME_CDR (obj)))
00542 
00543 #define SCHEME_MCAR(obj)      (((Scheme_Simple_Object *)(obj))->u.pair_val.car)
00544 #define SCHEME_MCDR(obj)      (((Scheme_Simple_Object *)(obj))->u.pair_val.cdr)
00545 
00546 #define SCHEME_VEC_SIZE(obj) (((Scheme_Vector *)(obj))->size)
00547 #define SCHEME_VEC_ELS(obj)  (((Scheme_Vector *)(obj))->els)
00548 #define SCHEME_VEC_BASE(obj) SCHEME_VEC_ELS(obj)
00549 
00550 #define SCHEME_ENVBOX_VAL(obj)  (*((Scheme_Object **)(obj)))
00551 #define SCHEME_WEAK_BOX_VAL(obj) SCHEME_BOX_VAL(obj)
00552 
00553 #define SCHEME_PTR_VAL(obj)  (((Scheme_Small_Object *)(obj))->u.ptr_val)
00554 #define SCHEME_PTR1_VAL(obj) (((Scheme_Simple_Object *)(obj))->u.two_ptr_val.ptr1)
00555 #define SCHEME_PTR2_VAL(obj) (((Scheme_Simple_Object *)(obj))->u.two_ptr_val.ptr2)
00556 #define SCHEME_IPTR_VAL(obj) (((Scheme_Simple_Object *)(obj))->u.ptr_int_val.ptr)
00557 #define SCHEME_LPTR_VAL(obj) (((Scheme_Simple_Object *)(obj))->u.ptr_long_val.ptr)
00558 #define SCHEME_INT1_VAL(obj) (((Scheme_Simple_Object *)(obj))->u.two_int_val.int1)
00559 #define SCHEME_INT2_VAL(obj) (((Scheme_Simple_Object *)(obj))->u.two_int_val.int2)
00560 #define SCHEME_PINT_VAL(obj) (((Scheme_Simple_Object *)(obj))->u.ptr_int_val.pint)
00561 #define SCHEME_PLONG_VAL(obj) (((Scheme_Simple_Object *)(obj))->u.ptr_long_val.pint)
00562 
00563 typedef struct Scheme_Cptr
00564 {
00565   Scheme_Object so;
00566   void *val;
00567   Scheme_Object *type;
00568 } Scheme_Cptr;
00569 typedef struct Scheme_Offset_Cptr
00570 {
00571   Scheme_Cptr cptr; 
00572   long offset;
00573 } Scheme_Offset_Cptr;
00574 
00575 #define SCHEME_CPTR_VAL(obj) (((Scheme_Cptr *)(obj))->val)
00576 #define SCHEME_CPTR_TYPE(obj) (((Scheme_Cptr *)(obj))->type)
00577 #define SCHEME_CPTR_OFFSET(obj) (SAME_TYPE(_SCHEME_TYPE(obj), scheme_offset_cpointer_type) ? ((Scheme_Offset_Cptr *)obj)->offset : 0)
00578 
00579 #define SCHEME_SET_IMMUTABLE(obj)  ((MZ_OPT_HASH_KEY((Scheme_Inclhash_Object *)(obj)) |= 0x1))
00580 #define SCHEME_SET_CHAR_STRING_IMMUTABLE(obj) SCHEME_SET_IMMUTABLE(obj)
00581 #define SCHEME_SET_BYTE_STRING_IMMUTABLE(obj) SCHEME_SET_IMMUTABLE(obj)
00582 #define SCHEME_SET_VECTOR_IMMUTABLE(obj) SCHEME_SET_IMMUTABLE(obj)
00583 #define SCHEME_SET_BOX_IMMUTABLE(obj) SCHEME_SET_IMMUTABLE(obj)
00584 
00585 /*========================================================================*/
00586 /*               fast basic Scheme constructor macros                     */
00587 /*========================================================================*/
00588 
00589 #define scheme_make_integer(i)    LONG_TO_OBJ ((OBJ_TO_LONG(i) << 1) | 0x1)
00590 #define scheme_make_character(ch) ((((mzchar)ch) < 256) ? scheme_char_constants[(unsigned char)(ch)] : scheme_make_char(ch))
00591 #define scheme_make_ascii_character(ch) scheme_char_constants[(unsigned char)(ch)]
00592 
00593 #define scheme_uchar_find(table, x) (table[(x >> 8) & 0x1FFF][x & 0xFF])
00594 
00595 #define scheme_isblank(x) ((scheme_uchar_find(scheme_uchar_table, x)) & 0x1)
00596 #define scheme_issymbol(x) ((scheme_uchar_find(scheme_uchar_table, x)) & 0x2)
00597 #define scheme_ispunc(x) ((scheme_uchar_find(scheme_uchar_table, x)) & 0x4)
00598 #define scheme_iscontrol(x) ((scheme_uchar_find(scheme_uchar_table, x)) & 0x8)
00599 #define scheme_isspace(x) ((scheme_uchar_find(scheme_uchar_table, x)) & 0x10)
00600 /* #define scheme_isSOMETHING(x) ((scheme_uchar_find(scheme_uchar_table, x)) & 0x20) - not yet used */
00601 #define scheme_isdigit(x) ((scheme_uchar_find(scheme_uchar_table, x)) & 0x40)
00602 #define scheme_isalpha(x) ((scheme_uchar_find(scheme_uchar_table, x)) & 0x80)
00603 #define scheme_istitle(x) ((scheme_uchar_find(scheme_uchar_table, x)) & 0x100)
00604 #define scheme_isupper(x) ((scheme_uchar_find(scheme_uchar_table, x)) & 0x200)
00605 #define scheme_islower(x) ((scheme_uchar_find(scheme_uchar_table, x)) & 0x400)
00606 #define scheme_isgraphic(x) ((scheme_uchar_find(scheme_uchar_table, x)) & 0x800)
00607 #define scheme_iscaseignorable(x) ((scheme_uchar_find(scheme_uchar_table, x)) & 0x1000)
00608 #define scheme_isspecialcasing(x) ((scheme_uchar_find(scheme_uchar_table, x)) & 0x2000)
00609 #define scheme_needs_decompose(x) ((scheme_uchar_find(scheme_uchar_table, x)) & 0x4000)
00610 #define scheme_needs_maybe_compose(x) ((scheme_uchar_find(scheme_uchar_table, x)) & 0x8000)
00611 
00612 #define scheme_iscased(x) ((scheme_uchar_find(scheme_uchar_table, x)) & 0x700)
00613 
00614 #define scheme_toupper(x) (x + scheme_uchar_ups[scheme_uchar_find(scheme_uchar_cases_table, x)])
00615 #define scheme_tolower(x) (x + scheme_uchar_downs[scheme_uchar_find(scheme_uchar_cases_table, x)])
00616 #define scheme_totitle(x) (x + scheme_uchar_titles[scheme_uchar_find(scheme_uchar_cases_table, x)])
00617 #define scheme_tofold(x) (x + scheme_uchar_folds[scheme_uchar_find(scheme_uchar_cases_table, x)])
00618 #define scheme_combining_class(x) (scheme_uchar_combining_classes[scheme_uchar_find(scheme_uchar_cases_table, x)])
00619 
00620 #define scheme_general_category(x) ((scheme_uchar_find(scheme_uchar_cats_table, x)) & 0x1F)
00621 /* Note: 3 bits available in the cats table */
00622 
00623 /*========================================================================*/
00624 /*                          procedure values                              */
00625 /*========================================================================*/
00626 
00627 /* Constants for flags in Scheme_Primitive_[Closed]_Proc.
00628    Do not use them directly. */
00629 #define SCHEME_PRIM_OPT_MASK (1 | 2)
00630 #define SCHEME_PRIM_IS_PRIMITIVE 4
00631 #define SCHEME_PRIM_IS_STRUCT_INDEXED_GETTER 8
00632 #define SCHEME_PRIM_IS_STRUCT_PRED 16
00633 #define SCHEME_PRIM_IS_PARAMETER 32
00634 #define SCHEME_PRIM_IS_STRUCT_OTHER 64
00635 #define SCHEME_PRIM_STRUCT_OTHER_TYPE_MASK (128 | 256)
00636 #define SCHEME_PRIM_IS_MULTI_RESULT 512
00637 #define SCHEME_PRIM_IS_BINARY_INLINED 1024
00638 #define SCHEME_PRIM_IS_USER_PARAMETER 2048
00639 #define SCHEME_PRIM_IS_METHOD 4096
00640 #define SCHEME_PRIM_IS_CLOSURE 8192
00641 #define SCHEME_PRIM_IS_UNARY_INLINED 16384
00642 #define SCHEME_PRIM_IS_NARY_INLINED 32768
00643 
00644 /* Values with SCHEME_PRIM_OPT_MASK, earlier implies later: */
00645 #define SCHEME_PRIM_OPT_FOLDING    3
00646 #define SCHEME_PRIM_OPT_IMMEDIATE  2
00647 #define SCHEME_PRIM_OPT_NONCM      1
00648 
00649 /* Values with SCHEME_PRIM_STRUCT_OTHER_TYPE_MASK */
00650 #define SCHEME_PRIM_STRUCT_TYPE_INDEXLESS_GETTER 0
00651 #define SCHEME_PRIM_STRUCT_TYPE_CONSTR           128
00652 #define SCHEME_PRIM_STRUCT_TYPE_INDEXLESS_SETTER 256
00653 #define SCHEME_PRIM_STRUCT_TYPE_INDEXED_SETTER   (128 | 256)
00654 
00655 #define SCHEME_PRIM_IS_STRUCT_PROC (SCHEME_PRIM_IS_STRUCT_INDEXED_GETTER | SCHEME_PRIM_IS_STRUCT_PRED | SCHEME_PRIM_IS_STRUCT_OTHER)
00656 
00657 #define SCHEME_PRIM_PROC_FLAGS(x) (((Scheme_Prim_Proc_Header *)x)->flags)
00658 
00659 typedef struct Scheme_Object *(Scheme_Prim)(int argc, Scheme_Object *argv[]);
00660 
00661 typedef struct Scheme_Object *(Scheme_Primitive_Closure_Proc)(int argc, struct Scheme_Object *argv[], Scheme_Object *p);
00662 
00663 #define SCHEME_MAX_ARGS 0x3FFFFFFE
00664 
00665 typedef struct {
00666   Scheme_Object so;
00667   unsigned short flags;
00668 } Scheme_Prim_Proc_Header;
00669 
00670 typedef struct {
00671   Scheme_Prim_Proc_Header pp;
00672   Scheme_Primitive_Closure_Proc *prim_val;
00673   const char *name;
00674   mzshort mina;
00675   /* If mina < 0; mina is negated case count minus one for a case-lambda
00676      generated by mzc, where the primitive checks argument arity
00677      itself, and mu.cases is available instead of mu.maxa. */
00678   union {
00679     mzshort *cases;
00680     mzshort maxa;   /* > SCHEME_MAX_ARGS => any number of arguments */
00681   } mu;
00682 } Scheme_Primitive_Proc;
00683 
00684 typedef struct {
00685   Scheme_Primitive_Proc pp;
00686   mzshort minr, maxr;
00687   /* Never combined with a closure */
00688 } Scheme_Prim_W_Result_Arity;
00689 
00690 typedef struct Scheme_Primitive_Closure {
00691   Scheme_Primitive_Proc p;
00692   /* The rest is here only if SCHEME_PRIM_IS_CLOSURE
00693      is set in p.pp.flags. */
00694 #ifdef MZ_PRECISE_GC
00695   mzshort count;
00696 #endif
00697   Scheme_Object *val[1];
00698 } Scheme_Primitive_Closure;
00699 
00700 #define SCHEME_PRIM_CLOSURE_ELS(p) ((Scheme_Primitive_Closure *)p)->val
00701 
00702 /* ------ Old-style primitive closures ------- */
00703 
00704 typedef struct Scheme_Object *(Scheme_Closed_Prim)(void *d, int argc, struct Scheme_Object *argv[]);
00705 
00706 typedef struct {
00707   Scheme_Prim_Proc_Header pp;
00708   Scheme_Closed_Prim *prim_val;
00709   void *data;
00710   const char *name;
00711   mzshort mina, maxa; /* mina == -2 => maxa is negated case count and
00712                      record is a Scheme_Closed_Case_Primitive_Proc */
00713 } Scheme_Closed_Primitive_Proc;
00714 
00715 typedef struct {
00716   Scheme_Closed_Primitive_Proc p;
00717   mzshort *cases;
00718 } Scheme_Closed_Case_Primitive_Proc;
00719 
00720 typedef struct {
00721   Scheme_Closed_Primitive_Proc p;
00722   mzshort minr, maxr;
00723 } Scheme_Closed_Prim_W_Result_Arity;
00724 
00725 /* ------------------------------------------------- */
00726 /*                 mzc closure glue
00727     The following are used by mzc to implement closures.
00728 */
00729 
00730 #define _scheme_fill_prim_closure(rec, cfunc, nm, amin, amax, flgs) \
00731   ((rec)->pp.so.type = scheme_prim_type, \
00732    (rec)->prim_val = cfunc, \
00733    (rec)->name = nm, \
00734    (rec)->mina = amin,        \
00735    (rec)->mu.maxa = (amax == -1 ? SCHEME_MAX_ARGS + 1 : amax), \
00736    (rec)->pp.flags = flgs, \
00737    rec)
00738 
00739 #ifdef MZ_PRECISE_GC
00740 # define _scheme_fill_prim_closure_post(rec, cfunc, nm, amin, amax, flgs, ln) \
00741   ((rec)->count = ln,                                                 \
00742    _scheme_fill_prim_closure(&(rec)->p, cfunc, nm, amin, amax, \
00743                           flgs | SCHEME_PRIM_IS_CLOSURE))
00744 #else
00745 # define _scheme_fill_prim_closure_post(rec, cfunc, nm, amin, amax, flgs, ln) \
00746   _scheme_fill_prim_closure(&(rec)->p, cfunc, nm, amin, amax, flgs)
00747 #endif
00748 
00749 #define _scheme_fill_prim_case_closure(rec, cfunc, nm, ccount, cses, flgs) \
00750   ((rec)->pp.so.type = scheme_prim_type, \
00751    (rec)->prim_val = cfunc, \
00752    (rec)->name = nm, \
00753    (rec)->mina = -(ccount+1), \
00754    (rec)->pp.flags = flgs, \
00755    (rec)->mu.cases = cses, \
00756    rec)
00757 
00758 #ifdef MZ_PRECISE_GC
00759 # define _scheme_fill_prim_case_closure_post(rec, cfunc, nm, ccount, cses, flgs, ln) \
00760   ((rec)->count = ln,                                                 \
00761    _scheme_fill_prim_case_closure(&((rec)->p), cfunc, nm, ccount, cses,      \
00762                               flgs | SCHEME_PRIM_IS_CLOSURE))
00763 #else
00764 # define _scheme_fill_prim_case_closure_post(rec, cfunc, nm, ccount, cses, flgs, ln) \
00765   _scheme_fill_prim_case_closure(&((rec)->p), cfunc, nm, ccount, cses, flgs)
00766 #endif
00767 
00768 /* ------------------------------------------------- */
00769 
00770 #define SCHEME_PROCP(obj)  (!SCHEME_INTP(obj) && ((_SCHEME_TYPE(obj) >= scheme_prim_type) && (_SCHEME_TYPE(obj) <= scheme_native_closure_type)))
00771 #define SCHEME_SYNTAXP(obj)  SAME_TYPE(SCHEME_TYPE(obj), scheme_syntax_compiler_type)
00772 #define SCHEME_PRIMP(obj)    SAME_TYPE(SCHEME_TYPE(obj), scheme_prim_type)
00773 #define SCHEME_CLSD_PRIMP(obj)    SAME_TYPE(SCHEME_TYPE(obj), scheme_closed_prim_type)
00774 #define SCHEME_CONTP(obj)    SAME_TYPE(SCHEME_TYPE(obj), scheme_cont_type)
00775 #define SCHEME_ECONTP(obj)    SAME_TYPE(SCHEME_TYPE(obj), scheme_escaping_cont_type)
00776 #define SCHEME_CONT_MARK_SETP(obj)    SAME_TYPE(SCHEME_TYPE(obj), scheme_cont_mark_set_type)
00777 #define SCHEME_PROC_STRUCTP(obj) SAME_TYPE(SCHEME_TYPE(obj), scheme_proc_struct_type)
00778 #define SCHEME_STRUCT_PROCP(obj) (SCHEME_PRIMP(obj) && (((Scheme_Primitive_Proc *)(obj))->pp.flags & SCHEME_PRIM_IS_STRUCT_PROC))
00779 #define SCHEME_CLOSUREP(obj) (SAME_TYPE(SCHEME_TYPE(obj), scheme_closure_type) || SAME_TYPE(SCHEME_TYPE(obj), scheme_case_closure_type))
00780 
00781 #define SCHEME_PRIM(obj)     (((Scheme_Primitive_Proc *)(obj))->prim_val)
00782 #define SCHEME_CLSD_PRIM(obj) (((Scheme_Closed_Primitive_Proc *)(obj))->prim_val)
00783 #define SCHEME_CLSD_PRIM_DATA(obj) (((Scheme_Closed_Primitive_Proc *)(obj))->data)
00784 #define SCHEME_CLOS_FUNC(obj) ((Scheme_Closure_Func)SCHEME_CAR(obj))
00785 #define SCHEME_CLOS_DATA(obj) SCHEME_CDR(obj)
00786 
00787 /*========================================================================*/
00788 /*                      hash tables and environments                      */
00789 /*========================================================================*/
00790 
00791 typedef struct Scheme_Hash_Table
00792 {
00793   Scheme_Inclhash_Object iso; /* 0x1 flag => marshal as #t (hack for stxobj bytecode) */
00794   int size; /* power of 2 */
00795   int count;
00796   Scheme_Object **keys;
00797   Scheme_Object **vals;
00798   void (*make_hash_indices)(void *v, long *h1, long *h2);
00799   int (*compare)(void *v1, void *v2);
00800   Scheme_Object *mutex;
00801   int mcount; /* number of non-NULL keys, >= count (which is non-NULL vals) */
00802 } Scheme_Hash_Table;
00803 
00804 typedef struct Scheme_Hash_Tree Scheme_Hash_Tree;
00805 
00806 typedef struct Scheme_Bucket
00807 {
00808   Scheme_Object so;
00809   void *val;
00810   char *key;
00811 } Scheme_Bucket;
00812 
00813 typedef struct Scheme_Bucket_Table
00814 {
00815   Scheme_Object so;
00816   int size; /* power of 2 */
00817   int count;
00818   Scheme_Bucket **buckets;
00819   char weak, with_home;
00820   void (*make_hash_indices)(void *v, long *h1, long *h2);
00821   int (*compare)(void *v1, void *v2);
00822   Scheme_Object *mutex;
00823 } Scheme_Bucket_Table;
00824 
00825 /* Hash tablekey types, used with scheme_hash_table */
00826 enum {
00827   SCHEME_hash_string,
00828   SCHEME_hash_ptr,
00829   SCHEME_hash_bound_id,
00830   SCHEME_hash_weak_ptr
00831 };
00832 
00833 typedef struct Scheme_Env Scheme_Env;
00834 
00835 #define SCHEME_VAR_BUCKET(obj) ((Scheme_Bucket *)(obj))
00836 
00837 /*========================================================================*/
00838 /*                    setjmpup (continuation) support                     */
00839 /*========================================================================*/
00840 
00841 #ifdef USE_MZ_SETJMP
00842 typedef long mz_pre_jmp_buf[8];
00843 #else
00844 # define mz_pre_jmp_buf jmp_buf
00845 #endif
00846 
00847 #ifdef MZ_USE_JIT
00848 typedef struct { 
00849   mz_pre_jmp_buf jb; 
00850   unsigned long stack_frame; /* declared as `long' to hide pointer from 3m xform */
00851 } mz_one_jit_jmp_buf;
00852 typedef mz_one_jit_jmp_buf mz_jit_jmp_buf[1];
00853 #else
00854 # define mz_jit_jmp_buf mz_pre_jmp_buf
00855 #endif
00856 
00857 #ifdef MZ_PRECISE_GC
00858 typedef struct {
00859   mz_jit_jmp_buf jb;
00860   long gcvs; /* declared as `long' to hide pointer from 3m xform */
00861   long gcvs_cnt;
00862 } mz_jmp_buf;
00863 #else
00864 # define mz_jmp_buf mz_jit_jmp_buf
00865 #endif
00866 
00867 /* Like setjmp & longjmp, but you can jmp to a deeper stack position */
00868 /* Intialize a Scheme_Jumpup_Buf record before using it */
00869 typedef struct Scheme_Jumpup_Buf {
00870   void *stack_from, *stack_copy;
00871   long stack_size, stack_max_size;
00872   struct Scheme_Cont *cont; /* for sharing continuation tails */
00873   mz_jmp_buf buf;
00874 #ifdef MZ_PRECISE_GC
00875   void *gc_var_stack;
00876   void *external_stack;
00877 #endif
00878 } Scheme_Jumpup_Buf;
00879 
00880 typedef struct Scheme_Jumpup_Buf_Holder {
00881   Scheme_Type type; /* for precise GC only */
00882   Scheme_Jumpup_Buf buf;
00883 } Scheme_Jumpup_Buf_Holder;
00884 
00885 typedef struct Scheme_Continuation_Jump_State {
00886   struct Scheme_Object *jumping_to_continuation;
00887   Scheme_Object *val; /* or **vals */
00888   mzshort num_vals;
00889   short is_kill, is_escape;
00890 } Scheme_Continuation_Jump_State;
00891 
00892 /* A mark position is in odd number, so that it can be
00893    viewed as a pointer (i.e., a fixnum): */
00894 #define MZ_MARK_POS_TYPE long
00895 /* A mark "pointer" is an offset into the stack: */
00896 #define MZ_MARK_STACK_TYPE long
00897 
00898 typedef struct Scheme_Cont_Frame_Data {
00899   MZ_MARK_POS_TYPE cont_mark_pos;
00900   MZ_MARK_STACK_TYPE cont_mark_stack;
00901   void *cache;
00902 } Scheme_Cont_Frame_Data;
00903 
00904 /*========================================================================*/
00905 /*                              threads                                   */
00906 /*========================================================================*/
00907 
00908 typedef void (Scheme_Close_Custodian_Client)(Scheme_Object *o, void *data);
00909 typedef void (*Scheme_Exit_Closer_Func)(Scheme_Object *, Scheme_Close_Custodian_Client *, void *);
00910 typedef Scheme_Object *(*Scheme_Custodian_Extractor)(Scheme_Object *o);
00911 
00912 #ifdef MZ_PRECISE_GC
00913 typedef struct Scheme_Object Scheme_Custodian_Reference;
00914 #else
00915 typedef struct Scheme_Custodian *Scheme_Custodian_Reference;
00916 #endif
00917 
00918 typedef struct Scheme_Custodian Scheme_Custodian;
00919 typedef Scheme_Bucket_Table Scheme_Thread_Cell_Table;
00920 typedef struct Scheme_Config Scheme_Config;
00921 
00922 typedef int (*Scheme_Ready_Fun)(Scheme_Object *o);
00923 typedef void (*Scheme_Needs_Wakeup_Fun)(Scheme_Object *, void *);
00924 typedef Scheme_Object *(*Scheme_Sync_Sema_Fun)(Scheme_Object *, int *repost);
00925 typedef int (*Scheme_Sync_Filter_Fun)(Scheme_Object *);
00926 
00927 /* The Scheme_Thread structure represents a MzScheme thread. */
00928 
00929 typedef struct Scheme_Thread {
00930   Scheme_Object so;
00931 
00932   struct Scheme_Thread *next;
00933   struct Scheme_Thread *prev;
00934 
00935   struct Scheme_Thread_Set *t_set_parent;
00936   Scheme_Object *t_set_next;
00937   Scheme_Object *t_set_prev;
00938 
00939   mz_jmp_buf *error_buf;
00940   Scheme_Continuation_Jump_State cjs;
00941   struct Scheme_Meta_Continuation *decompose_mc; /* set during a jump */
00942 
00943   Scheme_Thread_Cell_Table *cell_values;
00944   Scheme_Config *init_config;
00945 
00946   Scheme_Object *init_break_cell;
00947   int can_break_at_swap;
00948 
00949   Scheme_Object **runstack;
00950   Scheme_Object **runstack_start;
00951   long runstack_size;
00952   struct Scheme_Saved_Stack *runstack_saved;
00953   Scheme_Object **runstack_tmp_keep;
00954 
00955   Scheme_Object **spare_runstack;   /* in case of bouncing, we keep a recently
00956                                        released runstack; it's dropped on GC, though */
00957   long spare_runstack_size;
00958 
00959   struct Scheme_Thread **runstack_owner;
00960   struct Scheme_Saved_Stack *runstack_swapped;
00961 
00962   MZ_MARK_POS_TYPE cont_mark_pos;     /* depth of the continuation chain */
00963   MZ_MARK_STACK_TYPE cont_mark_stack; /* current mark stack position */
00964   struct Scheme_Cont_Mark **cont_mark_stack_segments;
00965   int cont_mark_seg_count;
00966   int cont_mark_stack_bottom; /* for restored delimited continuations */
00967   int cont_mark_pos_bottom;   /* for splicing cont marks in meta continuations */
00968 
00969   struct Scheme_Thread **cont_mark_stack_owner;
00970   struct Scheme_Cont_Mark *cont_mark_stack_swapped;
00971 
00972   struct Scheme_Prompt *meta_prompt; /* a pseudo-prompt */
00973   
00974   struct Scheme_Meta_Continuation *meta_continuation;
00975 
00976   long engine_weight;
00977 
00978   void *stack_start; /* This is the C stack base of the thread, which 
00979                         corresponds to the starting stack address for
00980                         paging out the thread, and in 3m corresponds to
00981                         the starting stack address for GC marking. In non-3m,
00982                         it can be 0, which means that the deepest (non-main)
00983                         thread starting address should be used. This value will
00984                         change when a continuation is applied under a prompt, 
00985                         and it will be changed on stack overflow. */
00986   void *stack_end; /* The end of the C stack, for determine stack overflow.
00987                       Currently, this is the same for all threads. */
00988 
00989   Scheme_Jumpup_Buf jmpup_buf; /* For jumping back to this thread */
00990 
00991   struct Scheme_Dynamic_Wind *dw;
00992   int next_meta;  /* amount to move forward in the meta-continuaiton chain, starting with dw */
00993 
00994   int running;
00995   Scheme_Object *suspended_box; /* contains pointer to thread when it's suspended */
00996   Scheme_Object *resumed_box;   /* contains pointer to thread when it's resumed */
00997   Scheme_Object *dead_box;      /* contains non-zero when the thread is dead */
00998   Scheme_Object *running_box;   /* contains pointer to thread when it's running */
00999 
01000   struct Scheme_Thread *nester, *nestee;
01001 
01002   double sleep_end; /* blocker has starting sleep time */
01003   int block_descriptor;
01004   Scheme_Object *blocker; /* semaphore or port */
01005   Scheme_Ready_Fun block_check;
01006   Scheme_Needs_Wakeup_Fun block_needs_wakeup;
01007   char ran_some;
01008   char suspend_to_kill;
01009 
01010   struct Scheme_Thread *return_marks_to;
01011   Scheme_Object *returned_marks;
01012 
01013   struct Scheme_Overflow *overflow;
01014 
01015   struct Scheme_Comp_Env *current_local_env;
01016   Scheme_Object *current_local_mark;
01017   Scheme_Object *current_local_name;
01018   Scheme_Object *current_local_certs;
01019   Scheme_Object *current_local_modidx;
01020   Scheme_Env *current_local_menv;
01021   Scheme_Object *current_local_bindings;
01022   int current_phase_shift;
01023 
01024   struct Scheme_Marshal_Tables *current_mt;
01025 
01026   Scheme_Object *constant_folding; /* compiler hack */
01027   Scheme_Object *reading_delayed; /* reader hack */
01028 
01029   Scheme_Object *(*overflow_k)(void);
01030   Scheme_Object *overflow_reply;
01031 
01032    /* content of tail_buffer is zeroed on GC, unless
01033       runstack_tmp_keep is set to tail_buffer */
01034   Scheme_Object **tail_buffer;
01035   int tail_buffer_size;
01036 
01037   /* values_buffer is used to avoid allocating for `values'
01038      calls. When ku.multiple.array is not the same as
01039      values_buffer, then it can be zeroed at GC points. */
01040   Scheme_Object **values_buffer;
01041   int values_buffer_size;
01042 
01043   struct { /* used to be a union, but that confuses MZ_PRECISE_GC */
01044     struct {
01045       Scheme_Object *wait_expr;
01046     } eval;
01047     struct {
01048       Scheme_Object *tail_rator;
01049       Scheme_Object **tail_rands;
01050       long tail_num_rands;
01051     } apply;
01052     struct {
01053       Scheme_Object **array;
01054       long count;
01055     } multiple;
01056     struct {
01057       void *p1, *p2, *p3, *p4, *p5;
01058       long i1, i2, i3, i4;
01059     } k;
01060   } ku;
01061 
01062   short suspend_break;
01063   short external_break;
01064 
01065   Scheme_Simple_Object *list_stack;
01066   int list_stack_pos;
01067 
01068   /* MzScheme client can use: */
01069   void (*on_kill)(struct Scheme_Thread *p);
01070   void *kill_data;
01071 
01072   /* MzScheme use only: */
01073   void (*private_on_kill)(void *);
01074   void *private_kill_data;
01075   void **private_kill_next; /* array of three pointers */
01076 
01077   void **user_tls;
01078   int user_tls_size;
01079 
01080   /* save thread-specific GMP state: */
01081   long gmp_tls[6];
01082   void *gmp_tls_data;
01083 
01084   long accum_process_msec;
01085   long current_start_process_msec;
01086 
01087   struct Scheme_Thread_Custodian_Hop *mr_hop;
01088   Scheme_Custodian_Reference *mref;
01089   Scheme_Object *extra_mrefs; /* More owning custodians */
01090   Scheme_Object *transitive_resumes; /* A hash table of running-boxes */
01091 
01092   Scheme_Object *name;
01093 
01094   Scheme_Object *mbox_first;
01095   Scheme_Object *mbox_last;
01096   Scheme_Object *mbox_sema;
01097 
01098 #ifdef MZ_PRECISE_GC
01099   struct GC_Thread_Info *gc_info; /* managed by the GC */
01100 #endif
01101 } Scheme_Thread;
01102 
01103 #if !SCHEME_DIRECT_EMBEDDED
01104 # ifdef LINK_EXTENSIONS_BY_TABLE
01105 #  define scheme_current_thread (*scheme_current_thread_ptr)
01106 # endif
01107 #endif
01108 
01109 typedef void (*Scheme_Kill_Action_Func)(void *);
01110 
01111 #define ESCAPE_BLOCK(return_code) \
01112     thread = scheme_get_current_thread(); \
01113     savebuf = thread->error_buf; \
01114     thread->error_buf = &newbuf; \
01115     thread = NULL; \
01116     if (scheme_setjmp(newbuf)) \
01117     { \
01118       thread = scheme_get_current_thread(); \
01119       thread->error_buf = savebuf; \
01120       scheme_clear_escape(); \
01121       return return_code; \
01122     }
01123 
01124 # define BEGIN_ESCAPEABLE(func, data) \
01125     { mz_jmp_buf * volatile savebuf, newbuf; \
01126       Scheme_Thread *thread; \
01127       thread = scheme_get_current_thread(); \
01128       scheme_push_kill_action((Scheme_Kill_Action_Func)func, (void *)data); \
01129       savebuf = thread->error_buf; \
01130       thread->error_buf = &newbuf; \
01131       thread = NULL; \
01132       if (scheme_setjmp(newbuf)) { \
01133         scheme_pop_kill_action(); \
01134         func(data); \
01135         scheme_longjmp(*savebuf, 1); \
01136       } else {
01137 # define END_ESCAPEABLE() \
01138       thread = scheme_get_current_thread(); \
01139       scheme_pop_kill_action(); \
01140       thread->error_buf = savebuf; \
01141       thread = NULL; } }
01142 
01143 
01144 /*========================================================================*/
01145 /*                             parameters                                 */
01146 /*========================================================================*/
01147 
01148 enum {
01149   MZCONFIG_ENV,
01150   MZCONFIG_INPUT_PORT,
01151   MZCONFIG_OUTPUT_PORT,
01152   MZCONFIG_ERROR_PORT,
01153 
01154   MZCONFIG_ERROR_DISPLAY_HANDLER,
01155   MZCONFIG_ERROR_PRINT_VALUE_HANDLER,
01156 
01157   MZCONFIG_EXIT_HANDLER,
01158 
01159   MZCONFIG_INIT_EXN_HANDLER,
01160 
01161   MZCONFIG_EVAL_HANDLER,
01162   MZCONFIG_COMPILE_HANDLER,
01163   MZCONFIG_LOAD_HANDLER,
01164   MZCONFIG_LOAD_COMPILED_HANDLER,
01165 
01166   MZCONFIG_PRINT_HANDLER,
01167   MZCONFIG_PROMPT_READ_HANDLER,
01168 
01169   MZCONFIG_READTABLE,
01170   MZCONFIG_READER_GUARD,
01171 
01172   MZCONFIG_CAN_READ_GRAPH,
01173   MZCONFIG_CAN_READ_COMPILED,
01174   MZCONFIG_CAN_READ_BOX,
01175   MZCONFIG_CAN_READ_PIPE_QUOTE,
01176   MZCONFIG_CAN_READ_DOT,
01177   MZCONFIG_CAN_READ_INFIX_DOT,
01178   MZCONFIG_CAN_READ_QUASI,
01179   MZCONFIG_CAN_READ_READER,
01180   MZCONFIG_READ_DECIMAL_INEXACT,
01181   
01182   MZCONFIG_PRINT_GRAPH,
01183   MZCONFIG_PRINT_STRUCT,
01184   MZCONFIG_PRINT_BOX,
01185   MZCONFIG_PRINT_VEC_SHORTHAND,
01186   MZCONFIG_PRINT_HASH_TABLE,
01187   MZCONFIG_PRINT_UNREADABLE,
01188   MZCONFIG_PRINT_PAIR_CURLY,
01189   MZCONFIG_PRINT_MPAIR_CURLY,
01190 
01191   MZCONFIG_CASE_SENS,
01192   MZCONFIG_SQUARE_BRACKETS_ARE_PARENS,
01193   MZCONFIG_CURLY_BRACES_ARE_PARENS,
01194 
01195   MZCONFIG_HONU_MODE,
01196 
01197   MZCONFIG_ERROR_PRINT_WIDTH,
01198   MZCONFIG_ERROR_PRINT_CONTEXT_LENGTH,
01199 
01200   MZCONFIG_ERROR_ESCAPE_HANDLER,
01201 
01202   MZCONFIG_ALLOW_SET_UNDEFINED,
01203   MZCONFIG_COMPILE_MODULE_CONSTS,
01204   MZCONFIG_USE_JIT,
01205   MZCONFIG_DISALLOW_INLINE,
01206 
01207   MZCONFIG_CUSTODIAN,
01208   MZCONFIG_INSPECTOR,
01209   MZCONFIG_CODE_INSPECTOR,
01210 
01211   MZCONFIG_USE_COMPILED_KIND,
01212   MZCONFIG_USE_USER_PATHS,
01213 
01214   MZCONFIG_LOAD_DIRECTORY,
01215   MZCONFIG_WRITE_DIRECTORY,
01216 
01217   MZCONFIG_COLLECTION_PATHS,
01218 
01219   MZCONFIG_PORT_PRINT_HANDLER,
01220 
01221   MZCONFIG_LOAD_EXTENSION_HANDLER,
01222 
01223   MZCONFIG_CURRENT_DIRECTORY,
01224 
01225   MZCONFIG_RANDOM_STATE,
01226 
01227   MZCONFIG_CURRENT_MODULE_RESOLVER,
01228   MZCONFIG_CURRENT_MODULE_NAME,
01229 
01230   MZCONFIG_ERROR_PRINT_SRCLOC,
01231 
01232   MZCONFIG_CMDLINE_ARGS,
01233 
01234   MZCONFIG_LOCALE,
01235 
01236   MZCONFIG_SECURITY_GUARD,
01237 
01238   MZCONFIG_PORT_COUNT_LINES,
01239 
01240   MZCONFIG_SCHEDULER_RANDOM_STATE,
01241 
01242   MZCONFIG_THREAD_SET,
01243   MZCONFIG_THREAD_INIT_STACK_SIZE,
01244 
01245   MZCONFIG_LOAD_DELAY_ENABLED,
01246   MZCONFIG_DELAY_LOAD_INFO,
01247 
01248   MZCONFIG_EXPAND_OBSERVE,
01249 
01250   MZCONFIG_LOGGER,
01251 
01252   __MZCONFIG_BUILTIN_COUNT__
01253 };
01254 
01255 /*========================================================================*/
01256 /*                                  ports                                 */
01257 /*========================================================================*/
01258 
01259 typedef struct Scheme_Input_Port Scheme_Input_Port;
01260 typedef struct Scheme_Output_Port Scheme_Output_Port;
01261 typedef struct Scheme_Port Scheme_Port;
01262 
01263 typedef long (*Scheme_Get_String_Fun)(Scheme_Input_Port *port,
01264                                   char *buffer, long offset, long size,
01265                                   int nonblock, Scheme_Object *unless);
01266 typedef long (*Scheme_Peek_String_Fun)(Scheme_Input_Port *port,
01267                                    char *buffer, long offset, long size,
01268                                    Scheme_Object *skip,
01269                                    int nonblock, Scheme_Object *unless);
01270 typedef Scheme_Object *(*Scheme_Progress_Evt_Fun)(Scheme_Input_Port *port);
01271 typedef int (*Scheme_Peeked_Read_Fun)(Scheme_Input_Port *port,
01272                                   long amount,
01273                                   Scheme_Object *unless_evt,
01274                                   Scheme_Object *target_ch);
01275 typedef int (*Scheme_In_Ready_Fun)(Scheme_Input_Port *port);
01276 typedef void (*Scheme_Close_Input_Fun)(Scheme_Input_Port *port);
01277 typedef void (*Scheme_Need_Wakeup_Input_Fun)(Scheme_Input_Port *, void *);
01278 
01279 typedef Scheme_Object *(*Scheme_Location_Fun)(Scheme_Port *);
01280 typedef void (*Scheme_Count_Lines_Fun)(Scheme_Port *);
01281 typedef int (*Scheme_Buffer_Mode_Fun)(Scheme_Port *, int m);
01282 
01283 typedef Scheme_Object *(*Scheme_Write_String_Evt_Fun)(Scheme_Output_Port *,
01284                                                 const char *str, long offset, long size);
01285 typedef long (*Scheme_Write_String_Fun)(Scheme_Output_Port *,
01286                                    const char *str, long offset, long size,
01287                                    int rarely_block, int enable_break);
01288 typedef int (*Scheme_Out_Ready_Fun)(Scheme_Output_Port *port);
01289 typedef void (*Scheme_Close_Output_Fun)(Scheme_Output_Port *port);
01290 typedef void (*Scheme_Need_Wakeup_Output_Fun)(Scheme_Output_Port *, void *);
01291 typedef Scheme_Object *(*Scheme_Write_Special_Evt_Fun)(Scheme_Output_Port *, Scheme_Object *);
01292 typedef int (*Scheme_Write_Special_Fun)(Scheme_Output_Port *, Scheme_Object *,
01293                                    int nonblock);
01294 
01295 struct Scheme_Port
01296 {
01297   Scheme_Object so;
01298   char count_lines, was_cr;
01299   long position, readpos, lineNumber, charsSinceNewline;
01300   long column, oldColumn; /* column tracking with one tab/newline ungetc */
01301   int utf8state;
01302   Scheme_Location_Fun location_fun;
01303   Scheme_Count_Lines_Fun count_lines_fun;
01304   Scheme_Buffer_Mode_Fun buffer_mode_fun;
01305 };
01306 
01307 struct Scheme_Input_Port
01308 {
01309   struct Scheme_Port p;
01310   char closed, pending_eof;
01311   Scheme_Object *sub_type;
01312   Scheme_Custodian_Reference *mref;
01313   void *port_data;
01314   Scheme_Get_String_Fun get_string_fun;
01315   Scheme_Peek_String_Fun peek_string_fun;
01316   Scheme_Progress_Evt_Fun progress_evt_fun;
01317   Scheme_Peeked_Read_Fun peeked_read_fun;
01318   Scheme_In_Ready_Fun byte_ready_fun;
01319   Scheme_Close_Input_Fun close_fun;
01320   Scheme_Need_Wakeup_Input_Fun need_wakeup_fun;
01321   Scheme_Object *read_handler;
01322   Scheme_Object *name;
01323   Scheme_Object *peeked_read, *peeked_write;
01324   Scheme_Object *progress_evt, *input_lock, *input_giveup, *input_extras, *input_extras_ready;
01325   unsigned char ungotten[24];
01326   int ungotten_count;
01327   Scheme_Object *special, *ungotten_special;
01328   Scheme_Object *unless, *unless_cache;
01329   struct Scheme_Output_Port *output_half;
01330 };
01331 
01332 struct Scheme_Output_Port
01333 {
01334   struct Scheme_Port p;
01335   short closed;
01336   Scheme_Object *sub_type;
01337   Scheme_Custodian_Reference *mref;
01338   void *port_data;
01339   Scheme_Write_String_Evt_Fun write_string_evt_fun;
01340   Scheme_Write_String_Fun write_string_fun;
01341   Scheme_Close_Output_Fun close_fun;
01342   Scheme_Out_Ready_Fun ready_fun;
01343   Scheme_Need_Wakeup_Output_Fun need_wakeup_fun;
01344   Scheme_Write_Special_Evt_Fun write_special_evt_fun;
01345   Scheme_Write_Special_Fun write_special_fun;
01346   long pos;
01347   Scheme_Object *name;
01348   Scheme_Object *display_handler;
01349   Scheme_Object *write_handler;
01350   Scheme_Object *print_handler;
01351   struct Scheme_Input_Port *input_half;
01352 };
01353 
01354 #define SCHEME_INPORT_VAL(obj) (((Scheme_Input_Port *)(obj))->port_data)
01355 #define SCHEME_OUTPORT_VAL(obj) (((Scheme_Output_Port *)(obj))->port_data)
01356 #define SCHEME_IPORT_NAME(obj) (((Scheme_Input_Port *)obj)->name)
01357 
01358 #define SCHEME_SPECIAL (-2)
01359 #define SCHEME_UNLESS_READY (-3)
01360 
01361 /*========================================================================*/
01362 /*                              exceptions                                */
01363 /*========================================================================*/
01364 
01365 /* This file includes the MZEXN constants */
01366 #ifdef INCLUDE_WITHOUT_PATHS
01367 # include "schexn.h"
01368 #else
01369 # include "../src/schexn.h"
01370 #endif
01371 
01372 #define SCHEME_LOG_FATAL   1
01373 #define SCHEME_LOG_ERROR   2
01374 #define SCHEME_LOG_WARNING 3
01375 #define SCHEME_LOG_INFO    4
01376 #define SCHEME_LOG_DEBUG   5
01377 
01378 typedef struct Scheme_Logger Scheme_Logger;
01379 
01380 /*========================================================================*/
01381 /*                               security                                 */
01382 /*========================================================================*/
01383 
01384 #define SCHEME_GUARD_FILE_READ    0x1
01385 #define SCHEME_GUARD_FILE_WRITE   0x2
01386 #define SCHEME_GUARD_FILE_EXECUTE 0x4
01387 #define SCHEME_GUARD_FILE_DELETE  0x8
01388 #define SCHEME_GUARD_FILE_EXISTS  0x10
01389 
01390 /*========================================================================*/
01391 /*                               modules                                  */
01392 /*========================================================================*/
01393 
01394 typedef void (*Scheme_Invoke_Proc)(Scheme_Env *env, long phase_shift,
01395                                Scheme_Object *self_modidx, void *data);
01396 
01397 /*========================================================================*/
01398 /*                               evaluation                               */
01399 /*========================================================================*/
01400 
01401 /* Exploit the fact that these should never be dereferenced: */
01402 #ifndef FIRST_TWO_BYTES_ARE_LEGAL_ADDRESSES
01403 # define MZ_EVAL_WAITING_CONSTANT ((Scheme_Object *)0x2)
01404 # define MZ_APPLY_WAITING_CONSTANT ((Scheme_Object *)0x4)
01405 # define MZ_MULTIPLE_VALUES_CONSTANT ((Scheme_Object *)0x6)
01406 #endif
01407 
01408 #ifdef MZ_EVAL_WAITING_CONSTANT
01409 # define SCHEME_EVAL_WAITING MZ_EVAL_WAITING_CONSTANT
01410 # define SCHEME_TAIL_CALL_WAITING MZ_APPLY_WAITING_CONSTANT
01411 # define SCHEME_MULTIPLE_VALUES MZ_MULTIPLE_VALUES_CONSTANT
01412 #else
01413 # define SCHEME_TAIL_CALL_WAITING scheme_tail_call_waiting
01414 # define SCHEME_EVAL_WAITING scheme_eval_waiting
01415 # define SCHEME_MULTIPLE_VALUES scheme_multiple_values
01416 #endif
01417 
01418 #define SCHEME_ASSERT(expr,msg) ((expr) ? 1 : (scheme_signal_error(msg), 0))
01419 
01420 #ifndef MZ_USE_PLACES
01421 #define scheme_eval_wait_expr (scheme_current_thread->ku.eval.wait_expr)
01422 #define scheme_tail_rator (scheme_current_thread->ku.apply.tail_rator)
01423 #define scheme_tail_num_rands (scheme_current_thread->ku.apply.tail_num_rands)
01424 #define scheme_tail_rands (scheme_current_thread->ku.apply.tail_rands)
01425 #define scheme_overflow_reply (scheme_current_thread->overflow_reply)
01426 
01427 #define scheme_error_buf *(scheme_current_thread->error_buf)
01428 #define scheme_jumping_to_continuation (scheme_current_thread->cjs.jumping_to_continuation)
01429 
01430 #define scheme_multiple_count (scheme_current_thread->ku.multiple.count)
01431 #define scheme_multiple_array (scheme_current_thread->ku.multiple.array)
01432 #endif
01433 
01434 #define scheme_setjmpup(b, base, s) scheme_setjmpup_relative(b, base, s, NULL)
01435 
01436 #define scheme_do_eval_w_thread(r,n,e,f,p) scheme_do_eval(r,n,e,f)
01437 #define scheme_apply_wp(r,n,a,p) scheme_apply(r,n,a)
01438 #define scheme_apply_multi_wp(r,n,a,p) scheme_apply_multi(r,n,a)
01439 #define scheme_apply_eb_wp(r,n,a,p) scheme_apply_eb(r,n,a)
01440 #define scheme_apply_multi_eb_wp(r,n,a,p) scheme_apply_multi_eb(r,n,a)
01441 
01442 #define _scheme_apply(r,n,rs) scheme_do_eval(r,n,rs,1)
01443 #define _scheme_apply_multi(r,n,rs) scheme_do_eval(r,n,rs,-1)
01444 #define _scheme_apply_wp(r,n,rs,p) scheme_do_eval_w_thread(r,n,rs,1,p)
01445 #define _scheme_apply_multi_wp(r,n,rs,p) scheme_do_eval_w_thread(r,n,rs,-1,p)
01446 #define _scheme_tail_apply scheme_tail_apply
01447 #define _scheme_tail_apply_wp scheme_tail_apply_wp
01448 
01449 #define _scheme_tail_eval scheme_tail_eval
01450 #define _scheme_tail_eval_wp scheme_tail_eval_wp
01451 
01452 #define _scheme_direct_apply_primitive_multi(prim, argc, argv) \
01453   (((Scheme_Primitive_Proc *)prim)->prim_val(argc, argv, prim))
01454 #define _scheme_direct_apply_primitive(prim, argc, argv) \
01455   scheme_check_one_value(_scheme_direct_apply_primitive_multi(prim, argc, argv))
01456 #define _scheme_direct_apply_primitive_closure_multi(prim, argc, argv) \
01457   _scheme_direct_apply_primitive_multi(prim, argc, argv)
01458 #define _scheme_direct_apply_primitive_closure(prim, argc, argv) \
01459   _scheme_direct_apply_primitive(prim, argc, argv)
01460 #define _scheme_direct_apply_closed_primitive_multi(prim, argc, argv) \
01461     (((Scheme_Closed_Primitive_Proc *)prim)->prim_val(((Scheme_Closed_Primitive_Proc *)prim)->data, argc, argv))
01462 #define _scheme_direct_apply_closed_primitive(prim, argc, argv) \
01463     scheme_check_one_value(_scheme_direct_apply_closed_primitive_multi(prim, argc, argv))
01464 
01465 #define _scheme_force_value(v) ((v == SCHEME_TAIL_CALL_WAITING) ? scheme_force_value(v) : v)
01466 
01467 #define scheme_tail_apply_buffer_wp(n, p) ((p)->tail_buffer)
01468 #define scheme_tail_apply_buffer(n) \
01469 { \
01470   Scheme_Thread *thread; \
01471   thread = scheme_get_current_thread(); \
01472   scheme_tail_apply_buffer_wp(n, thread);\
01473 }
01474 
01475 #define _scheme_tail_apply_no_copy_wp_tcw(f, n, args, p, tcw) (p->ku.apply.tail_rator = f, p->ku.apply.tail_rands = args, p->ku.apply.tail_num_rands = n, tcw)
01476 #define _scheme_tail_apply_no_copy_wp(f, n, args, p) _scheme_tail_apply_no_copy_wp_tcw(f, n, args, p, SCHEME_TAIL_CALL_WAITING)
01477 #define _scheme_tail_apply_no_copy(f, n, args) \
01478 { \
01479   Scheme_Thread *thread; \
01480   thread = scheme_get_current_thread(); \
01481   _scheme_tail_apply_no_copy_wp(f, n, args, thread) \
01482 }
01483 
01484 #define scheme_thread_block_w_thread(t,p) scheme_thread_block(t)
01485 
01486 #if !SCHEME_DIRECT_EMBEDDED
01487 # ifdef LINK_EXTENSIONS_BY_TABLE
01488 #  define scheme_fuel_counter (*scheme_fuel_counter_ptr)
01489 # endif
01490 #else
01491 MZ_EXTERN volatile int scheme_fuel_counter;
01492 #endif
01493 
01494 #ifdef FUEL_AUTODECEREMENTS
01495 # define DECREMENT_FUEL(f, p) (f)
01496 #else
01497 # define DECREMENT_FUEL(f, p) (f -= (p))
01498 #endif
01499 
01500 #define SCHEME_USE_FUEL(n) \
01501   { if (DECREMENT_FUEL(scheme_fuel_counter, n) <= 0) { scheme_out_of_fuel(); }}
01502 
01503 #if SCHEME_DIRECT_EMBEDDED
01504 MZ_EXTERN Scheme_Object *scheme_eval_waiting;
01505 #define scheme_tail_eval(obj) \
01506  (scheme_eval_wait_expr = obj, SCHEME_EVAL_WAITING)
01507 #endif
01508 
01509 #define scheme_break_waiting(p) (p->external_break)
01510 
01511 #ifndef USE_MZ_SETJMP
01512 # ifdef USE_UNDERSCORE_SETJMP
01513 #  define scheme_mz_longjmp(b, v) _longjmp(b, v)
01514 #  define scheme_mz_setjmp(b) _setjmp(b)
01515 # else
01516 #  define scheme_mz_longjmp(b, v) longjmp(b, v)
01517 #  define scheme_mz_setjmp(b) setjmp(b)
01518 # endif
01519 #endif
01520 
01521 #ifdef MZ_USE_JIT
01522 MZ_EXTERN void scheme_jit_longjmp(mz_jit_jmp_buf b, int v);
01523 MZ_EXTERN void scheme_jit_setjmp_prepare(mz_jit_jmp_buf b);
01524 # define scheme_jit_setjmp(b) (scheme_jit_setjmp_prepare(b), scheme_mz_setjmp((b)->jb))
01525 #else
01526 # define scheme_jit_longjmp(b, v) scheme_mz_longjmp(b, v) 
01527 # define scheme_jit_setjmp(b) scheme_mz_setjmp(b) 
01528 #endif
01529 
01530 #ifdef MZ_PRECISE_GC
01531 /* Need to make sure that a __gc_var_stack__ is always available where
01532    setjmp & longjmp are used. */
01533 # define scheme_longjmp(b, v) (((long *)(void*)((b).gcvs))[1] = (b).gcvs_cnt, \
01534                                GC_variable_stack = (void **)(void*)(b).gcvs, \
01535                                scheme_jit_longjmp((b).jb, v))
01536 # define scheme_setjmp(b)     ((b).gcvs = (long)__gc_var_stack__, \
01537                                (b).gcvs_cnt = (long)(__gc_var_stack__[1]), \
01538                                scheme_jit_setjmp((b).jb))
01539 #else
01540 # define scheme_longjmp(b, v) scheme_jit_longjmp(b, v)
01541 # define scheme_setjmp(b) scheme_jit_setjmp(b)
01542 #endif
01543 
01544 /*========================================================================*/
01545 /*                      memory management macros                          */
01546 /*========================================================================*/
01547 
01548 /* Allocation */
01549 #define scheme_alloc_object() \
01550    ((Scheme_Object *) scheme_malloc_small_tagged(sizeof(Scheme_Simple_Object)))
01551 #define scheme_alloc_small_object() \
01552    ((Scheme_Object *) scheme_malloc_small_tagged(sizeof(Scheme_Small_Object)))
01553 #define scheme_alloc_stubborn_object() \
01554    ((Scheme_Object *) scheme_malloc_stubborn_tagged(sizeof(Scheme_Simple_Object)))
01555 #define scheme_alloc_stubborn_small_object() \
01556    ((Scheme_Object *) scheme_malloc_stubborn_tagged(sizeof(Scheme_Small_Object)))
01557 #define scheme_alloc_eternal_object() \
01558    ((Scheme_Object *) scheme_malloc_eternal_tagged(sizeof(Scheme_Simple_Object)))
01559 #define scheme_alloc_eternal_small_object() \
01560    ((Scheme_Object *) scheme_malloc_eternal_tagged(sizeof(Scheme_Small_Object)))
01561 
01562 #ifdef SCHEME_NO_GC
01563 void *scheme_malloc(size_t size);
01564 # define scheme_malloc_atomic scheme_malloc
01565 # define scheme_malloc_stubborn scheme_malloc
01566 # define scheme_malloc_uncollectable scheme_malloc
01567 #else
01568 # define scheme_malloc GC_malloc
01569 # define scheme_malloc_atomic GC_malloc_atomic
01570 # ifdef MZ_PRECISE_GC
01571 #  define scheme_malloc_stubborn scheme_malloc
01572 # else
01573 #  define scheme_malloc_stubborn GC_malloc_stubborn
01574 #  define scheme_malloc_uncollectable GC_malloc_uncollectable
01575 # endif
01576 #endif
01577 
01578 #ifdef USE_MEMORY_TRACING
01579 # define USE_TAGGED_ALLOCATION
01580 # define MEMORY_COUNTING_ON
01581 #endif
01582 
01583 #ifdef MZ_PRECISE_GC
01584 # ifndef GC2_EXTERN
01585 #  define GC2_EXTERN MZ_EXTERN
01586 # endif
01587 # ifdef INCLUDE_WITHOUT_PATHS
01588 #  if !SCHEME_DIRECT_EMBEDDED
01589 #   define GC2_JUST_MACROS_AND_TYPEDEFS
01590 #  endif
01591 #  include "schemegc2.h"
01592 # else
01593 #  include "../gc2/gc2.h"
01594 # endif
01595 # define scheme_malloc_tagged GC_malloc_one_tagged
01596 # define scheme_malloc_small_tagged(s) GC_malloc_one_small_tagged(gcWORDS_TO_BYTES(gcBYTES_TO_WORDS(s)))
01597 # define scheme_malloc_small_dirty_tagged(s) GC_malloc_one_small_dirty_tagged(gcWORDS_TO_BYTES(gcBYTES_TO_WORDS(s)))
01598 # define scheme_malloc_small_atomic_tagged(s) GC_malloc_small_atomic_tagged(gcWORDS_TO_BYTES(gcBYTES_TO_WORDS(s)))
01599 # define scheme_malloc_array_tagged GC_malloc_array_tagged
01600 # define scheme_malloc_atomic_tagged GC_malloc_atomic_tagged
01601 # define scheme_malloc_stubborn_tagged GC_malloc_one_tagged
01602 # define scheme_malloc_eternal_tagged GC_malloc_atomic_uncollectable
01603 # define scheme_malloc_uncollectable_tagged >> error <<
01604 # define scheme_malloc_envunbox GC_malloc
01605 # define scheme_malloc_weak GC_malloc_weak
01606 # define scheme_malloc_weak_tagged GC_malloc_one_weak_tagged
01607 # define scheme_malloc_allow_interior GC_malloc_allow_interior
01608 # define scheme_malloc_atomic_allow_interior GC_malloc_allow_interior
01609 #else
01610 # ifdef USE_TAGGED_ALLOCATION
01611 extern void *scheme_malloc_tagged(size_t);
01612 #  define scheme_malloc_array_tagged scheme_malloc
01613 #  define scheme_malloc_small_tagged scheme_malloc
01614 extern void *scheme_malloc_atomic_tagged(size_t);
01615 extern void *scheme_malloc_stubborn_tagged(size_t);
01616 extern void *scheme_malloc_eternal_tagged(size_t);
01617 extern void *scheme_malloc_uncollectable_tagged(size_t);
01618 extern void *scheme_malloc_envunbox(size_t);
01619 # else
01620 #  define scheme_malloc_tagged scheme_malloc
01621 #  define scheme_malloc_small_tagged scheme_malloc
01622 #  define scheme_malloc_array_tagged scheme_malloc
01623 #  define scheme_malloc_atomic_tagged scheme_malloc_atomic
01624 #  define scheme_malloc_stubborn_tagged scheme_malloc_stubborn
01625 #  define scheme_malloc_eternal_tagged scheme_malloc_eternal
01626 #  define scheme_malloc_uncollectable_tagged scheme_malloc_uncollectable
01627 #  define scheme_malloc_envunbox scheme_malloc
01628 # endif
01629 # define scheme_malloc_small_dirty_tagged scheme_malloc_small_tagged
01630 # define scheme_malloc_allow_interior scheme_malloc
01631 # define scheme_malloc_atomic_allow_interior scheme_malloc_atomic
01632 # define scheme_malloc_small_atomic_tagged scheme_malloc_atomic_tagged
01633 #endif
01634 
01635 
01636 #ifdef MZ_PRECISE_GC
01637 # define MZ_GC_DECL_REG(size) void *__gc_var_stack__[size+2] = { (void *)0, (void *)size };
01638 # define MZ_GC_VAR_IN_REG(x, v) (__gc_var_stack__[x+2] = (void *)&(v))
01639 # define MZ_GC_ARRAY_VAR_IN_REG(x, v, l) (__gc_var_stack__[x+2] = (void *)0, \
01640                                           __gc_var_stack__[x+3] = (void *)&(v), \
01641                                           __gc_var_stack__[x+4] = (void *)l)
01642 # define MZ_GC_NO_VAR_IN_REG(x) (__gc_var_stack__[x+2] = NULL)
01643 # define MZ_GC_REG()  (__gc_var_stack__[0] = GC_variable_stack, \
01644                        GC_variable_stack = __gc_var_stack__)
01645 # define MZ_GC_UNREG() (GC_variable_stack = (void **)__gc_var_stack__[0])
01646 #else
01647 # define MZ_GC_DECL_REG(size)            /* empty */
01648 # define MZ_GC_VAR_IN_REG(x, v)          /* empty */
01649 # define MZ_GC_ARRAY_VAR_IN_REG(x, v, l) /* empty */
01650 # define MZ_GC_NO_VAR_IN_REG(x)          /* empty */
01651 # define MZ_GC_REG()                     /* empty */
01652 # define MZ_GC_UNREG()                   /* empty */
01653 # define XFORM_HIDE_EXPR(x) x
01654 # define XFORM_START_SKIP 
01655 # define XFORM_END_SKIP 
01656 # define XFORM_START_SUSPEND 
01657 # define XFORM_END_SUSPEND 
01658 # define XFORM_START_TRUST_ARITH 
01659 # define XFORM_END_TRUST_ARITH 
01660 # define XFORM_CAN_IGNORE 
01661 # define XFORM_TRUST_PLUS +
01662 # define XFORM_TRUST_MINUS -
01663 #endif
01664 
01665 /*========================================================================*/
01666 /*                   embedding configuration and hooks                    */
01667 /*========================================================================*/
01668 
01669 #if SCHEME_DIRECT_EMBEDDED
01670 
01671 #if defined(_IBMR2)
01672 MZ_EXTERN long scheme_stackbottom;
01673 #endif
01674 
01675 MZ_EXTERN int scheme_defining_primitives;
01676 
01677 /* These flags must be set before MzScheme is started: */
01678 MZ_EXTERN int scheme_case_sensitive; /* Defaults to 0 */
01679 MZ_EXTERN int scheme_no_keywords; /* Defaults to 0 */
01680 MZ_EXTERN int scheme_allow_set_undefined; /* Defaults to 0 */
01681 MZ_EXTERN int scheme_square_brackets_are_parens; /* Defaults to 1 */
01682 MZ_EXTERN int scheme_curly_braces_are_parens; /* Defaults to 1 */
01683 MZ_EXTERN int scheme_hash_percent_syntax_only; /* Defaults to 0 */
01684 MZ_EXTERN int scheme_hash_percent_globals_only; /* Defaults to 0 */
01685 MZ_EXTERN int scheme_binary_mode_stdio; /* Windows-specific; Defaults to 0 */
01686 MZ_EXTERN int scheme_startup_use_jit; /* Defaults to 1 */
01687 MZ_EXTERN int scheme_ignore_user_paths; /* Defaults to 0 */
01688 
01689 MZ_EXTERN void scheme_set_case_sensitive(int);
01690 MZ_EXTERN void scheme_set_allow_set_undefined(int);
01691 MZ_EXTERN void scheme_set_binary_mode_stdio(int);
01692 MZ_EXTERN void scheme_set_startup_use_jit(int);
01693 MZ_EXTERN void scheme_set_startup_load_on_demand(int);
01694 MZ_EXTERN void scheme_set_ignore_user_paths(int);
01695 MZ_EXTERN void scheme_set_logging(int syslog_level, int stderr_level);
01696 
01697 MZ_EXTERN int scheme_get_allow_set_undefined();
01698 
01699 #ifndef MZ_USE_PLACES
01700 MZ_EXTERN THREAD_LOCAL Scheme_Thread *scheme_current_thread;
01701 MZ_EXTERN THREAD_LOCAL Scheme_Thread *scheme_first_thread;
01702 #endif
01703 MZ_EXTERN Scheme_Thread *scheme_get_current_thread();
01704 MZ_EXTERN long scheme_get_multiple_count();
01705 MZ_EXTERN Scheme_Object **scheme_get_multiple_array();
01706 MZ_EXTERN void scheme_set_current_thread_ran_some();
01707 
01708 
01709 /* Set these global hooks (optionally): */
01710 typedef void (*Scheme_Exit_Proc)(int v);
01711 MZ_EXTERN Scheme_Exit_Proc scheme_exit;
01712 MZ_EXTERN void scheme_set_exit(Scheme_Exit_Proc p);
01713 typedef void (*scheme_console_printf_t)(char *str, ...);
01714 MZ_EXTERN scheme_console_printf_t scheme_console_printf;
01715 MZ_EXTERN scheme_console_printf_t scheme_get_console_printf();
01716 MZ_EXTERN void (*scheme_console_output)(char *str, long len);
01717 MZ_EXTERN void (*scheme_sleep)(float seconds, void *fds);
01718 MZ_EXTERN void (*scheme_notify_multithread)(int on);
01719 MZ_EXTERN void (*scheme_wakeup_on_input)(void *fds);
01720 MZ_EXTERN int (*scheme_check_for_break)(void);
01721 MZ_EXTERN Scheme_Object *(*scheme_module_demand_hook)(int c, Scheme_Object **a);
01722 #ifdef MZ_PRECISE_GC
01723 MZ_EXTERN void *(*scheme_get_external_stack_val)(void);
01724 MZ_EXTERN void (*scheme_set_external_stack_val)(void *);
01725 #endif
01726 #ifdef USE_WIN32_THREADS
01727 MZ_EXTERN void (*scheme_suspend_main_thread)(void);
01728 int scheme_set_in_main_thread(void);
01729 void scheme_restore_nonmain_thread(void);
01730 #endif
01731 #ifdef MAC_FILE_SYSTEM
01732 extern long scheme_creator_id;
01733 #endif
01734 
01735 MZ_EXTERN Scheme_Object *(*scheme_make_stdin)(void);
01736 MZ_EXTERN Scheme_Object *(*scheme_make_stdout)(void);
01737 MZ_EXTERN Scheme_Object *(*scheme_make_stderr)(void);
01738 
01739 MZ_EXTERN void scheme_set_banner(char *s);
01740 MZ_EXTERN Scheme_Object *scheme_set_exec_cmd(char *s);
01741 MZ_EXTERN Scheme_Object *scheme_set_run_cmd(char *s);
01742 MZ_EXTERN void scheme_set_collects_path(Scheme_Object *p);
01743 MZ_EXTERN void scheme_set_original_dir(Scheme_Object *d);
01744 
01745 MZ_EXTERN void scheme_init_collection_paths(Scheme_Env *global_env, Scheme_Object *extra_dirs);
01746 MZ_EXTERN void scheme_init_collection_paths_post(Scheme_Env *global_env, Scheme_Object *extra_dirs, Scheme_Object *extra_post_dirs);
01747 
01748 /* Initialization */
01749 MZ_EXTERN Scheme_Env *scheme_basic_env(void);
01750 MZ_EXTERN void scheme_reset_overflow(void);
01751 MZ_EXTERN void scheme_free_all(void);
01752 
01753 #ifdef USE_MSVC_MD_LIBRARY
01754 MZ_EXTERN void GC_pre_init(void);
01755 #endif
01756 
01757 MZ_EXTERN void scheme_check_threads(void);
01758 MZ_EXTERN void scheme_wake_up(void);
01759 MZ_EXTERN int scheme_get_external_event_fd(void);
01760 
01761 /* GC registration: */
01762 MZ_EXTERN void scheme_set_stack_base(void *base, int no_auto_statics);
01763 MZ_EXTERN void scheme_set_stack_bounds(void *base, void *deepest, int no_auto_statics);
01764 
01765 typedef void (*Scheme_Report_Out_Of_Memory_Proc)(void);
01766 MZ_EXTERN void scheme_set_report_out_of_memory(Scheme_Report_Out_Of_Memory_Proc p);
01767 
01768 /* Stack-preparation start-up: */
01769 typedef int (*Scheme_Nested_Main)(void *data);
01770 MZ_EXTERN int scheme_main_stack_setup(int no_auto_statics, Scheme_Nested_Main _main, void *data);
01771 
01772 /* More automatic start-up: */
01773 typedef int (*Scheme_Env_Main)(Scheme_Env *env, int argc, char **argv);
01774 MZ_EXTERN int scheme_main_setup(int no_auto_statics, Scheme_Env_Main _main, int argc, char **argv);
01775 
01776 
01777 MZ_EXTERN void scheme_register_static(void *ptr, long size);
01778 #if defined(MUST_REGISTER_GLOBALS) || defined(GC_MIGHT_USE_REGISTERED_STATICS)
01779 # define MZ_REGISTER_STATIC(x)  scheme_register_static((void *)&x, sizeof(x))
01780 #else
01781 # define MZ_REGISTER_STATIC(x) /* empty */
01782 #endif
01783 
01784 MZ_EXTERN void (*scheme_on_atomic_timeout)(void);
01785 
01786 MZ_EXTERN void scheme_immediate_exit(int status);
01787 
01788 MZ_EXTERN int scheme_new_param(void);
01789 MZ_EXTERN Scheme_Object *scheme_param_config(char *name, Scheme_Object *pos,
01790                                         int argc, Scheme_Object **argv,
01791                                         int arity,
01792                                         Scheme_Prim *check, char *expected,
01793                                         int isbool);
01794 MZ_EXTERN Scheme_Object *scheme_register_parameter(Scheme_Prim *function, char *name, int which);
01795 
01796 #endif /* SCHEME_DIRECT_EMBEDDED */
01797 
01798 /*========================================================================*/
01799 /*                              addrinfo                                  */
01800 /*========================================================================*/
01801 
01802 #ifdef HAVE_GETADDRINFO
01803 # define mz_addrinfo addrinfo
01804 #else
01805 struct mz_addrinfo {
01806   int ai_flags;
01807   int ai_family;
01808   int ai_socktype;
01809   int ai_protocol;
01810   size_t  ai_addrlen;
01811   struct sockaddr *ai_addr;
01812   struct mz_addrinfo *ai_next;
01813 };
01814 #endif
01815 
01816 /*========================================================================*/
01817 /*                              FFI functions                             */
01818 /*========================================================================*/
01819 
01820 /* If MzScheme is being empbedded, then we just include the
01821    prototypes. Otherwise, we may include a function-table definition
01822    instead, plus macros that map the usual name to table lookups. */
01823 
01824 #if SCHEME_DIRECT_EMBEDDED
01825 
01826 /* All functions & global constants prototyped here */
01827 #ifdef INCLUDE_WITHOUT_PATHS
01828 # include "schemef.h"
01829 #else
01830 # include "../src/schemef.h"
01831 #endif
01832 
01833 #else
01834 
01835 #ifdef LINK_EXTENSIONS_BY_TABLE
01836 /* Constants and function prototypes as function pointers in a struct: */
01837 # ifdef INCLUDE_WITHOUT_PATHS
01838 #  include "schemex.h"
01839 # else
01840 #  include "../src/schemex.h"
01841 # endif
01842 
01843 extern Scheme_Extension_Table *scheme_extension_table;
01844 
01845 /* Macro mapping names to record access */
01846 # ifdef INCLUDE_WITHOUT_PATHS
01847 #  include "schemexm.h"
01848 # else
01849 #  include "../src/schemexm.h"
01850 # endif
01851 
01852 #else
01853 
01854 /* Not LINK_EXTENSIONS_BY_TABLE */
01855 # ifdef INCLUDE_WITHOUT_PATHS
01856 #  include "schemef.h"
01857 # else
01858 #  include "../src/schemef.h"
01859 # endif
01860 
01861 #endif
01862 
01863 #endif
01864 
01865 /*========================================================================*/
01866 /*                              misc flags                                */
01867 /*========================================================================*/
01868 
01869 /* For use with scheme_symbol_name_and_size: */
01870 #define SCHEME_SNF_FOR_TS 0x1
01871 #define SCHEME_SNF_PIPE_QUOTE 0x2
01872 #define SCHEME_SNF_NO_PIPE_QUOTE 0x4
01873 #define SCHEME_SNF_NEED_CASE 0x8
01874 #define SCHEME_SNF_KEYWORD 0x10
01875 #define SCHEME_SNF_NO_KEYWORDS 0x20
01876 
01877 /* For use with scheme_make_struct_values et al.: */
01878 #define SCHEME_STRUCT_NO_TYPE 0x01
01879 #define SCHEME_STRUCT_NO_CONSTR 0x02
01880 #define SCHEME_STRUCT_NO_PRED 0x04
01881 #define SCHEME_STRUCT_NO_GET 0x08
01882 #define SCHEME_STRUCT_NO_SET 0x10
01883 #define SCHEME_STRUCT_GEN_GET 0x20
01884 #define SCHEME_STRUCT_GEN_SET 0x40
01885 #define SCHEME_STRUCT_EXPTIME 0x80
01886 
01887 /*========================================================================*/
01888 /*                           file descriptors                             */
01889 /*========================================================================*/
01890 
01891 #if defined(DETECT_WIN32_CONSOLE_STDIN) || defined(WINDOWS_PROCESSES)
01892 # ifndef NO_STDIO_THREADS
01893 #  define USE_FAR_MZ_FDCALLS
01894 # endif
01895 #endif
01896 #ifdef USE_DYNAMIC_FDSET_SIZE
01897 # define USE_FAR_MZ_FDCALLS
01898 #endif
01899 #ifdef USE_BEOS_PORT_THREADS
01900 # define USE_FAR_MZ_FDCALLS
01901 #endif
01902 
01903 #ifdef USE_FAR_MZ_FDCALLS
01904 # define MZ_GET_FDSET(p, n) scheme_get_fdset(p, n)
01905 # define MZ_FD_ZERO(p) scheme_fdzero(p)
01906 # define MZ_FD_SET(n, p) scheme_fdset(p, n)
01907 # define MZ_FD_CLR(n, p) scheme_fdclr(p, n)
01908 # define MZ_FD_ISSET(n, p) scheme_fdisset(p, n)
01909 #else
01910 # define MZ_GET_FDSET(p, n) ((void *)(((fd_set *)p) + n))
01911 # define MZ_FD_ZERO(p) FD_ZERO(p)
01912 # define MZ_FD_SET(n, p) FD_SET(n, p)
01913 # define MZ_FD_CLR(n, p) FD_CLR(n, p)
01914 # define MZ_FD_ISSET(n, p) FD_ISSET(n, p)
01915 #endif
01916 
01917 /*========================================================================*/
01918 
01919 #ifdef __cplusplus
01920 }
01921 #endif
01922 
01923 #if defined(__MWERKS__)
01924 # ifdef MZSCHEME_USES_NEAR_GLOBALS
01925 #  pragma far_data reset
01926 # endif
01927 #endif
01928 
01929 #endif /* ! SCHEME_H */
01930