1 #ifndef SCHEME_H
2 #define SCHEME_H
3
4 /* The next line is used and set during installation: */
5 /*III*/
6
7 /*========================================================================*/
8 /* configuration */
9 /*========================================================================*/
10
11 /* The configuration is not intended to be adjusted here. Instead,
12 modify sconfig.h. The code below simply draws a few more
13 configuration conclusions and a few extra macros based on those
14 settings. */
15
16 #ifdef INCLUDE_WITHOUT_PATHS
17 # include "sconfig.h"
18 #else
19 # include "../sconfig.h"
20 #endif
21
22 #if defined(__MWERKS__)
23 # ifdef MZSCHEME_USES_NEAR_GLOBALS
24 # pragma far_data off
25 # endif
26 #endif
27
28 #if SGC_STD_DEBUGGING
29 # ifndef USE_SENORA_GC
30 # define USE_SENORA_GC
31 # endif
32 # define USE_MEMORY_TRACING
33 #endif
34
35 #ifdef MZ_PRECISE_GC
36 # define MUST_REGISTER_GLOBALS
37 # define MZTAG_REQUIRED
38 /* In case SGC is used to build PRECISE_GC: */
39 # undef USE_SENORA_GC
40 #endif
41
42 #ifdef USE_SENORA_GC
43 # define MUST_REGISTER_GLOBALS
44 #endif
45
46 #ifdef USE_SINGLE_FLOATS
47 # define MZ_USE_SINGLE_FLOATS
48 #endif
49
50 /* gcc defines __SSE2_MATH__ when SSE2 floating point is enabled: */
51 #ifdef __SSE2_MATH__
52 # define C_COMPILER_USES_SSE 1
53 #endif
54
55 #ifdef C_COMPILER_USES_SSE
56 # if defined(MZ_TRY_EXTFLONUMS) && !defined(MZ_NO_EXTFLONUMS)
57 # define MZ_LONG_DOUBLE
58 # ifdef ASM_DBLPREC_CONTROL_87
59 # define ASM_EXTPREC_CONTROL_87
60 # endif
61 # endif
62 # ifdef ASM_DBLPREC_CONTROL_87
63 # undef ASM_DBLPREC_CONTROL_87
64 # endif
65 # if defined(MZ_USE_JIT_I386) && !defined(MZ_NO_JIT_SSE)
66 # define MZ_USE_JIT_SSE
67 # endif
68 #endif
69
70 #ifdef MZ_LONG_DOUBLE
71 # ifdef MZ_LONG_DOUBLE_API_IS_EXTERNAL
72 # define BYTES_RESERVED_FOR_LONG_DOUBLE 16
73 typedef struct {
74 char bytes[BYTES_RESERVED_FOR_LONG_DOUBLE];
75 } mz_long_double;
76 # else
77 typedef long double mz_long_double;
78 # endif
79 #else
80 # ifdef MZ_INSIST_EXTFLONUMS
81 # error "cannot support extflonums; you may need to adjust compiler options"
82 # endif
83 typedef double mz_long_double;
84 #endif
85
86 #ifdef DONT_ITIMER
87 # undef USE_ITIMER
88 #endif
89
90 #if defined(USE_ITIMER) || defined(USE_WIN32_THREAD_TIMER) || defined(USE_PTHREAD_THREAD_TIMER)
91 # define FUEL_AUTODECEREMENTS
92 #endif
93
94 #ifdef SIZEOF_VOID_P
95 # if SIZEOF_VOID_P == 8
96 # define SIXTY_FOUR_BIT_INTEGERS
97 # ifdef USE_LONG_LONG_FOR_BIGDIG
98 Do not specify USE_LONG_LONG_FOR_BIGDIG on a platform with
99 64-bit integers
100 # endif
101 # endif
102 #endif
103
104 #ifdef SIZEOF_LONG
105 # if SIZEOF_LONG == 8
106 # define SIXTY_FOUR_BIT_LONGS
107 # endif
108 #endif
109
110 #ifdef MZ_PRECISE_GC
111 # define MZ_HASH_KEY_EX short keyex;
112 # define MZ_OPT_HASH_KEY_EX /**/
113 # define MZ_OPT_HASH_KEY(obj) (obj)->so.keyex
114 #else
115 # define MZ_HASH_KEY_EX /**/
116 # define MZ_OPT_HASH_KEY_EX short keyex;
117 # define MZ_OPT_HASH_KEY(obj) (obj)->keyex
118 #endif
119
120 #ifdef PALMOS_STUFF
121 # include <PalmOS.h>
122 typedef long FILE;
123 # define _LINUX_TYPES_H /* Blocks types.h */
124 #endif
125
126 #ifndef SCHEME_DIRECT_EMBEDDED
127 # define SCHEME_DIRECT_EMBEDDED 1
128 #endif
129
130 #ifndef MSC_IZE
131 # define MSC_IZE(x) x
132 #endif
133 #ifndef M_MSC_IZE
134 # define M_MSC_IZE(x) x
135 #endif
136 #ifndef MSCBOR_IZE
137 # define MSCBOR_IZE(x) MSC_IZE(x)
138 #endif
139
140 /* C99 allows an array in a struct to be declared
141 with [] to indicate that its actual size can be
142 any number. The old way was to declare the array
143 of size 1. For now, we support going back to the
144 old way. */
145 #ifdef MZ_USE_OLD_ARRAY_STYLE
146 # define mzFLEX_ARRAY_DECL 1
147 # define mzFLEX_ARRAY4_DECL 4
148 # define mzFLEX_DELTA 1
149 # define mzFLEX4_DELTA 4
150 #else
151 # define mzFLEX_ARRAY_DECL /* empty */
152 # define mzFLEX_ARRAY4_DECL /* empty */
153 # define mzFLEX_DELTA 0
154 # define mzFLEX4_DELTA 0
155 #endif
156
157 #ifdef MZ_XFORM
158 /* A non-GCing function will never trigger a garbage collection.
159 The xform tool checks this declaration, and it uses this hint
160 to avoid registering variables unnecessarily. */
161 # define XFORM_NONGCING __xform_nongcing__
162 /* A non-GCing, non-aliasing function is non-GCing, and it may take
163 arguments that are addresses of local variables, but it doesn't
164 leak those addresses; it only filles them in. The xform tool only
165 checks the non-GCing part of this declaration, but uses both
166 facets of the hint. */
167 # define XFORM_NONGCING_NONALIASING __xform_nongcing_nonaliasing__
168 #else
169 # define XFORM_NONGCING /* empty */
170 # define XFORM_NONGCING_NONALIASING /* empty */
171 #endif
172
173 #ifdef MZ_XFORM
174 START_XFORM_SUSPEND;
175 #endif
176
177 #include <stdio.h>
178 #include <setjmp.h>
179 #include <stdarg.h>
180 #include <stdlib.h>
181 #include <string.h>
182 #include <stddef.h>
183
184 #ifdef MZ_XFORM
185 END_XFORM_SUSPEND;
186 #endif
187
188 #ifdef PALMOS_STUFF
189 typedef jmpbuf jmp_buf[1];
190 #endif
191
192 #define GC_MIGHT_USE_REGISTERED_STATICS
193
194 #ifndef MZ_DONT_USE_JIT
195 # if defined(MZ_USE_JIT_PPC) || defined(MZ_USE_JIT_I386) || defined(MZ_USE_JIT_X86_64) || defined(MZ_USE_JIT_ARM)
196 # define MZ_USE_JIT
197 # endif
198 #endif
199
200 /* Define _W64 for MSC if needed. */
201 #if defined(_MSC_VER) && !defined(_W64)
202 # if !defined(__midl) && (defined(_X86_) || defined(_M_IX86)) && _MSC_VER >= 1300
203 # define _W64 __w64
204 # else
205 # define _W64
206 # endif
207 #endif
208
209 #ifdef MZ_PRECISE_GC
210 # ifndef MZ_XFORM
211 # define XFORM_SKIP_PROC /* empty */
212 # define XFORM_ASSERT_NO_CONVERSION /* empty */
213 # define XFORM_CAN_IGNORE /**/
214 # endif
215 #else
216 # define XFORM_HIDE_EXPR(x) x
217 # define XFORM_START_SKIP /**/
218 # define XFORM_END_SKIP /**/
219 # define XFORM_START_SUSPEND /**/
220 # define XFORM_END_SUSPEND /**/
221 # define XFORM_SKIP_PROC /**/
222 # define XFORM_ASSERT_NO_CONVERSION /**/
223 # define XFORM_START_TRUST_ARITH /**/
224 # define XFORM_END_TRUST_ARITH /**/
225 # define XFORM_CAN_IGNORE /**/
226 # define XFORM_TRUST_PLUS +
227 # define XFORM_TRUST_MINUS -
228 #endif
229
230 /* PPC Linux plays a slimy trick: it defines strcpy() as a macro that
231 uses __extension__. This breaks the 3m xform. */
232 #if defined(MZ_XFORM) && defined(strcpy)
233 START_XFORM_SKIP;
234 # ifdef __clang__
235 # pragma clang diagnostic push
236 # pragma clang diagnostic ignored "-Wunused-function"
237 # endif
_mzstrcpy(char * a,const char * b)238 static inline void _mzstrcpy(char *a, const char *b)
239 {
240 strcpy(a, b);
241 }
242 # ifdef __clang__
243 # pragma clang diagnostic pop
244 # endif
245 END_XFORM_SKIP;
246 # undef strcpy
247 # define strcpy _mzstrcpy
248 #endif
249
250 #ifdef __cplusplus
251 extern "C"
252 {
253 #endif
254
255 #if !defined(MZ_NORETURN)
256 # if !defined(MZ_PRECISE_RETURN_SPEC)
257 # define MZ_NORETURN
258 # elif defined(__GNUC__) || defined(__clang__)
259 # define MZ_NORETURN __attribute__((noreturn))
260 # elif defined(_MSC_VER)
261 # define MZ_NORETURN __declspec(noreturn)
262 # else
263 # define MZ_NORETURN
264 # endif /* defined(__GNUC__) || defined(__clang__) */
265 #endif /* !defined(MZ_NORETURN) */
266
267 #if !defined(MZ_UNREACHABLE)
268 # if (defined(__GNUC__) && (__GNUC__ > 4)) || defined(__clang__)
269 # define MZ_UNREACHABLE __builtin_unreachable()
270 # elif defined(_MSC_VER)
271 # define MZ_UNREACHABLE __assume(0)
272 # else
273 # define MZ_UNREACHABLE
274 # endif /* defined(__GNUC__) || defined(__clang__) */
275 #endif /* !defined(MZ_UNREACHABLE) */
276
277 /* Allowed by all configurations, currently: */
278 #define MZ_CAN_ACCESS_THREAD_LOCAL_DIRECTLY
279
280 /*========================================================================*/
281 /* basic Scheme values */
282 /*========================================================================*/
283
284 typedef short Scheme_Type;
285
286 typedef int mzshort;
287
288 typedef unsigned int mzchar;
289 typedef int mzchar_int; /* includes EOF */
290
291 #ifdef INT64_AS_LONG_LONG
292 typedef _int64 mzlonglong;
293 typedef unsigned _int64 umzlonglong;
294 #else
295 # if defined(NO_LONG_LONG_TYPE) || defined(SIXTY_FOUR_BIT_INTEGERS)
296 typedef intptr_t mzlonglong;
297 typedef uintptr_t umzlonglong;
298 # else
299 typedef long long mzlonglong;
300 typedef unsigned long long umzlonglong;
301 # endif
302 #endif
303
304 /* Racket values have the type `Scheme_Object *'. The Scheme_Object
305 structure declares just the header: a type tag and space for
306 hashing or extra flags; actual object types will extend this
307 structure.
308
309 For example, Scheme_Simple_Object defines a few variants. The
310 important thing is that it starts with a nested Scheme_Object
311 record.
312
313 The Scheme_Simple_Object struct is defined here, instead of in a
314 private header, so that macros can provide quick access. Of course,
315 don't access the fields of these structures directly; use the
316 macros instead. */
317
318 typedef struct Scheme_Object
319 {
320 Scheme_Type type; /* Anything that starts with a type field
321 can be a Scheme_Object */
322
323 /* For precise GC, the keyex field is used for all object types to
324 store a hash key extension. The low bit is not used for this
325 purpose, though. For string, pair, vector, and box values in all
326 variants of Racket, the low bit is set to 1 to indicate that
327 the object is immutable. Thus, the keyex field is needed even in
328 non-precise GC mode, so such structures embed
329 Scheme_Inclhash_Object */
330
331 MZ_HASH_KEY_EX
332 } Scheme_Object;
333
334 /* See note above on MZ_HASH_KEY_EX. To get the keyex field,
335 use MZ_OPT_HASH_KEY(iso), where iso is a pointer to a
336 Scheme_Inclhash_Object */
337 typedef struct Scheme_Inclhash_Object
338 {
339 Scheme_Object so;
340 MZ_OPT_HASH_KEY_EX
341 } Scheme_Inclhash_Object;
342
343 typedef struct Scheme_Simple_Object
344 {
345 Scheme_Inclhash_Object iso;
346
347 union
348 {
349 struct { mzchar *string_val; intptr_t tag_val; } char_str_val;
350 struct { char *string_val; intptr_t tag_val; } byte_str_val;
351 struct { void *ptr1, *ptr2; } two_ptr_val;
352 struct { int int1; int int2; } two_int_val;
353 struct { void *ptr; int pint; } ptr_int_val;
354 struct { void *ptr; intptr_t pint; } ptr_long_val;
355 struct { struct Scheme_Object *car, *cdr; } pair_val;
356 struct { mzshort len; mzshort *vec; } svector_val;
357 struct { void *val; Scheme_Object *type; } cptr_val;
358 } u;
359 } Scheme_Simple_Object;
360
361 typedef struct Scheme_Object *(*Scheme_Closure_Func)(struct Scheme_Object *);
362
363 /* Scheme_Small_Object is used for several types of Racket values: */
364 typedef struct {
365 Scheme_Inclhash_Object iso;
366 union {
367 mzchar char_val;
368 Scheme_Object *ptr_value;
369 intptr_t int_val;
370 Scheme_Object *ptr_val;
371 } u;
372 } Scheme_Small_Object;
373
374 /* A floating-point number: */
375 typedef struct {
376 Scheme_Object so;
377 double double_val;
378 } Scheme_Double;
379
380 #ifdef MZ_LONG_DOUBLE
381 typedef struct {
382 Scheme_Object so;
383 mz_long_double long_double_val;
384 } Scheme_Long_Double;
385 #else
386 typedef struct {
387 Scheme_Object so;
388 const char *printed_form;
389 } Scheme_Long_Double;
390 #endif
391
392 #ifdef MZ_USE_SINGLE_FLOATS
393 typedef struct {
394 Scheme_Object so;
395 float float_val;
396 } Scheme_Float;
397 #endif
398
399 typedef struct Scheme_Symbol {
400 Scheme_Inclhash_Object iso; /* 1 in low bit of keyex indicates uninterned */
401 intptr_t len;
402 char s[mzFLEX_ARRAY4_DECL];
403 } Scheme_Symbol;
404
405 typedef struct Scheme_Vector {
406 Scheme_Inclhash_Object iso; /* 1 in low bit of keyex indicates immutable */
407 intptr_t size;
408 Scheme_Object *els[mzFLEX_ARRAY_DECL];
409 } Scheme_Vector;
410
411 # define SHARED_ALLOCATED 0x2
412 # define SHARED_ALLOCATEDP(so) (MZ_OPT_HASH_KEY((Scheme_Inclhash_Object *)(so)) & SHARED_ALLOCATED)
413 # define SHARED_ALLOCATED_SET(so) (MZ_OPT_HASH_KEY((Scheme_Inclhash_Object *)(so)) |= SHARED_ALLOCATED)
414
415 typedef struct Scheme_Double_Vector {
416 Scheme_Inclhash_Object iso; /* & 0x2 indicates allocated in the MASTERGC */
417 intptr_t size;
418 double els[mzFLEX_ARRAY_DECL];
419 } Scheme_Double_Vector;
420
421 #ifdef MZ_LONG_DOUBLE
422 typedef struct Scheme_Long_Double_Vector {
423 Scheme_Inclhash_Object iso; /* & 0x2 indicates allocated in the MASTERGC */
424 intptr_t size;
425 mz_long_double els[mzFLEX_ARRAY_DECL];
426 } Scheme_Long_Double_Vector;
427 #endif
428
429 typedef struct Scheme_Print_Params Scheme_Print_Params;
430 typedef void (*Scheme_Type_Printer)(Scheme_Object *v, int for_display, Scheme_Print_Params *pp);
431
432 typedef int (*Scheme_Equal_Proc)(Scheme_Object *obj1, Scheme_Object *obj2, void *cycle_data);
433 typedef intptr_t (*Scheme_Primary_Hash_Proc)(Scheme_Object *obj, intptr_t base, void *cycle_data);
434 typedef intptr_t (*Scheme_Secondary_Hash_Proc)(Scheme_Object *obj, void *cycle_data);
435
436 /* This file defines all the built-in types */
437 #ifdef INCLUDE_WITHOUT_PATHS
438 # include "stypes.h"
439 #else
440 # include "../src/stypes.h"
441 #endif
442
443 #define OBJ_TO_LONG(ptr) ((intptr_t)(ptr))
444 #define LONG_TO_OBJ(l) ((Scheme_Object *)(void *)(intptr_t)(l))
445
446 /* Scheme Objects are always aligned on 2-byte boundaries, so */
447 /* words of type Scheme_Object * will always have zero in the */
448 /* least significant bit. Therefore, we can use this bit as a */
449 /* tag to indicate that the `pointer' isn't really a pointer */
450 /* but a 31-bit signed immediate integer. */
451
452 #define SCHEME_INTP(obj) (OBJ_TO_LONG(obj) & 0x1)
453
454 #define SAME_PTR(a, b) ((a) == (b))
455 #define NOT_SAME_PTR(a, b) ((a) != (b))
456
457 #define SAME_OBJ(a, b) SAME_PTR(a, b)
458 #define NOT_SAME_OBJ(a, b) NOT_SAME_PTR(a, b)
459
460 #define SAME_TYPE(a, b) ((Scheme_Type)(a) == (Scheme_Type)(b))
461 #define NOT_SAME_TYPE(a, b) ((Scheme_Type)(a) != (Scheme_Type)(b))
462
463 # define SCHEME_TYPE(obj) (SCHEME_INTP(obj)?(Scheme_Type)scheme_integer_type:((Scheme_Object *)(obj))->type)
464 # define _SCHEME_TYPE(obj) ((obj)->type) /* unsafe version */
465
466 /*========================================================================*/
467 /* basic Scheme predicates */
468 /*========================================================================*/
469
470 #define SCHEME_CHARP(obj) SAME_TYPE(SCHEME_TYPE(obj), scheme_char_type)
471 /* SCHEME_INTP defined above */
472 #define SCHEME_DBLP(obj) SAME_TYPE(SCHEME_TYPE(obj), scheme_double_type)
473 #ifdef MZ_USE_SINGLE_FLOATS
474 # define SCHEME_FLTP(obj) SAME_TYPE(SCHEME_TYPE(obj), scheme_float_type)
475 # define SCHEME_FLOATP(obj) (SCHEME_FLTP(obj) || SCHEME_DBLP(obj))
476 #else
477 # define SCHEME_FLTP SCHEME_DBLP
478 # define SCHEME_FLOATP SCHEME_DBLP
479 #endif
480 #define SCHEME_BIGNUMP(obj) SAME_TYPE(SCHEME_TYPE(obj), scheme_bignum_type)
481 #define SCHEME_RATIONALP(obj) SAME_TYPE(SCHEME_TYPE(obj), scheme_rational_type)
482 #define SCHEME_COMPLEXP(obj) (!SCHEME_INTP(obj) && ((_SCHEME_TYPE(obj) == scheme_complex_type)))
483 #define SCHEME_EXACT_INTEGERP(obj) (SCHEME_INTP(obj) || (_SCHEME_TYPE(obj) == scheme_bignum_type))
484 #define SCHEME_EXACT_REALP(obj) (SCHEME_INTP(obj) || (_SCHEME_TYPE(obj) == scheme_bignum_type) || (_SCHEME_TYPE(obj) == scheme_rational_type))
485 #define SCHEME_REALP(obj) (SCHEME_INTP(obj) || ((_SCHEME_TYPE(obj) >= scheme_bignum_type) && (_SCHEME_TYPE(obj) < scheme_complex_type)))
486 #define SCHEME_NUMBERP(obj) (SCHEME_INTP(obj) || ((_SCHEME_TYPE(obj) >= scheme_bignum_type) && (_SCHEME_TYPE(obj) <= scheme_complex_type)))
487
488 #define SCHEME_LONG_DBLP(obj) SAME_TYPE(SCHEME_TYPE(obj), scheme_long_double_type)
489
490 #define SCHEME_CHAR_STRINGP(obj) SAME_TYPE(SCHEME_TYPE(obj), scheme_char_string_type)
491 #define SCHEME_MUTABLE_CHAR_STRINGP(obj) (SCHEME_CHAR_STRINGP(obj) && SCHEME_MUTABLEP(obj))
492 #define SCHEME_IMMUTABLE_CHAR_STRINGP(obj) (SCHEME_CHAR_STRINGP(obj) && SCHEME_IMMUTABLEP(obj))
493
494 #define SCHEME_BYTE_STRINGP(obj) SAME_TYPE(SCHEME_TYPE(obj), scheme_byte_string_type)
495 #define SCHEME_MUTABLE_BYTE_STRINGP(obj) (SCHEME_BYTE_STRINGP(obj) && SCHEME_MUTABLEP(obj))
496 #define SCHEME_IMMUTABLE_BYTE_STRINGP(obj) (SCHEME_BYTE_STRINGP(obj) && SCHEME_IMMUTABLEP(obj))
497
498 #define SCHEME_PATHP(obj) SAME_TYPE(SCHEME_TYPE(obj), SCHEME_PLATFORM_PATH_KIND)
499 #define SCHEME_GENERAL_PATHP(obj) ((SCHEME_TYPE(obj) >= scheme_unix_path_type) && (SCHEME_TYPE(obj) <= scheme_windows_path_type))
500 /* A path is guaranteed to have the same shape as a byte string */
501
502 #define SCHEME_PATH_STRINGP(x) (SCHEME_CHAR_STRINGP(x) || SCHEME_PATHP(x))
503 #define SCHEME_PATH_STRING_STR "path or string"
504
505 #define SCHEME_GENERAL_PATH_STRINGP(x) (SCHEME_CHAR_STRINGP(x) || SCHEME_GENERAL_PATHP(x))
506 #define SCHEME_GENERAL_PATH_STRING_STR "path (for any platform) or string"
507
508 #define SCHEME_SYMBOLP(obj) SAME_TYPE(SCHEME_TYPE(obj), scheme_symbol_type)
509 #define SCHEME_KEYWORDP(obj) SAME_TYPE(SCHEME_TYPE(obj), scheme_keyword_type)
510
511 #define SCHEME_STRSYMP(obj) (SCHEME_CHAR_STRINGP(obj) || SCHEME_SYMBOLP(obj))
512
513 #define SCHEME_BOOLP(obj) (SAME_OBJ(obj, scheme_true) || SAME_OBJ(obj, scheme_false))
514 #define SCHEME_FALSEP(obj) SAME_OBJ((obj), scheme_false)
515 #define SCHEME_TRUEP(obj) (!SCHEME_FALSEP(obj))
516 #define SCHEME_EOFP(obj) SAME_OBJ((obj), scheme_eof)
517 #define SCHEME_VOIDP(obj) SAME_OBJ((obj), scheme_void)
518
519 #define SCHEME_NULLP(obj) SAME_OBJ(obj, scheme_null)
520 #define SCHEME_PAIRP(obj) SAME_TYPE(SCHEME_TYPE(obj), scheme_pair_type)
521 #define SCHEME_MPAIRP(obj) SAME_TYPE(SCHEME_TYPE(obj), scheme_mutable_pair_type)
522 #define SCHEME_MUTABLE_PAIRP(obj) SCHEME_MPAIRP(obj)
523 #define SCHEME_LISTP(obj) scheme_is_list(obj)
524
525 #define SCHEME_RPAIRP(obj) SAME_TYPE(SCHEME_TYPE(obj), scheme_raw_pair_type)
526
527 #define SCHEME_BOXP(obj) SAME_TYPE(SCHEME_TYPE(obj), scheme_box_type)
528 #define SCHEME_MUTABLE_BOXP(obj) (SCHEME_BOXP(obj) && SCHEME_MUTABLEP(obj))
529 #define SCHEME_IMMUTABLE_BOXP(obj) (SCHEME_BOXP(obj) && SCHEME_IMMUTABLEP(obj))
530
531 #define SCHEME_PROMPT_TAGP(obj) SAME_TYPE(SCHEME_TYPE(obj), scheme_prompt_tag_type)
532 #define SCHEME_CONTINUATION_MARK_KEYP(obj) SAME_TYPE(SCHEME_TYPE(obj), scheme_continuation_mark_key_type)
533
534 #define SCHEME_BUCKTP(obj) SAME_TYPE(SCHEME_TYPE(obj),scheme_bucket_table_type)
535 #define SCHEME_HASHTP(obj) SAME_TYPE(SCHEME_TYPE(obj),scheme_hash_table_type)
536 #define SCHEME_HASHTRP(obj) ((SCHEME_TYPE(obj) >= scheme_hash_tree_type) && (SCHEME_TYPE(obj) <= scheme_hash_tree_indirection_type))
537
538 #define SCHEME_VECTORP(obj) SAME_TYPE(SCHEME_TYPE(obj), scheme_vector_type)
539 #define SCHEME_MUTABLE_VECTORP(obj) (SCHEME_VECTORP(obj) && SCHEME_MUTABLEP(obj))
540 #define SCHEME_IMMUTABLE_VECTORP(obj) (SCHEME_VECTORP(obj) && SCHEME_IMMUTABLEP(obj))
541
542 #define SCHEME_FLVECTORP(obj) SAME_TYPE(SCHEME_TYPE(obj), scheme_flvector_type)
543 #define SCHEME_EXTFLVECTORP(obj) SAME_TYPE(SCHEME_TYPE(obj), scheme_extflvector_type)
544 #define SCHEME_FXVECTORP(obj) SAME_TYPE(SCHEME_TYPE(obj), scheme_fxvector_type)
545
546 #define SCHEME_STRUCTP(obj) (SAME_TYPE(SCHEME_TYPE(obj), scheme_structure_type) || SAME_TYPE(SCHEME_TYPE(obj), scheme_proc_struct_type))
547 #define SCHEME_STRUCT_TYPEP(obj) SAME_TYPE(SCHEME_TYPE(obj), scheme_struct_type_type)
548
549 #define SCHEME_INPORTP(obj) SAME_TYPE(SCHEME_TYPE(obj), scheme_input_port_type)
550 #define SCHEME_OUTPORTP(obj) SAME_TYPE(SCHEME_TYPE(obj), scheme_output_port_type)
551
552 #define SCHEME_INPUT_PORTP(obj) scheme_is_input_port(obj)
553 #define SCHEME_OUTPUT_PORTP(obj) scheme_is_output_port(obj)
554
555 #define SCHEME_THREADP(obj) SAME_TYPE(SCHEME_TYPE(obj), scheme_thread_type)
556 #define SCHEME_CUSTODIANP(obj) SAME_TYPE(SCHEME_TYPE(obj), scheme_custodian_type)
557 #define SCHEME_PLUMBERP(obj) SAME_TYPE(SCHEME_TYPE(obj), scheme_plumber_type)
558 #define SCHEME_SEMAP(obj) SAME_TYPE(SCHEME_TYPE(obj), scheme_sema_type)
559 #define SCHEME_CHANNELP(obj) SAME_TYPE(SCHEME_TYPE(obj), scheme_channel_type)
560 #define SCHEME_CHANNEL_PUTP(obj) SAME_TYPE(SCHEME_TYPE(obj), scheme_channel_put_type)
561
562 #define SCHEME_CONFIGP(obj) SAME_TYPE(SCHEME_TYPE(obj), scheme_config_type)
563 #define SCHEME_NAMESPACEP(obj) SAME_TYPE(SCHEME_TYPE(obj), scheme_namespace_type)
564 #define SCHEME_WEAKP(obj) SAME_TYPE(SCHEME_TYPE(obj), scheme_weak_box_type)
565
566 #define SCHEME_STXP(obj) SAME_TYPE(SCHEME_TYPE(obj), scheme_stx_type)
567
568 #define SCHEME_CHAPERONEP(obj) (SAME_TYPE(SCHEME_TYPE(obj), scheme_chaperone_type) \
569 || SAME_TYPE(SCHEME_TYPE(obj), scheme_proc_chaperone_type))
570
571 #define SCHEME_UDPP(obj) SAME_TYPE(SCHEME_TYPE(obj), scheme_udp_type)
572 #define SCHEME_UDP_EVTP(obj) SAME_TYPE(SCHEME_TYPE(obj), scheme_udp_evt_type)
573
574 #define SCHEME_CPTRP(obj) (SAME_TYPE(SCHEME_TYPE(obj), scheme_cpointer_type))
575
576 #define SCHEME_MUTABLEP(obj) (!(MZ_OPT_HASH_KEY((Scheme_Inclhash_Object *)(obj)) & 0x1))
577 #define SCHEME_IMMUTABLEP(obj) (MZ_OPT_HASH_KEY((Scheme_Inclhash_Object *)(obj)) & 0x1)
578
579 #define GUARANTEE_TYPE(fname, argnum, typepred, typenam) \
580 (typepred (argv [argnum]) \
581 ? argv [argnum] \
582 : (scheme_wrong_type (fname, typenam, argnum, argc, argv), argv [argnum]))
583
584 #define GUARANTEE_BOOL(fname, argnum) GUARANTEE_TYPE (fname, argnum, SCHEME_BOOLP, "boolean")
585 #define GUARANTEE_CHAR(fname, argnum) GUARANTEE_TYPE (fname, argnum, SCHEME_CHARP, "character")
586 #define GUARANTEE_INTEGER(fname, argnum) GUARANTEE_TYPE (fname, argnum, SCHEME_INTP, "integer")
587 #define GUARANTEE_PAIR(fname, argnum) GUARANTEE_TYPE (fname, argnum, SCHEME_PAIRP, "pair")
588 #define GUARANTEE_PROCEDURE(fname, argnum) GUARANTEE_TYPE (fname, argnum, SCHEME_PROCP, "procedure")
589 #define GUARANTEE_CHAR_STRING(fname, argnum) GUARANTEE_TYPE (fname, argnum, SCHEME_CHAR_STRINGP, "string")
590 #define GUARANTEE_STRSYM(fname, argnum) GUARANTEE_TYPE (fname, argnum, SCHEME_STRSYMP, "string or symbol")
591 #define GUARANTEE_SYMBOL(fname, argnum) GUARANTEE_TYPE (fname, argnum, SCHEME_SYMBOLP, "symbol")
592
593 #define SCHEME_UNIX_PATH_KIND scheme_unix_path_type
594 #define SCHEME_WINDOWS_PATH_KIND scheme_windows_path_type
595
596 #ifdef DOS_FILE_SYSTEM
597 # define SCHEME_PLATFORM_PATH_KIND SCHEME_WINDOWS_PATH_KIND
598 #else
599 # define SCHEME_PLATFORM_PATH_KIND SCHEME_UNIX_PATH_KIND
600 #endif
601
602 #define SCHEME_PATH_KIND(p) SCHEME_TYPE(p)
603
604 /*========================================================================*/
605 /* basic Scheme accessors */
606 /*========================================================================*/
607
608 #define SCHEME_CHAR_VAL(obj) (((Scheme_Small_Object *)(obj))->u.char_val)
609 #define SCHEME_INT_VAL(obj) (OBJ_TO_LONG(obj)>>1)
610 #define SCHEME_DBL_VAL(obj) (((Scheme_Double *)(obj))->double_val)
611 #ifdef MZ_LONG_DOUBLE
612 #define SCHEME_LONG_DBL_VAL(obj) (((Scheme_Long_Double *)(obj))->long_double_val)
613 #endif
614 #ifdef MZ_USE_SINGLE_FLOATS
615 # define SCHEME_FLT_VAL(obj) (((Scheme_Float *)(obj))->float_val)
616 # define SCHEME_FLOAT_VAL(obj) (SCHEME_DBLP(obj) ? SCHEME_DBL_VAL(obj) : SCHEME_FLT_VAL(obj))
617 #else
618 # define SCHEME_FLT_VAL(x) ((float)(SCHEME_DBL_VAL(x)))
619 # define SCHEME_FLOAT_VAL SCHEME_DBL_VAL
620 # define scheme_make_float(x) scheme_make_double((double)x)
621 #endif
622
623 #define SCHEME_CHAR_STR_VAL(obj) (((Scheme_Simple_Object *)(obj))->u.char_str_val.string_val)
624 #define SCHEME_CHAR_STRTAG_VAL(obj) (((Scheme_Simple_Object *)(obj))->u.char_str_val.tag_val)
625 #define SCHEME_CHAR_STRLEN_VAL(obj) (((Scheme_Simple_Object *)(obj))->u.char_str_val.tag_val)
626 #define SCHEME_BYTE_STR_VAL(obj) (((Scheme_Simple_Object *)(obj))->u.byte_str_val.string_val)
627 #define SCHEME_BYTE_STRTAG_VAL(obj) (((Scheme_Simple_Object *)(obj))->u.byte_str_val.tag_val)
628 #define SCHEME_BYTE_STRLEN_VAL(obj) (((Scheme_Simple_Object *)(obj))->u.byte_str_val.tag_val)
629 #define SCHEME_PATH_VAL(obj) (((Scheme_Simple_Object *)(obj))->u.byte_str_val.string_val)
630 #define SCHEME_PATH_LEN(obj) (((Scheme_Simple_Object *)(obj))->u.byte_str_val.tag_val)
631 #define SCHEME_SYM_VAL(obj) (((Scheme_Symbol *)((Scheme_Simple_Object *)(obj)))->s)
632 #define SCHEME_SYM_LEN(obj) (((Scheme_Symbol *)((Scheme_Simple_Object *)(obj)))->len)
633 #define SCHEME_KEYWORD_VAL(obj) SCHEME_SYM_VAL(obj)
634 #define SCHEME_KEYWORD_LEN(obj) SCHEME_SYM_LEN(obj)
635
636 #define SCHEME_SYMSTR_OFFSET(obj) ((uintptr_t)SCHEME_SYM_VAL(obj)-(uintptr_t)(obj))
637
638 /* return a `char *' pointing to the string or the symbol name */
639 #define SCHEME_STRSYM_VAL(obj) (SCHEME_SYMBOLP(obj) ? SCHEME_SYM_VAL(obj) : SCHEME_CHAR_STR_VAL(obj))
640
641 #define SCHEME_BOX_VAL(obj) (((Scheme_Small_Object *)(obj))->u.ptr_val)
642
643 #define SCHEME_CAR(obj) (((Scheme_Simple_Object *)(obj))->u.pair_val.car)
644 #define SCHEME_CDR(obj) (((Scheme_Simple_Object *)(obj))->u.pair_val.cdr)
645
646 #define SCHEME_CADR(obj) (SCHEME_CAR (SCHEME_CDR (obj)))
647 #define SCHEME_CAAR(obj) (SCHEME_CAR (SCHEME_CAR (obj)))
648 #define SCHEME_CDDR(obj) (SCHEME_CDR (SCHEME_CDR (obj)))
649
650 #define SCHEME_MCAR(obj) (((Scheme_Simple_Object *)(obj))->u.pair_val.car)
651 #define SCHEME_MCDR(obj) (((Scheme_Simple_Object *)(obj))->u.pair_val.cdr)
652
653 #define SCHEME_VEC_SIZE(obj) (((Scheme_Vector *)(obj))->size)
654 #define SCHEME_VEC_ELS(obj) (((Scheme_Vector *)(obj))->els)
655 #define SCHEME_VEC_BASE(obj) SCHEME_VEC_ELS(obj)
656
657 #define SCHEME_FLVEC_SIZE(obj) (((Scheme_Double_Vector *)(obj))->size)
658 #define SCHEME_FLVEC_ELS(obj) (((Scheme_Double_Vector *)(obj))->els)
659
660 #ifdef MZ_LONG_DOUBLE
661 #define SCHEME_EXTFLVEC_SIZE(obj) (((Scheme_Long_Double_Vector *)(obj))->size)
662 #define SCHEME_EXTFLVEC_ELS(obj) (((Scheme_Long_Double_Vector *)(obj))->els)
663 #endif
664
665 #define SCHEME_FXVEC_SIZE(obj) SCHEME_VEC_SIZE(obj)
666 #define SCHEME_FXVEC_ELS(obj) SCHEME_VEC_ELS(obj)
667
668 #define SCHEME_ENVBOX_VAL(obj) (*((Scheme_Object **)(obj)))
669 #define SCHEME_WEAK_BOX_VAL(obj) SCHEME_BOX_VAL(obj)
670
671 #define SCHEME_PTR_VAL(obj) (((Scheme_Small_Object *)(obj))->u.ptr_val)
672 #define SCHEME_PTR1_VAL(obj) (((Scheme_Simple_Object *)(obj))->u.two_ptr_val.ptr1)
673 #define SCHEME_PTR2_VAL(obj) (((Scheme_Simple_Object *)(obj))->u.two_ptr_val.ptr2)
674 #define SCHEME_IPTR_VAL(obj) (((Scheme_Simple_Object *)(obj))->u.ptr_int_val.ptr)
675 #define SCHEME_LPTR_VAL(obj) (((Scheme_Simple_Object *)(obj))->u.ptr_long_val.ptr)
676 #define SCHEME_INT1_VAL(obj) (((Scheme_Simple_Object *)(obj))->u.two_int_val.int1)
677 #define SCHEME_INT2_VAL(obj) (((Scheme_Simple_Object *)(obj))->u.two_int_val.int2)
678 #define SCHEME_PINT_VAL(obj) (((Scheme_Simple_Object *)(obj))->u.ptr_int_val.pint)
679 #define SCHEME_PLONG_VAL(obj) (((Scheme_Simple_Object *)(obj))->u.ptr_long_val.pint)
680
681 typedef struct Scheme_Cptr
682 {
683 Scheme_Inclhash_Object so; /* 0x1 => an external pointer (not GCable); 0x2 => has offset */
684 void *val;
685 Scheme_Object *type;
686 } Scheme_Cptr;
687 typedef struct Scheme_Offset_Cptr
688 {
689 Scheme_Cptr cptr;
690 intptr_t offset;
691 } Scheme_Offset_Cptr;
692
693 #define SCHEME_CPTR_VAL(obj) (((Scheme_Cptr *)(obj))->val)
694 #define SCHEME_CPTR_TYPE(obj) (((Scheme_Cptr *)(obj))->type)
695 #define SCHEME_CPTR_OFFSET(obj) (SCHEME_CPTR_HAS_OFFSET(obj) ? ((Scheme_Offset_Cptr *)obj)->offset : 0)
696 #define SCHEME_CPTR_FLAGS(obj) MZ_OPT_HASH_KEY(&((Scheme_Cptr *)(obj))->so)
697 #define SCHEME_CPTR_HAS_OFFSET(obj) (SCHEME_CPTR_FLAGS(obj) & 0x2)
698
699 #define SCHEME_SET_IMMUTABLE(obj) ((MZ_OPT_HASH_KEY((Scheme_Inclhash_Object *)(obj)) |= 0x1))
700 #define SCHEME_SET_CHAR_STRING_IMMUTABLE(obj) SCHEME_SET_IMMUTABLE(obj)
701 #define SCHEME_SET_BYTE_STRING_IMMUTABLE(obj) SCHEME_SET_IMMUTABLE(obj)
702 #define SCHEME_SET_VECTOR_IMMUTABLE(obj) SCHEME_SET_IMMUTABLE(obj)
703 #define SCHEME_SET_BOX_IMMUTABLE(obj) SCHEME_SET_IMMUTABLE(obj)
704
705 /*========================================================================*/
706 /* fast basic Scheme constructor macros */
707 /*========================================================================*/
708
709 #define scheme_make_integer(i) LONG_TO_OBJ ((((uintptr_t)OBJ_TO_LONG(i)) << 1) | 0x1)
710 #define scheme_make_character(ch) ((((mzchar)ch) < 256) ? scheme_char_constants[(unsigned char)(ch)] : scheme_make_char(ch))
711 #define scheme_make_ascii_character(ch) scheme_char_constants[(unsigned char)(ch)]
712
713 #define SCHEME_UCHAR_FIND_SHIFT 8
714 #define SCHEME_UCHAR_FIND_HI_MASK 0x1FFF
715 #define SCHEME_UCHAR_FIND_LO_MASK 0xFF
716
717 #define scheme_uchar_find(table, x) (table[(x >> SCHEME_UCHAR_FIND_SHIFT) & SCHEME_UCHAR_FIND_HI_MASK][x & SCHEME_UCHAR_FIND_LO_MASK])
718
719 #define SCHEME_ISSPACE_BIT 0x10
720
721 #define scheme_isblank(x) ((scheme_uchar_find(scheme_uchar_table, x)) & 0x1)
722 #define scheme_issymbol(x) ((scheme_uchar_find(scheme_uchar_table, x)) & 0x2)
723 #define scheme_ispunc(x) ((scheme_uchar_find(scheme_uchar_table, x)) & 0x4)
724 #define scheme_iscontrol(x) ((scheme_uchar_find(scheme_uchar_table, x)) & 0x8)
725 #define scheme_isspace(x) ((scheme_uchar_find(scheme_uchar_table, x)) & SCHEME_ISSPACE_BIT)
726 /* #define scheme_isSOMETHING(x) ((scheme_uchar_find(scheme_uchar_table, x)) & 0x20) - not yet used */
727 #define scheme_isdigit(x) ((scheme_uchar_find(scheme_uchar_table, x)) & 0x40)
728 #define scheme_isalpha(x) ((scheme_uchar_find(scheme_uchar_table, x)) & 0x80)
729 #define scheme_istitle(x) ((scheme_uchar_find(scheme_uchar_table, x)) & 0x100)
730 #define scheme_isupper(x) ((scheme_uchar_find(scheme_uchar_table, x)) & 0x200)
731 #define scheme_islower(x) ((scheme_uchar_find(scheme_uchar_table, x)) & 0x400)
732 #define scheme_isgraphic(x) ((scheme_uchar_find(scheme_uchar_table, x)) & 0x800)
733 #define scheme_iscaseignorable(x) ((scheme_uchar_find(scheme_uchar_table, x)) & 0x1000)
734 #define scheme_isspecialcasing(x) ((scheme_uchar_find(scheme_uchar_table, x)) & 0x2000)
735 #define scheme_needs_decompose(x) ((scheme_uchar_find(scheme_uchar_table, x)) & 0x4000)
736 #define scheme_needs_maybe_compose(x) ((scheme_uchar_find(scheme_uchar_table, x)) & 0x8000)
737
738 #define scheme_iscased(x) ((scheme_uchar_find(scheme_uchar_table, x)) & 0x700)
739
740 #define scheme_toupper(x) (x + scheme_uchar_ups[scheme_uchar_find(scheme_uchar_cases_table, x)])
741 #define scheme_tolower(x) (x + scheme_uchar_downs[scheme_uchar_find(scheme_uchar_cases_table, x)])
742 #define scheme_totitle(x) (x + scheme_uchar_titles[scheme_uchar_find(scheme_uchar_cases_table, x)])
743 #define scheme_tofold(x) (x + scheme_uchar_folds[scheme_uchar_find(scheme_uchar_cases_table, x)])
744 #define scheme_combining_class(x) (scheme_uchar_combining_classes[scheme_uchar_find(scheme_uchar_cases_table, x)])
745
746 #define scheme_general_category(x) ((scheme_uchar_find(scheme_uchar_cats_table, x)) & 0x1F)
747 /* Note: 3 bits available in the cats table */
748
749 /*========================================================================*/
750 /* procedure values */
751 /*========================================================================*/
752
753 /* Constants for flags in Scheme_Primitive_[Closed]_Proc.
754 Do not use them directly. */
755 #define SCHEME_PRIM_OPT_MASK (1 | 2)
756 #define SCHEME_PRIM_IS_PRIMITIVE 4
757 #define SCHEME_PRIM_IS_MULTI_RESULT 8
758 #define SCHEME_PRIM_IS_CLOSURE 16
759 #define SCHEME_PRIM_OTHER_TYPE_MASK (32 | 64 | 128 | 256)
760
761 #define SCHEME_PRIM_OPT_INDEX_SIZE 7
762 #define SCHEME_PRIM_OPT_INDEX_SHIFT 9
763 #define SCHEME_PRIM_OPT_INDEX_MASK ((1 << SCHEME_PRIM_OPT_INDEX_SIZE) - 1)
764
765 /* Values with SCHEME_PRIM_OPT_MASK, earlier implies later: */
766 #define SCHEME_PRIM_OPT_FOLDING 3
767 #define SCHEME_PRIM_OPT_IMMEDIATE 2
768 #define SCHEME_PRIM_OPT_NONCM 1
769
770 /* Values with SCHEME_PRIM_OTHER_TYPE_MASK */
771 #define SCHEME_PRIM_STRUCT_TYPE_INDEXLESS_GETTER (32 | 256)
772 #define SCHEME_PRIM_STRUCT_TYPE_CONSTR 128
773 #define SCHEME_PRIM_STRUCT_TYPE_SIMPLE_CONSTR (32 | 64 | 128)
774 #define SCHEME_PRIM_STRUCT_TYPE_INDEXLESS_SETTER 256
775 #define SCHEME_PRIM_STRUCT_TYPE_INDEXED_SETTER (128 | 256)
776 #define SCHEME_PRIM_STRUCT_TYPE_BROKEN_INDEXED_SETTER (32 | 128)
777 #define SCHEME_PRIM_TYPE_PARAMETER 64
778 #define SCHEME_PRIM_TYPE_STRUCT_PROP_GETTER (64 | 128)
779 #define SCHEME_PRIM_STRUCT_TYPE_STRUCT_PROP_PRED (64 | 128 | 256)
780 #define SCHEME_PRIM_STRUCT_TYPE_INDEXED_GETTER 32
781 #define SCHEME_PRIM_STRUCT_TYPE_PRED (32 | 64)
782
783 #define SCHEME_PRIM_PROC_FLAGS(x) (((Scheme_Prim_Proc_Header *)x)->flags)
784
785 typedef struct Scheme_Object *(Scheme_Prim)(int argc, Scheme_Object *argv[]);
786
787 typedef struct Scheme_Object *(Scheme_Primitive_Closure_Proc)(int argc, struct Scheme_Object *argv[], Scheme_Object *p);
788
789 #define SCHEME_MAX_ARGS 0x3FFFFFFE
790
791 typedef struct {
792 Scheme_Object so;
793 unsigned short flags;
794 } Scheme_Prim_Proc_Header;
795
796 typedef struct {
797 Scheme_Prim_Proc_Header pp;
798 Scheme_Primitive_Closure_Proc *prim_val;
799 const char *name;
800 mzshort mina;
801 /* If mina < 0; mina is negated case count minus one for a case-lambda
802 generated by mzc, where the primitive checks argument arity
803 itself, and mu.cases is available instead of mu.maxa. */
804 union {
805 mzshort *cases;
806 mzshort maxa; /* > SCHEME_MAX_ARGS => any number of arguments */
807 } mu;
808 } Scheme_Primitive_Proc;
809
810 typedef struct {
811 Scheme_Primitive_Proc pp;
812 mzshort minr, maxr;
813 /* Never combined with a closure */
814 } Scheme_Prim_W_Result_Arity;
815
816 typedef struct Scheme_Primitive_Closure {
817 Scheme_Primitive_Proc p;
818 /* The rest is here only if SCHEME_PRIM_IS_CLOSURE
819 is set in p.pp.flags. */
820 #ifdef MZ_PRECISE_GC
821 mzshort count;
822 #endif
823 Scheme_Object *val[mzFLEX_ARRAY_DECL];
824 } Scheme_Primitive_Closure;
825
826 #define SCHEME_PRIM_CLOSURE_ELS(p) ((Scheme_Primitive_Closure *)p)->val
827
828 /* ------ Old-style primitive closures ------- */
829
830 typedef struct Scheme_Object *(Scheme_Closed_Prim)(void *d, int argc, struct Scheme_Object *argv[]);
831
832 typedef struct {
833 Scheme_Prim_Proc_Header pp;
834 Scheme_Closed_Prim *prim_val;
835 void *data;
836 const char *name;
837 mzshort mina, maxa; /* mina == -2 => maxa is negated case count and
838 record is a Scheme_Closed_Case_Primitive_Proc */
839 } Scheme_Closed_Primitive_Proc;
840
841 typedef struct {
842 Scheme_Closed_Primitive_Proc p;
843 mzshort *cases;
844 } Scheme_Closed_Case_Primitive_Proc;
845
846 typedef struct {
847 Scheme_Closed_Primitive_Proc p;
848 mzshort minr, maxr;
849 } Scheme_Closed_Prim_W_Result_Arity;
850
851 /* ------------------------------------------------- */
852 /* mzc closure glue
853 The following are used by mzc to implement closures.
854 */
855
856 #define _scheme_fill_prim_closure(rec, cfunc, nm, amin, amax, flgs) \
857 ((rec)->pp.so.type = scheme_prim_type, \
858 (rec)->prim_val = cfunc, \
859 (rec)->name = nm, \
860 (rec)->mina = amin, \
861 (rec)->mu.maxa = (amax == -1 ? SCHEME_MAX_ARGS + 1 : amax), \
862 (rec)->pp.flags = flgs, \
863 rec)
864
865 #ifdef MZ_PRECISE_GC
866 # define _scheme_fill_prim_closure_post(rec, cfunc, nm, amin, amax, flgs, ln) \
867 ((rec)->count = ln, \
868 _scheme_fill_prim_closure(&(rec)->p, cfunc, nm, amin, amax, \
869 flgs | SCHEME_PRIM_IS_CLOSURE))
870 #else
871 # define _scheme_fill_prim_closure_post(rec, cfunc, nm, amin, amax, flgs, ln) \
872 _scheme_fill_prim_closure(&(rec)->p, cfunc, nm, amin, amax, flgs)
873 #endif
874
875 #define _scheme_fill_prim_case_closure(rec, cfunc, nm, ccount, cses, flgs) \
876 ((rec)->pp.so.type = scheme_prim_type, \
877 (rec)->prim_val = cfunc, \
878 (rec)->name = nm, \
879 (rec)->mina = -(ccount+1), \
880 (rec)->pp.flags = flgs, \
881 (rec)->mu.cases = cses, \
882 rec)
883
884 #ifdef MZ_PRECISE_GC
885 # define _scheme_fill_prim_case_closure_post(rec, cfunc, nm, ccount, cses, flgs, ln) \
886 ((rec)->count = ln, \
887 _scheme_fill_prim_case_closure(&((rec)->p), cfunc, nm, ccount, cses, \
888 flgs | SCHEME_PRIM_IS_CLOSURE))
889 #else
890 # define _scheme_fill_prim_case_closure_post(rec, cfunc, nm, ccount, cses, flgs, ln) \
891 _scheme_fill_prim_case_closure(&((rec)->p), cfunc, nm, ccount, cses, flgs)
892 #endif
893
894 /* ------------------------------------------------- */
895
896 #define SCHEME_PROCP(obj) (!SCHEME_INTP(obj) && ((_SCHEME_TYPE(obj) >= scheme_prim_type) && (_SCHEME_TYPE(obj) <= scheme_proc_chaperone_type)))
897 #define SCHEME_SYNTAXP(obj) SAME_TYPE(SCHEME_TYPE(obj), scheme_primitive_syntax_type)
898 #define SCHEME_PRIMP(obj) SAME_TYPE(SCHEME_TYPE(obj), scheme_prim_type)
899 #define SCHEME_CLSD_PRIMP(obj) SAME_TYPE(SCHEME_TYPE(obj), scheme_closed_prim_type)
900 #define SCHEME_CONTP(obj) SAME_TYPE(SCHEME_TYPE(obj), scheme_cont_type)
901 #define SCHEME_ECONTP(obj) SAME_TYPE(SCHEME_TYPE(obj), scheme_escaping_cont_type)
902 #define SCHEME_CONT_MARK_SETP(obj) SAME_TYPE(SCHEME_TYPE(obj), scheme_cont_mark_set_type)
903 #define SCHEME_PROC_STRUCTP(obj) SAME_TYPE(SCHEME_TYPE(obj), scheme_proc_struct_type)
904 #define SCHEME_CLOSUREP(obj) (SAME_TYPE(SCHEME_TYPE(obj), scheme_closure_type) || SAME_TYPE(SCHEME_TYPE(obj), scheme_case_closure_type))
905
906 #define SCHEME_PRIM(obj) (((Scheme_Primitive_Proc *)(obj))->prim_val)
907 #define SCHEME_CLSD_PRIM(obj) (((Scheme_Closed_Primitive_Proc *)(obj))->prim_val)
908 #define SCHEME_CLSD_PRIM_DATA(obj) (((Scheme_Closed_Primitive_Proc *)(obj))->data)
909 #define SCHEME_RAW_CLOS_FUNC(obj) ((Scheme_Closure_Func)SCHEME_CAR(obj))
910 #define SCHEME_RAW_CLOS_DATA(obj) SCHEME_CDR(obj)
911
912 /*========================================================================*/
913 /* hash tables and environments */
914 /*========================================================================*/
915
916 typedef struct Scheme_Hash_Table
917 {
918 Scheme_Inclhash_Object iso; /* 0x1 flag => print as opaque (e.g., exports table); 0x2 => misc (e.g., top-level multi_scopes) */
919 intptr_t size; /* power of 2 */
920 intptr_t count;
921 Scheme_Object **keys;
922 Scheme_Object **vals;
923 void (*make_hash_indices)(void *v, intptr_t *h1, intptr_t *h2);
924 int (*compare)(void *v1, void *v2);
925 Scheme_Object *mutex;
926 intptr_t mcount; /* number of non-NULL keys, >= count (which is non-NULL vals) */
927 } Scheme_Hash_Table;
928
929 typedef struct Scheme_Hash_Tree Scheme_Hash_Tree;
930
931 typedef struct Scheme_Bucket
932 {
933 Scheme_Object so;
934 void *val;
935 char *key;
936 } Scheme_Bucket;
937
938 typedef struct Scheme_Bucket_Table
939 {
940 Scheme_Object so;
941 intptr_t size; /* power of 2 */
942 intptr_t count;
943 Scheme_Bucket **buckets;
944 char weak; /* 1 => normal weak, 2 => late weak */
945 char with_home;
946 void (*make_hash_indices)(void *v, intptr_t *h1, intptr_t *h2);
947 int (*compare)(void *v1, void *v2);
948 Scheme_Object *mutex;
949 } Scheme_Bucket_Table;
950
951 /* Hash tablekey types, used with scheme_hash_table */
952 enum {
953 SCHEME_hash_string,
954 SCHEME_hash_ptr,
955 SCHEME_hash_weak_ptr,
956 SCHEME_hash_late_weak_ptr,
957 SCHEME_hash_ephemeron_ptr
958 };
959
960 enum {
961 SCHEME_hashtr_eq,
962 SCHEME_hashtr_equal,
963 SCHEME_hashtr_eqv
964 };
965
966 typedef struct Scheme_Env Scheme_Env;
967
968 #define SCHEME_VAR_BUCKET(obj) ((Scheme_Bucket *)(obj))
969
970 /*========================================================================*/
971 /* setjmpup (continuation) support */
972 /*========================================================================*/
973
974 #ifdef USE_MZ_SETJMP
975 # if defined(_WIN64)
976 # define USE_MZ_SETJMP_INDIRECT
977 typedef intptr_t mz_pre_jmp_buf[31];
978 # else
979 typedef intptr_t mz_pre_jmp_buf[8];
980 # endif
981 #else
982 # define mz_pre_jmp_buf jmp_buf
983 #endif
984
985 #ifdef MZ_USE_JIT
986 typedef struct {
987 mz_pre_jmp_buf jb;
988 uintptr_t stack_frame; /* declared as `uintptr_t' to hide pointer from 3m xform */
989 } mz_one_jit_jmp_buf;
990 typedef mz_one_jit_jmp_buf mz_jit_jmp_buf[1];
991 #else
992 # define mz_jit_jmp_buf mz_pre_jmp_buf
993 #endif
994
995 #ifdef MZ_PRECISE_GC
996 typedef struct {
997 XFORM_CAN_IGNORE mz_jit_jmp_buf jb;
998 intptr_t gcvs; /* declared as `intptr_t' to hide pointer from 3m xform */
999 intptr_t gcvs_cnt;
1000 } mz_jmp_buf;
1001 #else
1002 # define mz_jmp_buf mz_jit_jmp_buf
1003 #endif
1004
1005 /* Like setjmp & longjmp, but you can jmp to a deeper stack position */
1006 /* Initialize a Scheme_Jumpup_Buf record before using it */
1007 typedef struct Scheme_Jumpup_Buf {
1008 void *stack_from, *stack_copy;
1009 intptr_t stack_size, stack_max_size;
1010 struct Scheme_Cont *cont; /* for sharing continuation tails */
1011 mz_jmp_buf buf;
1012 #ifdef MZ_PRECISE_GC
1013 void *gc_var_stack;
1014 void *external_stack;
1015 #endif
1016 } Scheme_Jumpup_Buf;
1017
1018 typedef struct Scheme_Jumpup_Buf_Holder {
1019 Scheme_Type type; /* for precise GC only */
1020 Scheme_Jumpup_Buf buf;
1021 } Scheme_Jumpup_Buf_Holder;
1022
1023 typedef struct Scheme_Continuation_Jump_State {
1024 struct Scheme_Object *jumping_to_continuation;
1025 struct Scheme_Object *alt_full_continuation;
1026 Scheme_Object *val; /* or **vals */
1027 mzshort num_vals;
1028 char is_kill, is_escape, skip_dws;
1029 } Scheme_Continuation_Jump_State;
1030
1031 #ifdef USE_MZ_SETJMP_INDIRECT
1032 /* Needed to avoid a direct reference to scheme_mz_setjmp,
1033 which might be implemented in assembly and incompatible
1034 with delayloading: */
1035 typedef int (*Scheme_Setjmp_Proc)(mz_pre_jmp_buf);
1036 # ifndef MZ_XFORM
1037 # define scheme_call_mz_setjmp(s) ((scheme_get_mz_setjmp())(s))
1038 # else
1039 # define scheme_call_mz_setjmp(s) scheme_mz_setjmp_post_xform(s)
1040 # endif
1041 #else
1042 # ifdef USE_MZ_SETJMP
1043 # define scheme_call_mz_setjmp(s) scheme_mz_setjmp(s)
1044 # endif
1045 typedef int (*Scheme_Setjmp_Proc)(void*);
1046 #endif
1047
1048 /* A mark position is in odd number, so that it can be
1049 viewed as a pointer (i.e., a fixnum): */
1050 #define MZ_MARK_POS_TYPE intptr_t
1051 /* A mark "pointer" is an offset into the stack: */
1052 #define MZ_MARK_STACK_TYPE intptr_t
1053
1054 typedef struct Scheme_Cont_Frame_Data {
1055 MZ_MARK_POS_TYPE cont_mark_pos;
1056 MZ_MARK_STACK_TYPE cont_mark_stack;
1057 void *cache;
1058 } Scheme_Cont_Frame_Data;
1059
1060 /*========================================================================*/
1061 /* threads */
1062 /*========================================================================*/
1063
1064 #ifdef MZ_PRECISE_GC
1065 # ifdef INCLUDE_WITHOUT_PATHS
1066 # include "schgc2obj.h"
1067 # else
1068 # include "../gc2/gc2_obj.h"
1069 # endif
1070 #endif
1071
1072 typedef void (Scheme_Close_Custodian_Client)(Scheme_Object *o, void *data);
1073 typedef void (*Scheme_Exit_Closer_Func)(Scheme_Object *, Scheme_Close_Custodian_Client *, void *);
1074 typedef Scheme_Object *(*Scheme_Custodian_Extractor)(Scheme_Object *o);
1075
1076 #ifdef MZ_PRECISE_GC
1077 typedef struct Scheme_Object Scheme_Custodian_Reference;
1078 #else
1079 typedef struct Scheme_Custodian *Scheme_Custodian_Reference;
1080 #endif
1081
1082 typedef struct Scheme_Custodian Scheme_Custodian;
1083 typedef Scheme_Bucket_Table Scheme_Thread_Cell_Table;
1084 typedef struct Scheme_Config Scheme_Config;
1085 typedef struct Scheme_Plumber Scheme_Plumber;
1086
1087 typedef int (*Scheme_Ready_Fun)(Scheme_Object *o);
1088 typedef void (*Scheme_Needs_Wakeup_Fun)(Scheme_Object *, void *);
1089 typedef Scheme_Object *(*Scheme_Sync_Sema_Fun)(Scheme_Object *, int *repost);
1090 typedef int (*Scheme_Sync_Filter_Fun)(Scheme_Object *);
1091
1092 /* The Scheme_Thread structure represents a Racket thread. */
1093
1094 typedef struct Scheme_Thread {
1095 Scheme_Object so;
1096
1097 struct Scheme_Thread *next;
1098 struct Scheme_Thread *prev;
1099
1100 struct Scheme_Thread_Set *t_set_parent;
1101 Scheme_Object *t_set_next;
1102 Scheme_Object *t_set_prev;
1103
1104 mz_jmp_buf *error_buf;
1105 Scheme_Continuation_Jump_State cjs;
1106 struct Scheme_Meta_Continuation *decompose_mc; /* set during a jump */
1107
1108 Scheme_Thread_Cell_Table *cell_values;
1109 Scheme_Config *init_config;
1110
1111 Scheme_Object *init_break_cell;
1112 int can_break_at_swap;
1113
1114 Scheme_Object **runstack;
1115 Scheme_Object **runstack_start;
1116 intptr_t runstack_size;
1117 struct Scheme_Saved_Stack *runstack_saved;
1118 Scheme_Object **runstack_tmp_keep;
1119
1120 Scheme_Object **spare_runstack; /* in case of bouncing, we keep a recently
1121 released runstack; it's dropped on GC, though */
1122 intptr_t spare_runstack_size;
1123
1124 struct Scheme_Thread **runstack_owner;
1125 struct Scheme_Saved_Stack *runstack_swapped;
1126
1127 MZ_MARK_POS_TYPE cont_mark_pos; /* depth of the continuation chain */
1128 MZ_MARK_STACK_TYPE cont_mark_stack; /* current mark stack position */
1129 struct Scheme_Cont_Mark **cont_mark_stack_segments;
1130 intptr_t cont_mark_seg_count;
1131 intptr_t cont_mark_stack_bottom; /* for restored delimited continuations */
1132 intptr_t cont_mark_pos_bottom; /* for splicing cont marks in meta continuations */
1133
1134 struct Scheme_Thread **cont_mark_stack_owner;
1135 struct Scheme_Cont_Mark *cont_mark_stack_swapped;
1136
1137 struct Scheme_Prompt *meta_prompt; /* a pseudo-prompt */
1138
1139 struct Scheme_Meta_Continuation *meta_continuation;
1140 struct Scheme_Prompt *acting_barrier_prompt;
1141
1142 intptr_t engine_weight;
1143
1144 void *stack_start; /* This is the C stack base of the thread, which
1145 corresponds to the starting stack address for
1146 paging out the thread, and in 3m corresponds to
1147 the starting stack address for GC marking. In non-3m,
1148 it can be 0, which means that the deepest (non-main)
1149 thread starting address should be used. This value will
1150 change when a continuation is applied under a prompt,
1151 and it will be changed on stack overflow. */
1152 void *stack_end; /* The end of the C stack, for determine stack overflow.
1153 Currently, this is the same for all threads. */
1154
1155 Scheme_Jumpup_Buf jmpup_buf; /* For jumping back to this thread */
1156
1157 struct Scheme_Dynamic_Wind *dw;
1158 int next_meta; /* amount to move forward in the meta-continuaiton chain, starting with dw */
1159
1160 int running;
1161 Scheme_Object *suspended_box; /* contains pointer to thread when it's suspended */
1162 Scheme_Object *resumed_box; /* contains pointer to thread when it's resumed */
1163 Scheme_Object *dead_box; /* contains non-zero when the thread is dead */
1164 Scheme_Object *running_box; /* contains pointer to thread when it's running */
1165 Scheme_Object *sync_box; /* semaphore used for NACK events */
1166
1167 struct Scheme_Thread *gc_prep_chain;
1168
1169 struct Scheme_Thread *nester, *nestee;
1170
1171 struct future_t *current_ft;
1172
1173 double sleep_end; /* blocker has starting sleep time */
1174 int block_descriptor;
1175 Scheme_Object *blocker; /* semaphore or port */
1176 Scheme_Ready_Fun block_check;
1177 Scheme_Needs_Wakeup_Fun block_needs_wakeup;
1178 char ran_some;
1179 char suspend_to_kill;
1180
1181 struct Scheme_Thread *return_marks_to;
1182 Scheme_Object *returned_marks;
1183
1184 struct Scheme_Overflow *overflow;
1185
1186 struct Scheme_Marshal_Tables *current_mt;
1187
1188 struct Optimize_Info *constant_folding; /* compiler hack */
1189 Scheme_Object *reading_delayed; /* reader hack */
1190
1191 Scheme_Object *(*overflow_k)(void);
1192 Scheme_Object *overflow_reply;
1193
1194 /* content of tail_buffer is zeroed on GC, unless
1195 runstack_tmp_keep is set to tail_buffer */
1196 Scheme_Object **tail_buffer;
1197 int tail_buffer_size;
1198
1199 /* values_buffer is used to avoid allocating for `values'
1200 calls. When ku.multiple.array is not the same as
1201 values_buffer, then it can be zeroed at GC points. */
1202 Scheme_Object **values_buffer;
1203 int values_buffer_size;
1204
1205 struct { /* used to be a union, but that confuses MZ_PRECISE_GC */
1206 struct {
1207 Scheme_Object *wait_expr;
1208 } eval;
1209 struct {
1210 Scheme_Object *tail_rator;
1211 Scheme_Object **tail_rands;
1212 intptr_t tail_num_rands;
1213 } apply;
1214 struct {
1215 Scheme_Object **array;
1216 intptr_t count;
1217 } multiple;
1218 struct {
1219 void *p1, *p2, *p3, *p4, *p5;
1220 intptr_t i1, i2, i3, i4;
1221 } k;
1222 } ku;
1223
1224 /* To pass the current procedure from one chaperone
1225 layer to the next: */
1226 Scheme_Object *self_for_proc_chaperone;
1227
1228 short suspend_break;
1229 short external_break;
1230
1231 /* Racket client can use: */
1232 void (*on_kill)(struct Scheme_Thread *p);
1233 void *kill_data;
1234
1235 /* Racket use only: */
1236 void (*private_on_kill)(void *);
1237 void *private_kill_data;
1238 void **private_kill_next; /* array of three pointers */
1239
1240 void **user_tls;
1241 int user_tls_size;
1242
1243 /* save thread-specific GMP state: */
1244 intptr_t gmp_tls[6];
1245 void *gmp_tls_data;
1246
1247 intptr_t accum_process_msec;
1248 intptr_t current_start_process_msec;
1249
1250 struct Scheme_Thread_Custodian_Hop *mr_hop;
1251 Scheme_Custodian_Reference *mref;
1252 Scheme_Object *extra_mrefs; /* More owning custodians */
1253 Scheme_Object *transitive_resumes; /* A hash table of running-boxes */
1254
1255 Scheme_Object *name;
1256
1257 Scheme_Object *mbox_first;
1258 Scheme_Object *mbox_last;
1259 Scheme_Object *mbox_sema;
1260
1261 long saved_errno;
1262
1263 int futures_slow_path_tracing;
1264
1265 #ifdef MZ_PRECISE_GC
1266 struct GC_Thread_Info *gc_info; /* managed by the GC */
1267 void *place_channel_msg_in_flight;
1268 void *place_channel_msg_chain_in_flight;
1269 #endif
1270
1271 } Scheme_Thread;
1272
1273 #include "schthread.h"
1274
1275 #if !SCHEME_DIRECT_EMBEDDED
1276 # ifdef LINK_EXTENSIONS_BY_TABLE
1277 # define scheme_current_thread (*scheme_current_thread_ptr)
1278 # endif
1279 #endif
1280
1281 typedef void (*Scheme_Kill_Action_Func)(void *);
1282
1283 #define ESCAPE_BLOCK(return_code) \
1284 thread = scheme_get_current_thread(); \
1285 savebuf = thread->error_buf; \
1286 thread->error_buf = &newbuf; \
1287 thread = NULL; \
1288 if (scheme_setjmp(newbuf)) \
1289 { \
1290 thread = scheme_get_current_thread(); \
1291 thread->error_buf = savebuf; \
1292 scheme_clear_escape(); \
1293 return return_code; \
1294 }
1295
1296 # define BEGIN_ESCAPEABLE(func, data) \
1297 { mz_jmp_buf * volatile savebuf, newbuf; \
1298 Scheme_Thread *thread; \
1299 thread = scheme_get_current_thread(); \
1300 scheme_push_kill_action((Scheme_Kill_Action_Func)func, (void *)data); \
1301 savebuf = thread->error_buf; \
1302 thread->error_buf = &newbuf; \
1303 thread = NULL; \
1304 if (scheme_setjmp(newbuf)) { \
1305 scheme_pop_kill_action(); \
1306 thread = scheme_get_current_thread(); \
1307 if (!thread->cjs.skip_dws) { \
1308 func(data); \
1309 } \
1310 scheme_longjmp(*savebuf, 1); \
1311 } else {
1312 # define END_ESCAPEABLE() \
1313 thread = scheme_get_current_thread(); \
1314 scheme_pop_kill_action(); \
1315 thread->error_buf = savebuf; \
1316 thread = NULL; } }
1317
1318 typedef int (*Scheme_Frozen_Stack_Proc)(void *);
1319
1320 /*========================================================================*/
1321 /* parameters */
1322 /*========================================================================*/
1323
1324 enum {
1325 MZCONFIG_ENV,
1326 MZCONFIG_INPUT_PORT,
1327 MZCONFIG_OUTPUT_PORT,
1328 MZCONFIG_ERROR_PORT,
1329
1330 MZCONFIG_ERROR_DISPLAY_HANDLER,
1331 MZCONFIG_ERROR_PRINT_VALUE_HANDLER,
1332 MZCONFIG_ERROR_PRINT_SYNTAX_HANDLER,
1333
1334 MZCONFIG_EXIT_HANDLER,
1335
1336 MZCONFIG_INIT_EXN_HANDLER,
1337
1338 MZCONFIG_PRINT_HANDLER,
1339 MZCONFIG_PROMPT_READ_HANDLER,
1340 MZCONFIG_READ_HANDLER,
1341 MZCONFIG_READ_INPUT_PORT_HANDLER,
1342
1343 MZCONFIG_CASE_SENS,
1344 MZCONFIG_CAN_READ_PIPE_QUOTE,
1345
1346 MZCONFIG_PRINT_GRAPH,
1347 MZCONFIG_PRINT_STRUCT,
1348 MZCONFIG_PRINT_BOX,
1349 MZCONFIG_PRINT_VEC_SHORTHAND,
1350 MZCONFIG_PRINT_HASH_TABLE,
1351 MZCONFIG_PRINT_UNREADABLE,
1352 MZCONFIG_PRINT_PAIR_CURLY,
1353 MZCONFIG_PRINT_MPAIR_CURLY,
1354 MZCONFIG_PRINT_SYNTAX_WIDTH,
1355 MZCONFIG_PRINT_READER,
1356 MZCONFIG_PRINT_LONG_BOOLEAN,
1357 MZCONFIG_PRINT_AS_QQ,
1358
1359 MZCONFIG_ERROR_PRINT_WIDTH,
1360 MZCONFIG_ERROR_PRINT_CONTEXT_LENGTH,
1361
1362 MZCONFIG_ERROR_ESCAPE_HANDLER,
1363
1364 MZCONFIG_EXE_YIELD_HANDLER,
1365
1366 MZCONFIG_ALLOW_SET_UNDEFINED,
1367 MZCONFIG_COMPILE_MODULE_CONSTS,
1368 MZCONFIG_USE_JIT,
1369 MZCONFIG_DISALLOW_INLINE,
1370 MZCONFIG_COMPILE_TARGET_MACHINE,
1371
1372 MZCONFIG_CUSTODIAN,
1373 MZCONFIG_INSPECTOR,
1374 MZCONFIG_CODE_INSPECTOR,
1375 MZCONFIG_PLUMBER,
1376
1377 MZCONFIG_LOAD_DIRECTORY,
1378 MZCONFIG_WRITE_DIRECTORY,
1379
1380 MZCONFIG_PORT_PRINT_HANDLER,
1381
1382 MZCONFIG_LOAD_EXTENSION_HANDLER,
1383
1384 MZCONFIG_CURRENT_DIRECTORY,
1385 MZCONFIG_CURRENT_ENV_VARS,
1386 MZCONFIG_FORCE_DELETE_PERMS,
1387
1388 MZCONFIG_CURRENT_USER_DIRECTORY,
1389
1390 MZCONFIG_RANDOM_STATE,
1391
1392 MZCONFIG_CURRENT_MODULE_SRC,
1393
1394 MZCONFIG_ERROR_PRINT_SRCLOC,
1395
1396 MZCONFIG_CMDLINE_ARGS,
1397
1398 MZCONFIG_LOCALE,
1399
1400 MZCONFIG_SECURITY_GUARD,
1401
1402 MZCONFIG_PORT_COUNT_LINES,
1403
1404 MZCONFIG_SCHEDULER_RANDOM_STATE,
1405
1406 MZCONFIG_THREAD_SET,
1407 MZCONFIG_THREAD_INIT_STACK_SIZE,
1408
1409 MZCONFIG_SUBPROC_CUSTODIAN_MODE,
1410 MZCONFIG_SUBPROC_GROUP_ENABLED,
1411
1412 MZCONFIG_LOAD_DELAY_ENABLED,
1413 MZCONFIG_DELAY_LOAD_INFO,
1414
1415 MZCONFIG_LOGGER,
1416
1417 __MZCONFIG_BUILTIN_COUNT__
1418 };
1419
1420 /*========================================================================*/
1421 /* ports */
1422 /*========================================================================*/
1423
1424 typedef struct Scheme_Input_Port Scheme_Input_Port;
1425 typedef struct Scheme_Output_Port Scheme_Output_Port;
1426 typedef struct Scheme_Port Scheme_Port;
1427
1428 typedef intptr_t (*Scheme_Get_String_Fun)(Scheme_Input_Port *port,
1429 char *buffer, intptr_t offset, intptr_t size,
1430 int nonblock, Scheme_Object *unless);
1431 typedef intptr_t (*Scheme_Peek_String_Fun)(Scheme_Input_Port *port,
1432 char *buffer, intptr_t offset, intptr_t size,
1433 Scheme_Object *skip,
1434 int nonblock, Scheme_Object *unless);
1435 typedef Scheme_Object *(*Scheme_Progress_Evt_Fun)(Scheme_Input_Port *port);
1436 typedef int (*Scheme_Peeked_Read_Fun)(Scheme_Input_Port *port,
1437 intptr_t amount,
1438 Scheme_Object *unless_evt,
1439 Scheme_Object *target_ch);
1440 typedef int (*Scheme_In_Ready_Fun)(Scheme_Input_Port *port);
1441 typedef void (*Scheme_Close_Input_Fun)(Scheme_Input_Port *port);
1442 typedef void (*Scheme_Need_Wakeup_Input_Fun)(Scheme_Input_Port *, void *);
1443
1444 typedef Scheme_Object *(*Scheme_Location_Fun)(Scheme_Port *);
1445 typedef void (*Scheme_Count_Lines_Fun)(Scheme_Port *);
1446 typedef int (*Scheme_Buffer_Mode_Fun)(Scheme_Port *, int m);
1447
1448 typedef Scheme_Object *(*Scheme_Write_String_Evt_Fun)(Scheme_Output_Port *,
1449 const char *str, intptr_t offset, intptr_t size);
1450 typedef intptr_t (*Scheme_Write_String_Fun)(Scheme_Output_Port *,
1451 const char *str, intptr_t offset, intptr_t size,
1452 int rarely_block, int enable_break);
1453 typedef int (*Scheme_Out_Ready_Fun)(Scheme_Output_Port *port);
1454 typedef void (*Scheme_Close_Output_Fun)(Scheme_Output_Port *port);
1455 typedef void (*Scheme_Need_Wakeup_Output_Fun)(Scheme_Output_Port *, void *);
1456 typedef Scheme_Object *(*Scheme_Write_Special_Evt_Fun)(Scheme_Output_Port *, Scheme_Object *);
1457 typedef int (*Scheme_Write_Special_Fun)(Scheme_Output_Port *, Scheme_Object *,
1458 int nonblock);
1459
1460 struct Scheme_Port
1461 {
1462 Scheme_Object so;
1463 char count_lines, was_cr;
1464 intptr_t position, readpos, lineNumber, charsSinceNewline;
1465 intptr_t column, oldColumn; /* column tracking with one tab/newline ungetc */
1466 int utf8state;
1467 Scheme_Location_Fun location_fun;
1468 Scheme_Count_Lines_Fun count_lines_fun;
1469 Scheme_Buffer_Mode_Fun buffer_mode_fun;
1470 Scheme_Object *position_redirect; /* for `file-position' */
1471 };
1472
1473 struct Scheme_Input_Port
1474 {
1475 struct Scheme_Port p;
1476 char slow; /* 0 => no line count, no ungotten, etc.: can call get_string_fun directly */
1477 char closed, pending_eof;
1478 Scheme_Object *sub_type;
1479 Scheme_Object *closed_evt;
1480 Scheme_Custodian_Reference *mref;
1481 void *port_data;
1482 Scheme_Get_String_Fun get_string_fun;
1483 Scheme_Peek_String_Fun peek_string_fun;
1484 Scheme_Progress_Evt_Fun progress_evt_fun;
1485 Scheme_Peeked_Read_Fun peeked_read_fun;
1486 Scheme_In_Ready_Fun byte_ready_fun;
1487 Scheme_Close_Input_Fun close_fun;
1488 Scheme_Need_Wakeup_Input_Fun need_wakeup_fun;
1489 Scheme_Object *read_handler;
1490 Scheme_Object *name;
1491 Scheme_Object *peeked_read, *peeked_write;
1492 Scheme_Object *progress_evt, *input_lock, *input_giveup, *input_extras, *input_extras_ready;
1493 unsigned char ungotten[24];
1494 int ungotten_count;
1495 Scheme_Object *special, *ungotten_special;
1496 Scheme_Object *unless, *unless_cache;
1497 struct Scheme_Output_Port *output_half;
1498 #ifdef WINDOWS_FILE_HANDLES
1499 char *bufwidths; /* to track CRLF => LF conversions in the buffer */
1500 #endif
1501 };
1502
1503 #define SCHEME_INPORT_VAL(i) (((Scheme_Input_Port *)i)->port_data)
1504
1505 struct Scheme_Output_Port
1506 {
1507 struct Scheme_Port p;
1508 short closed;
1509 Scheme_Object *sub_type;
1510 Scheme_Object *closed_evt;
1511 Scheme_Custodian_Reference *mref;
1512 void *port_data;
1513 Scheme_Write_String_Evt_Fun write_string_evt_fun;
1514 Scheme_Write_String_Fun write_string_fun;
1515 Scheme_Close_Output_Fun close_fun;
1516 Scheme_Out_Ready_Fun ready_fun;
1517 Scheme_Need_Wakeup_Output_Fun need_wakeup_fun;
1518 Scheme_Write_Special_Evt_Fun write_special_evt_fun;
1519 Scheme_Write_Special_Fun write_special_fun;
1520 intptr_t pos;
1521 Scheme_Object *name;
1522 Scheme_Object *display_handler;
1523 Scheme_Object *write_handler;
1524 Scheme_Object *print_handler;
1525 struct Scheme_Input_Port *input_half;
1526 };
1527
1528 #define SCHEME_OUTPORT_VAL(o) (((Scheme_Output_Port *)o)->port_data)
1529
1530 #define SCHEME_SPECIAL (-2)
1531 #define SCHEME_UNLESS_READY (-3)
1532
1533 /*========================================================================*/
1534 /* exceptions */
1535 /*========================================================================*/
1536
1537 /* This file includes the MZEXN constants */
1538 #ifdef INCLUDE_WITHOUT_PATHS
1539 # include "schexn.h"
1540 #else
1541 # include "../src/schexn.h"
1542 #endif
1543
1544 #define SCHEME_LOG_FATAL 1
1545 #define SCHEME_LOG_ERROR 2
1546 #define SCHEME_LOG_WARNING 3
1547 #define SCHEME_LOG_INFO 4
1548 #define SCHEME_LOG_DEBUG 5
1549
1550 typedef struct Scheme_Logger Scheme_Logger;
1551
1552 /*========================================================================*/
1553 /* security */
1554 /*========================================================================*/
1555
1556 #define SCHEME_GUARD_FILE_READ 0x1
1557 #define SCHEME_GUARD_FILE_WRITE 0x2
1558 #define SCHEME_GUARD_FILE_EXECUTE 0x4
1559 #define SCHEME_GUARD_FILE_DELETE 0x8
1560 #define SCHEME_GUARD_FILE_EXISTS 0x10
1561
1562 /*========================================================================*/
1563 /* evaluation */
1564 /*========================================================================*/
1565
1566 /* Exploit the fact that these should never be dereferenced: */
1567 #ifndef FIRST_TWO_BYTES_ARE_LEGAL_ADDRESSES
1568 # define MZ_EVAL_WAITING_CONSTANT ((Scheme_Object *)0x2)
1569 # define MZ_APPLY_WAITING_CONSTANT ((Scheme_Object *)0x4)
1570 # define MZ_MULTIPLE_VALUES_CONSTANT ((Scheme_Object *)0x6)
1571 #endif
1572
1573 #ifdef MZ_EVAL_WAITING_CONSTANT
1574 # define SCHEME_EVAL_WAITING MZ_EVAL_WAITING_CONSTANT
1575 # define SCHEME_TAIL_CALL_WAITING MZ_APPLY_WAITING_CONSTANT
1576 # define SCHEME_MULTIPLE_VALUES MZ_MULTIPLE_VALUES_CONSTANT
1577 #else
1578 # define SCHEME_TAIL_CALL_WAITING scheme_tail_call_waiting
1579 # define SCHEME_EVAL_WAITING scheme_eval_waiting
1580 # define SCHEME_MULTIPLE_VALUES scheme_multiple_values
1581 #endif
1582
1583 #define SCHEME_ASSERT(expr,msg) ((expr) ? 1 : (scheme_signal_error(msg), 0))
1584
1585 #ifdef MZ_CAN_ACCESS_THREAD_LOCAL_DIRECTLY
1586 # define mzSCHEME_CURRENT_THREAD scheme_current_thread
1587 #else
1588 # define mzSCHEME_CURRENT_THREAD scheme_get_current_thread()
1589 #endif
1590
1591 #define scheme_eval_wait_expr (mzSCHEME_CURRENT_THREAD->ku.eval.wait_expr)
1592 #define scheme_tail_rator (mzSCHEME_CURRENT_THREAD->ku.apply.tail_rator)
1593 #define scheme_tail_num_rands (mzSCHEME_CURRENT_THREAD->ku.apply.tail_num_rands)
1594 #define scheme_tail_rands (mzSCHEME_CURRENT_THREAD->ku.apply.tail_rands)
1595 #define scheme_overflow_reply (mzSCHEME_CURRENT_THREAD->overflow_reply)
1596
1597 #define scheme_error_buf *(mzSCHEME_CURRENT_THREAD->error_buf)
1598 #define scheme_jumping_to_continuation (mzSCHEME_CURRENT_THREAD->cjs.jumping_to_continuation)
1599
1600 #define scheme_multiple_count (mzSCHEME_CURRENT_THREAD->ku.multiple.count)
1601 #define scheme_multiple_array (mzSCHEME_CURRENT_THREAD->ku.multiple.array)
1602
1603 #define scheme_setjmpup(b, base, s) scheme_setjmpup_relative(b, base, s, NULL)
1604
1605 #define scheme_do_eval_w_thread(r,n,e,f,p) scheme_do_eval(r,n,e,f)
1606 #define scheme_apply_wp(r,n,a,p) scheme_apply(r,n,a)
1607 #define scheme_apply_multi_wp(r,n,a,p) scheme_apply_multi(r,n,a)
1608 #define scheme_apply_eb_wp(r,n,a,p) scheme_apply_eb(r,n,a)
1609 #define scheme_apply_multi_eb_wp(r,n,a,p) scheme_apply_multi_eb(r,n,a)
1610
1611 #define _scheme_apply(r,n,rs) scheme_do_eval(r,n,rs,1)
1612 #define _scheme_apply_multi(r,n,rs) scheme_do_eval(r,n,rs,-1)
1613 #define _scheme_apply_wp(r,n,rs,p) scheme_do_eval_w_thread(r,n,rs,1,p)
1614 #define _scheme_apply_multi_wp(r,n,rs,p) scheme_do_eval_w_thread(r,n,rs,-1,p)
1615 #define _scheme_tail_apply scheme_tail_apply
1616 #define _scheme_tail_apply_wp scheme_tail_apply_wp
1617
1618 #define _scheme_tail_eval scheme_tail_eval
1619 #define _scheme_tail_eval_wp scheme_tail_eval_wp
1620
1621 #define _scheme_direct_apply_primitive_multi(prim, argc, argv) \
1622 (((Scheme_Primitive_Proc *)prim)->prim_val(argc, argv, prim))
1623 #define _scheme_direct_apply_primitive(prim, argc, argv) \
1624 scheme_check_one_value(_scheme_direct_apply_primitive_multi(prim, argc, argv))
1625 #define _scheme_direct_apply_primitive_closure_multi(prim, argc, argv) \
1626 _scheme_direct_apply_primitive_multi(prim, argc, argv)
1627 #define _scheme_direct_apply_primitive_closure(prim, argc, argv) \
1628 _scheme_direct_apply_primitive(prim, argc, argv)
1629 #define _scheme_direct_apply_closed_primitive_multi(prim, argc, argv) \
1630 (((Scheme_Closed_Primitive_Proc *)prim)->prim_val(((Scheme_Closed_Primitive_Proc *)prim)->data, argc, argv))
1631 #define _scheme_direct_apply_closed_primitive(prim, argc, argv) \
1632 scheme_check_one_value(_scheme_direct_apply_closed_primitive_multi(prim, argc, argv))
1633
1634 #define _scheme_force_value(v) ((v == SCHEME_TAIL_CALL_WAITING) ? scheme_force_value(v) : v)
1635
1636 #define scheme_tail_apply_buffer_wp(n, p) ((p)->tail_buffer)
1637 #define scheme_tail_apply_buffer(n) \
1638 { \
1639 Scheme_Thread *thread; \
1640 thread = scheme_get_current_thread(); \
1641 scheme_tail_apply_buffer_wp(n, thread);\
1642 }
1643
1644 #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)
1645 #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)
1646 #define _scheme_tail_apply_no_copy(f, n, args) \
1647 { \
1648 Scheme_Thread *thread; \
1649 thread = scheme_get_current_thread(); \
1650 _scheme_tail_apply_no_copy_wp(f, n, args, thread) \
1651 }
1652
1653 #define scheme_thread_block_w_thread(t,p) scheme_thread_block(t)
1654
1655 #if !SCHEME_DIRECT_EMBEDDED
1656 # ifdef LINK_EXTENSIONS_BY_TABLE
1657 # define scheme_fuel_counter (*scheme_fuel_counter_ptr)
1658 # endif
1659 #else
1660 THREAD_LOCAL_DECL(MZ_EXTERN volatile int scheme_fuel_counter);
1661 #endif
1662
1663 #ifdef FUEL_AUTODECEREMENTS
1664 # define DECREMENT_FUEL(f, p) (f)
1665 #else
1666 # define DECREMENT_FUEL(f, p) (f -= (p))
1667 #endif
1668
1669 #define SCHEME_USE_FUEL(n) \
1670 { if (DECREMENT_FUEL(scheme_fuel_counter, n) <= 0) { scheme_out_of_fuel(); }}
1671
1672 #if SCHEME_DIRECT_EMBEDDED
1673 MZ_EXTERN Scheme_Object *scheme_eval_waiting;
1674 #define scheme_tail_eval(obj) \
1675 (scheme_eval_wait_expr = obj, SCHEME_EVAL_WAITING)
1676 #endif
1677
1678 #define scheme_break_waiting(p) (p->external_break)
1679
1680 #ifndef USE_MZ_SETJMP
1681 # ifdef USE_UNDERSCORE_SETJMP
1682 # define scheme_mz_longjmp(b, v) _longjmp(b, v)
1683 # define scheme_call_mz_setjmp(b) _setjmp(b)
1684 # else
1685 # define scheme_mz_longjmp(b, v) longjmp(b, v)
1686 # define scheme_call_mz_setjmp(b) setjmp(b)
1687 # endif
1688 #endif
1689
1690 #ifdef MZ_USE_JIT
1691 MZ_EXTERN MZ_NORETURN void scheme_jit_longjmp(mz_jit_jmp_buf b, int v);
1692 MZ_EXTERN void scheme_jit_setjmp_prepare(mz_jit_jmp_buf b);
1693 # define scheme_jit_setjmp(b) (scheme_jit_setjmp_prepare(b), scheme_call_mz_setjmp((b)->jb))
1694 #else
1695 # define scheme_jit_longjmp(b, v) scheme_mz_longjmp(b, v)
1696 # define scheme_jit_setjmp(b) scheme_call_mz_setjmp(b)
1697 #endif
1698
1699 #ifdef MZ_PRECISE_GC
1700 /* Need to make sure that a __gc_var_stack__ is always available where
1701 setjmp & longjmp are used. */
1702 # define scheme_longjmp(b, v) (((intptr_t *)(void*)((b).gcvs))[1] = (b).gcvs_cnt, \
1703 GC_variable_stack = (void **)(void*)(b).gcvs, \
1704 scheme_jit_longjmp((b).jb, v))
1705 # define scheme_setjmp(b) ((b).gcvs = (intptr_t)__gc_var_stack__, \
1706 (b).gcvs_cnt = XFORM_CURRENT_COUNT, \
1707 scheme_jit_setjmp((b).jb))
1708 # ifndef MZ_XFORM
1709 # define XFORM_CURRENT_COUNT (intptr_t)(__gc_var_stack__[1])
1710 # endif
1711 #else
1712 # define scheme_longjmp(b, v) scheme_jit_longjmp(b, v)
1713 # define scheme_setjmp(b) scheme_jit_setjmp(b)
1714 #endif
1715
1716 /*========================================================================*/
1717 /* memory management macros */
1718 /*========================================================================*/
1719
1720 /* Allocation */
1721 #define scheme_alloc_object() \
1722 ((Scheme_Object *) scheme_malloc_small_tagged(sizeof(Scheme_Simple_Object)))
1723 #define scheme_alloc_small_object() \
1724 ((Scheme_Object *) scheme_malloc_small_tagged(sizeof(Scheme_Small_Object)))
1725 #define scheme_alloc_stubborn_object() \
1726 ((Scheme_Object *) scheme_malloc_stubborn_tagged(sizeof(Scheme_Simple_Object)))
1727 #define scheme_alloc_stubborn_small_object() \
1728 ((Scheme_Object *) scheme_malloc_stubborn_tagged(sizeof(Scheme_Small_Object)))
1729 #define scheme_alloc_eternal_object() \
1730 ((Scheme_Object *) scheme_malloc_eternal_tagged(sizeof(Scheme_Simple_Object)))
1731 #define scheme_alloc_eternal_small_object() \
1732 ((Scheme_Object *) scheme_malloc_eternal_tagged(sizeof(Scheme_Small_Object)))
1733
1734 #ifdef SCHEME_NO_GC
1735 void *scheme_malloc(size_t size);
1736 # define scheme_malloc_atomic scheme_malloc
1737 # define scheme_malloc_stubborn scheme_malloc
1738 # define scheme_malloc_uncollectable scheme_malloc
1739 #else
1740 # define scheme_malloc GC_malloc
1741 # define scheme_malloc_atomic GC_malloc_atomic
1742 # ifdef MZ_PRECISE_GC
1743 # define scheme_malloc_stubborn scheme_malloc
1744 # else
1745 # define scheme_malloc_stubborn GC_malloc_stubborn
1746 # define scheme_malloc_uncollectable GC_malloc_uncollectable
1747 # endif
1748 #endif
1749
1750 #ifdef USE_MEMORY_TRACING
1751 # define USE_TAGGED_ALLOCATION
1752 # define MEMORY_COUNTING_ON
1753 #endif
1754
1755 #ifdef MZ_PRECISE_GC
1756 # ifndef GC2_EXTERN
1757 # define GC2_EXTERN MZ_EXTERN
1758 # endif
1759 # ifdef INCLUDE_WITHOUT_PATHS
1760 # if !SCHEME_DIRECT_EMBEDDED
1761 # define GC2_JUST_MACROS_AND_TYPEDEFS
1762 # endif
1763 # include "schemegc2.h"
1764 # else
1765 # include "../gc2/gc2.h"
1766 # endif
1767 # define scheme_malloc_tagged GC_malloc_one_tagged
1768 # define scheme_malloc_small_tagged(s) GC_malloc_one_small_tagged(gcWORDS_TO_BYTES(gcBYTES_TO_WORDS(s)))
1769 # define scheme_malloc_small_dirty_tagged(s) GC_malloc_one_small_dirty_tagged(gcWORDS_TO_BYTES(gcBYTES_TO_WORDS(s)))
1770 # define scheme_malloc_small_atomic_tagged(s) GC_malloc_small_atomic_tagged(gcWORDS_TO_BYTES(gcBYTES_TO_WORDS(s)))
1771 # define scheme_malloc_array_tagged GC_malloc_array_tagged
1772 # define scheme_malloc_atomic_tagged GC_malloc_atomic_tagged
1773 # define scheme_malloc_stubborn_tagged GC_malloc_one_tagged
1774 # define scheme_malloc_eternal_tagged GC_malloc_atomic_uncollectable
1775 # define scheme_malloc_uncollectable_tagged >> error <<
1776 # define scheme_malloc_envunbox GC_malloc
1777 # define scheme_malloc_weak GC_malloc_weak
1778 # define scheme_malloc_weak_tagged GC_malloc_one_weak_tagged
1779 # define scheme_malloc_allow_interior GC_malloc_allow_interior
1780 # define scheme_malloc_atomic_allow_interior GC_malloc_atomic_allow_interior
1781 #else
1782 # ifdef USE_TAGGED_ALLOCATION
1783 extern void *scheme_malloc_tagged(size_t);
1784 # define scheme_malloc_array_tagged scheme_malloc
1785 # define scheme_malloc_small_tagged scheme_malloc
1786 extern void *scheme_malloc_atomic_tagged(size_t);
1787 extern void *scheme_malloc_stubborn_tagged(size_t);
1788 extern void *scheme_malloc_eternal_tagged(size_t);
1789 extern void *scheme_malloc_uncollectable_tagged(size_t);
1790 extern void *scheme_malloc_envunbox(size_t);
1791 # else
1792 # define scheme_malloc_tagged scheme_malloc
1793 # define scheme_malloc_small_tagged scheme_malloc
1794 # define scheme_malloc_array_tagged scheme_malloc
1795 # define scheme_malloc_atomic_tagged scheme_malloc_atomic
1796 # define scheme_malloc_stubborn_tagged scheme_malloc_stubborn
1797 # define scheme_malloc_eternal_tagged scheme_malloc_eternal
1798 # define scheme_malloc_uncollectable_tagged scheme_malloc_uncollectable
1799 # define scheme_malloc_envunbox scheme_malloc
1800 # endif
1801 # define scheme_malloc_small_dirty_tagged scheme_malloc_small_tagged
1802 # define scheme_malloc_allow_interior scheme_malloc
1803 # define scheme_malloc_atomic_allow_interior scheme_malloc_atomic
1804 # define scheme_malloc_small_atomic_tagged scheme_malloc_atomic_tagged
1805 #endif
1806
1807 #ifdef MZ_PRECISE_GC
1808 # define MZ_GC_DECL_REG(size) void *__gc_var_stack__[size+2] = { (void *)0, (void *)size };
1809 # define MZ_GC_VAR_IN_REG(x, v) (__gc_var_stack__[x+2] = (void *)&(v))
1810 # define MZ_GC_ARRAY_VAR_IN_REG(x, v, l) (__gc_var_stack__[x+2] = (void *)0, \
1811 __gc_var_stack__[x+3] = (void *)&(v), \
1812 __gc_var_stack__[x+4] = (void *)l)
1813 # define MZ_GC_NO_VAR_IN_REG(x) (__gc_var_stack__[x+2] = NULL)
1814 # define MZ_GC_REG() (__gc_var_stack__[0] = GC_variable_stack, \
1815 GC_variable_stack = __gc_var_stack__)
1816 # define MZ_GC_UNREG() (GC_variable_stack = (void **)__gc_var_stack__[0])
1817 #else
1818 # define MZ_GC_DECL_REG(size) /* empty */
1819 # define MZ_GC_VAR_IN_REG(x, v) /* empty */
1820 # define MZ_GC_ARRAY_VAR_IN_REG(x, v, l) /* empty */
1821 # define MZ_GC_NO_VAR_IN_REG(x) /* empty */
1822 # define MZ_GC_REG() /* empty */
1823 # define MZ_GC_UNREG() /* empty */
1824 #endif
1825
1826 #define SCHEME_GC_SHAPE_TERM 0
1827 #define SCHEME_GC_SHAPE_PTR_OFFSET 1
1828 #define SCHEME_GC_SHAPE_ADD_SIZE 2
1829
1830 /*========================================================================*/
1831 /* embedding configuration and hooks */
1832 /*========================================================================*/
1833
1834 #if SCHEME_DIRECT_EMBEDDED
1835
1836 #if defined(_IBMR2)
1837 MZ_EXTERN intptr_t scheme_stackbottom;
1838 #endif
1839
1840 MZ_EXTERN int scheme_defining_primitives;
1841
1842 /* These flags must be set before Racket is started: */
1843 MZ_EXTERN int scheme_case_sensitive; /* Defaults to 0 */
1844 MZ_EXTERN int scheme_no_keywords; /* Defaults to 0 */
1845 MZ_EXTERN int scheme_allow_set_undefined; /* Defaults to 0 */
1846 MZ_EXTERN int scheme_square_brackets_are_parens; /* Defaults to 1 */
1847 MZ_EXTERN int scheme_curly_braces_are_parens; /* Defaults to 1 */
1848 MZ_EXTERN int scheme_hash_percent_syntax_only; /* Defaults to 0 */
1849 MZ_EXTERN int scheme_hash_percent_globals_only; /* Defaults to 0 */
1850 MZ_EXTERN int scheme_binary_mode_stdio; /* Windows-specific; Defaults to 0 */
1851 MZ_EXTERN int scheme_startup_use_jit; /* Defaults to 1 */
1852 MZ_EXTERN int scheme_startup_compile_machine_independent; /* Defaults to 0 */
1853 MZ_EXTERN int scheme_ignore_user_paths; /* Defaults to 0 */
1854 MZ_EXTERN int scheme_ignore_link_paths; /* Defaults to 0 */
1855
1856 MZ_EXTERN void scheme_set_case_sensitive(int);
1857 MZ_EXTERN void scheme_set_allow_set_undefined(int);
1858 MZ_EXTERN void scheme_set_binary_mode_stdio(int);
1859 MZ_EXTERN void scheme_set_startup_use_jit(int);
1860 MZ_EXTERN void scheme_set_startup_compile_machine_independent(int);
1861 MZ_EXTERN void scheme_set_startup_load_on_demand(int);
1862 MZ_EXTERN void scheme_set_ignore_user_paths(int);
1863 MZ_EXTERN void scheme_set_ignore_link_paths(int);
1864 MZ_EXTERN void scheme_set_cross_compile_mode(int);
1865 MZ_EXTERN void scheme_set_logging(int syslog_level, int stderr_level);
1866 MZ_EXTERN void scheme_set_logging_spec(Scheme_Object *syslog_level, Scheme_Object *stderr_level);
1867 MZ_EXTERN void scheme_set_logging2(int syslog_level, int stderr_level, int stdout_level);
1868 MZ_EXTERN void scheme_set_logging2_spec(Scheme_Object *syslog_level, Scheme_Object *stderr_level, Scheme_Object *stdout_level);
1869
1870 MZ_EXTERN int scheme_get_allow_set_undefined();
1871
1872 MZ_EXTERN void scheme_set_compiled_file_check(int);
1873 #define SCHEME_COMPILED_FILE_CHECK_MODIFY_SECONDS 0
1874 #define SCHEME_COMPILED_FILE_CHECK_EXISTS 1
1875
1876 #ifdef MZ_CAN_ACCESS_THREAD_LOCAL_DIRECTLY
1877 THREAD_LOCAL_DECL(MZ_EXTERN Scheme_Thread *scheme_current_thread);
1878 THREAD_LOCAL_DECL(MZ_EXTERN Scheme_Thread *scheme_first_thread);
1879 #endif
1880 XFORM_NONGCING MZ_EXTERN Scheme_Thread *scheme_get_current_thread();
1881 XFORM_NONGCING MZ_EXTERN intptr_t scheme_get_multiple_count();
1882 XFORM_NONGCING MZ_EXTERN Scheme_Object **scheme_get_multiple_array();
1883 XFORM_NONGCING MZ_EXTERN void scheme_set_current_thread_ran_some();
1884
1885 MZ_EXTERN void scheme_embedded_load(intptr_t len, const char *s, int predefined);
1886 MZ_EXTERN void scheme_register_embedded_load(intptr_t len, const char *s);
1887
1888 /* Set these global hooks (optionally): */
1889 typedef void (*Scheme_Exit_Proc)(int v);
1890 MZ_EXTERN Scheme_Exit_Proc scheme_exit;
1891 MZ_EXTERN void scheme_set_exit(Scheme_Exit_Proc p);
1892 typedef void (*Scheme_At_Exit_Callback_Proc)(void);
1893 typedef int (*Scheme_At_Exit_Proc)(Scheme_At_Exit_Callback_Proc);
1894 MZ_EXTERN void scheme_set_atexit(Scheme_At_Exit_Proc p);
1895 typedef void (*scheme_console_printf_t)(char *str, ...);
1896 MZ_EXTERN scheme_console_printf_t scheme_console_printf;
1897 MZ_EXTERN scheme_console_printf_t scheme_get_console_printf();
1898 MZ_EXTERN void scheme_set_console_printf(scheme_console_printf_t p);
1899 typedef void (*scheme_console_output_t)(char *str, intptr_t len);
1900 MZ_EXTERN scheme_console_output_t scheme_console_output;
1901 MZ_EXTERN void scheme_set_console_output(scheme_console_output_t p);
1902 MZ_EXTERN void scheme_ensure_console_ready();
1903 MZ_EXTERN void (*scheme_sleep)(float seconds, void *fds);
1904 MZ_EXTERN void (*scheme_notify_multithread)(int on);
1905 MZ_EXTERN void (*scheme_wakeup_on_input)(void *fds);
1906 MZ_EXTERN int (*scheme_check_for_break)(void);
1907 #ifdef MZ_PRECISE_GC
1908 MZ_EXTERN void *(*scheme_get_external_stack_val)(void);
1909 MZ_EXTERN void (*scheme_set_external_stack_val)(void *);
1910 #endif
1911 #ifdef USE_WIN32_THREADS
1912 MZ_EXTERN void (*scheme_suspend_main_thread)(void);
1913 int scheme_set_in_main_thread(void);
1914 void scheme_restore_nonmain_thread(void);
1915 #endif
1916
1917 typedef Scheme_Object *(*Scheme_Stdio_Maker_Proc)(void);
1918 MZ_EXTERN Scheme_Object *(*scheme_make_stdin)(void);
1919 MZ_EXTERN Scheme_Object *(*scheme_make_stdout)(void);
1920 MZ_EXTERN Scheme_Object *(*scheme_make_stderr)(void);
1921
1922 MZ_EXTERN void scheme_set_stdio_makers(Scheme_Stdio_Maker_Proc in,
1923 Scheme_Stdio_Maker_Proc out,
1924 Scheme_Stdio_Maker_Proc err);
1925
1926
1927 MZ_EXTERN void scheme_set_banner(char *s);
1928 MZ_EXTERN Scheme_Object *scheme_set_exec_cmd(char *s);
1929 MZ_EXTERN Scheme_Object *scheme_set_run_cmd(char *s);
1930 MZ_EXTERN void scheme_set_collects_path(Scheme_Object *p);
1931 MZ_EXTERN void scheme_set_config_path(Scheme_Object *p);
1932 MZ_EXTERN void scheme_set_host_collects_path(Scheme_Object *p);
1933 MZ_EXTERN void scheme_set_host_config_path(Scheme_Object *p);
1934 MZ_EXTERN void scheme_set_original_dir(Scheme_Object *d);
1935 MZ_EXTERN void scheme_set_addon_dir(Scheme_Object *p);
1936 MZ_EXTERN void scheme_set_command_line_arguments(Scheme_Object *vec);
1937 MZ_EXTERN void scheme_set_compiled_file_paths(Scheme_Object *list);
1938 MZ_EXTERN void scheme_set_compiled_file_roots(Scheme_Object *list);
1939 #ifdef DOS_FILE_SYSTEM
1940 MZ_EXTERN void scheme_set_dll_path(wchar_t *s);
1941 typedef void *(*scheme_dll_open_proc)(const char *name, int as_global);
1942 typedef void *(*scheme_dll_find_object_proc)(void *h, const char *name);
1943 typedef void (*scheme_dll_close_proc)(void *h);
1944 MZ_EXTERN void scheme_set_dll_procs(scheme_dll_open_proc,
1945 scheme_dll_find_object_proc,
1946 scheme_dll_close_proc);
1947 #endif
1948
1949 MZ_EXTERN void scheme_init_collection_paths(Scheme_Env *global_env, Scheme_Object *extra_dirs);
1950 MZ_EXTERN void scheme_init_collection_paths_post(Scheme_Env *global_env, Scheme_Object *extra_dirs, Scheme_Object *extra_post_dirs);
1951 MZ_EXTERN void scheme_init_compiled_roots(Scheme_Env *global_env, const char *paths);
1952
1953 MZ_EXTERN void scheme_seal_parameters();
1954
1955 /* Initialization */
1956 MZ_EXTERN Scheme_Env *scheme_basic_env(void);
1957 MZ_EXTERN void scheme_reset_overflow(void);
1958 MZ_EXTERN void scheme_free_all(void);
1959
1960 #ifdef USE_MSVC_MD_LIBRARY
1961 MZ_EXTERN void GC_pre_init(void);
1962 #endif
1963
1964 MZ_EXTERN void scheme_check_threads(void);
1965 MZ_EXTERN void scheme_wake_up(void);
1966 MZ_EXTERN int scheme_get_external_event_fd(void);
1967
1968 /* GC registration: */
1969 MZ_EXTERN void scheme_set_stack_base(void *base, int no_auto_statics);
1970 MZ_EXTERN void scheme_set_stack_bounds(void *base, void *deepest, int no_auto_statics);
1971
1972 typedef void (*Scheme_Report_Out_Of_Memory_Proc)(void);
1973 MZ_EXTERN void scheme_set_report_out_of_memory(Scheme_Report_Out_Of_Memory_Proc p);
1974
1975 /* Stack-preparation start-up: */
1976 typedef int (*Scheme_Nested_Main)(void *data);
1977 MZ_EXTERN int scheme_main_stack_setup(int no_auto_statics, Scheme_Nested_Main _main, void *data);
1978
1979 /* More automatic start-up: */
1980 typedef int (*Scheme_Env_Main)(Scheme_Env *env, int argc, char **argv);
1981 MZ_EXTERN int scheme_main_setup(int no_auto_statics, Scheme_Env_Main _main, int argc, char **argv);
1982
1983 MZ_EXTERN void scheme_register_tls_space(void *tls_space, int _tls_index);
1984
1985 MZ_EXTERN void scheme_register_static(void *ptr, intptr_t size);
1986 #if defined(MUST_REGISTER_GLOBALS) || defined(GC_MIGHT_USE_REGISTERED_STATICS)
1987 # define MZ_REGISTER_STATIC(x) scheme_register_static((void *)&x, sizeof(x))
1988 #else
1989 # define MZ_REGISTER_STATIC(x) /* empty */
1990 #endif
1991
1992 MZ_EXTERN void scheme_immediate_exit(int status);
1993
1994 MZ_EXTERN int scheme_new_param(void);
1995 MZ_EXTERN Scheme_Object *scheme_param_config(char *name, Scheme_Object *pos,
1996 int argc, Scheme_Object **argv,
1997 int arity,
1998 Scheme_Prim *check, char *expected_type,
1999 int isbool);
2000 MZ_EXTERN Scheme_Object *scheme_param_config2(char *name, Scheme_Object *pos,
2001 int argc, Scheme_Object **argv,
2002 int arity,
2003 Scheme_Prim *check, char *expected_contract,
2004 int isbool);
2005 MZ_EXTERN Scheme_Object *scheme_register_parameter(Scheme_Prim *function, char *name, int which);
2006
2007 MZ_EXTERN void scheme_set_default_locale(void);
2008
2009 #endif /* SCHEME_DIRECT_EMBEDDED */
2010
2011 /*========================================================================*/
2012 /* OS signals */
2013 /*========================================================================*/
2014
2015 typedef void (*Scheme_Signal_Handler_Proc)(int);
2016
2017 /*========================================================================*/
2018 /* addrinfo */
2019 /*========================================================================*/
2020
2021 #if defined(HAVE_GETADDRINFO) || defined(__MINGW32__)
2022 # define mz_addrinfo addrinfo
2023 #else
2024 struct mz_addrinfo {
2025 int ai_flags;
2026 int ai_family;
2027 int ai_socktype;
2028 int ai_protocol;
2029 size_t ai_addrlen;
2030 struct sockaddr *ai_addr;
2031 struct mz_addrinfo *ai_next;
2032 };
2033 #endif
2034
2035 /*========================================================================*/
2036 /* FFI functions */
2037 /*========================================================================*/
2038
2039 /* If Racket is being empbedded, then we just include the
2040 prototypes. Otherwise, we may include a function-table definition
2041 instead, plus macros that map the usual name to table lookups. */
2042
2043 #if SCHEME_DIRECT_EMBEDDED
2044
2045 /* All functions & global constants prototyped here */
2046 #ifdef INCLUDE_WITHOUT_PATHS
2047 # include "schemef.h"
2048 #else
2049 # include "../src/schemef.h"
2050 #endif
2051
2052 #else
2053
2054 #ifdef LINK_EXTENSIONS_BY_TABLE
2055 /* Constants and function prototypes as function pointers in a struct: */
2056 # ifdef INCLUDE_WITHOUT_PATHS
2057 # include "schemex.h"
2058 # else
2059 # include "../src/schemex.h"
2060 # endif
2061
2062 extern Scheme_Extension_Table *scheme_extension_table;
2063
2064 /* Macro mapping names to record access */
2065 # ifdef INCLUDE_WITHOUT_PATHS
2066 # include "schemexm.h"
2067 # else
2068 # include "../src/schemexm.h"
2069 # endif
2070
2071 #else
2072
2073 /* Not LINK_EXTENSIONS_BY_TABLE */
2074 # ifdef INCLUDE_WITHOUT_PATHS
2075 # include "schemef.h"
2076 # else
2077 # include "../src/schemef.h"
2078 # endif
2079
2080 #endif
2081
2082 #endif
2083
2084 /*========================================================================*/
2085 /* misc flags */
2086 /*========================================================================*/
2087
2088 /* For use with scheme_symbol_name_and_size: */
2089 #define SCHEME_SNF_FOR_TS 0x1
2090 #define SCHEME_SNF_PIPE_QUOTE 0x2
2091 #define SCHEME_SNF_NO_PIPE_QUOTE 0x4
2092 #define SCHEME_SNF_NEED_CASE 0x8
2093 #define SCHEME_SNF_KEYWORD 0x10
2094 #define SCHEME_SNF_NO_KEYWORDS 0x20
2095
2096 /* For use with scheme_make_struct_values et al.: */
2097 #define SCHEME_STRUCT_NO_TYPE 0x01
2098 #define SCHEME_STRUCT_NO_CONSTR 0x02
2099 #define SCHEME_STRUCT_NO_PRED 0x04
2100 #define SCHEME_STRUCT_NO_GET 0x08
2101 #define SCHEME_STRUCT_NO_SET 0x10
2102 #define SCHEME_STRUCT_GEN_GET 0x20
2103 #define SCHEME_STRUCT_GEN_SET 0x40
2104 #define SCHEME_STRUCT_EXPTIME 0x80
2105 #define SCHEME_STRUCT_NO_MAKE_PREFIX 0x100
2106 #define SCHEME_STRUCT_NAMES_ARE_STRINGS 0x200
2107 #define SCHEME_STRUCT_BUILTIN 0x400
2108
2109 /*========================================================================*/
2110 /* file descriptors */
2111 /*========================================================================*/
2112
2113 # define MZ_GET_FDSET(p, n) scheme_get_fdset(p, n)
2114 # define MZ_FD_ZERO(p) scheme_fdzero(p)
2115 # define MZ_FD_SET(n, p) scheme_fdset(p, n)
2116 # define MZ_FD_CLR(n, p) scheme_fdclr(p, n)
2117 # define MZ_FD_ISSET(n, p) scheme_fdisset(p, n)
2118
2119 /* For scheme_fd_to_semaphore(): */
2120 #define MZFD_CREATE_READ 1
2121 #define MZFD_CREATE_WRITE 2
2122 #define MZFD_CHECK_READ 3
2123 #define MZFD_CHECK_WRITE 4
2124 #define MZFD_REMOVE 5
2125
2126 /*========================================================================*/
2127
2128 #ifdef __cplusplus
2129 }
2130 #endif
2131
2132 #if defined(__MWERKS__)
2133 # ifdef MZSCHEME_USES_NEAR_GLOBALS
2134 # pragma far_data reset
2135 # endif
2136 #endif
2137
2138 #endif /* ! SCHEME_H */
2139
2140