-
-
Notifications
You must be signed in to change notification settings - Fork 645
/
scheme.h
2163 lines (1791 loc) · 77.1 KB
/
scheme.h
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
/*
Racket
Copyright (c) 2004-2016 PLT Design Inc.
Copyright (c) 1995-2001 Matthew Flatt
All rights reserved.
Please see the full copyright in the documentation.
Originally based on:
libscheme
Copyright (c) 1994 Brent Benson
All rights reserved.
*/
#ifndef SCHEME_H
#define SCHEME_H
/* The next line is used and set during installation: */
/*III*/
/*========================================================================*/
/* configuration */
/*========================================================================*/
/* The configuration is not intended to be adjusted here. Instead,
modify sconfig.h. The code below simply draws a few more
configuration conclusions and a few extra macros based on those
settings. */
#ifdef INCLUDE_WITHOUT_PATHS
# include "sconfig.h"
#else
# include "../sconfig.h"
#endif
#if defined(__MWERKS__)
# ifdef MZSCHEME_USES_NEAR_GLOBALS
# pragma far_data off
# endif
#endif
#if SGC_STD_DEBUGGING
# ifndef USE_SENORA_GC
# define USE_SENORA_GC
# endif
# define USE_MEMORY_TRACING
#endif
#ifdef MZ_PRECISE_GC
# define MUST_REGISTER_GLOBALS
# define MZTAG_REQUIRED
# undef UNIX_IMAGE_DUMPS
/* In case SGC is used to build PRECISE_GC: */
# undef USE_SENORA_GC
#endif
#ifdef USE_SENORA_GC
# define MUST_REGISTER_GLOBALS
# undef UNIX_IMAGE_DUMPS
#endif
#ifdef USE_SINGLE_FLOATS
# define MZ_USE_SINGLE_FLOATS
#endif
/* gcc defines __SSE2_MATH__ when SSE2 floating point is enabled: */
#ifdef __SSE2_MATH__
# define C_COMPILER_USES_SSE 1
#endif
#ifdef C_COMPILER_USES_SSE
# if defined(MZ_TRY_EXTFLONUMS) && !defined(MZ_NO_EXTFLONUMS)
# define MZ_LONG_DOUBLE
# ifdef ASM_DBLPREC_CONTROL_87
# define ASM_EXTPREC_CONTROL_87
# endif
# endif
# ifdef ASM_DBLPREC_CONTROL_87
# undef ASM_DBLPREC_CONTROL_87
# endif
# if defined(MZ_USE_JIT_I386) && !defined(MZ_NO_JIT_SSE)
# define MZ_USE_JIT_SSE
# endif
#endif
#ifdef MZ_LONG_DOUBLE
# ifdef MZ_LONG_DOUBLE_API_IS_EXTERNAL
# define BYTES_RESERVED_FOR_LONG_DOUBLE 16
typedef struct {
char bytes[BYTES_RESERVED_FOR_LONG_DOUBLE];
} mz_long_double;
# else
typedef long double mz_long_double;
# endif
#else
# ifdef MZ_INSIST_EXTFLONUMS
# error "cannot support extflonums; you may need to adjust compiler options"
# endif
typedef double mz_long_double;
#endif
#ifdef DONT_ITIMER
# undef USE_ITIMER
#endif
#if defined(USE_ITIMER) || defined(USE_WIN32_THREAD_TIMER) || defined(USE_PTHREAD_THREAD_TIMER)
# define FUEL_AUTODECEREMENTS
#endif
#ifdef SIZEOF_VOID_P
# if SIZEOF_VOID_P == 8
# define SIXTY_FOUR_BIT_INTEGERS
# ifdef USE_LONG_LONG_FOR_BIGDIG
Do not specify USE_LONG_LONG_FOR_BIGDIG on a platform with
64-bit integers
# endif
# endif
#endif
#ifdef SIZEOF_LONG
# if SIZEOF_LONG == 8
# define SIXTY_FOUR_BIT_LONGS
# endif
#endif
#ifdef MZ_PRECISE_GC
# define MZ_HASH_KEY_EX short keyex;
# define MZ_OPT_HASH_KEY_EX /**/
# define MZ_OPT_HASH_KEY(obj) (obj)->so.keyex
#else
# define MZ_HASH_KEY_EX /**/
# define MZ_OPT_HASH_KEY_EX short keyex;
# define MZ_OPT_HASH_KEY(obj) (obj)->keyex
#endif
#ifdef PALMOS_STUFF
# include <PalmOS.h>
typedef long FILE;
# define _LINUX_TYPES_H /* Blocks types.h */
#endif
#ifndef SCHEME_DIRECT_EMBEDDED
# define SCHEME_DIRECT_EMBEDDED 1
#endif
#ifndef MSC_IZE
# define MSC_IZE(x) x
#endif
#ifndef M_MSC_IZE
# define M_MSC_IZE(x) x
#endif
#ifndef MSCBOR_IZE
# define MSCBOR_IZE(x) MSC_IZE(x)
#endif
#ifdef SIGSET_IS_SIGNAL
# define MZ_SIGSET(s, f) signal(s, f)
#else
# define MZ_SIGSET(s, f) sigset(s, f)
#endif
/* C99 allows an array in a struct to be declared
with [] to indicate that its actual size can be
any number. The old way was to declare the array
of size 1. For now, we support going back to the
old way. */
#ifdef MZ_USE_OLD_ARRAY_STYLE
# define mzFLEX_ARRAY_DECL 1
# define mzFLEX_ARRAY4_DECL 4
# define mzFLEX_DELTA 1
# define mzFLEX4_DELTA 4
#else
# define mzFLEX_ARRAY_DECL /* empty */
# define mzFLEX_ARRAY4_DECL /* empty */
# define mzFLEX_DELTA 0
# define mzFLEX4_DELTA 0
#endif
#ifdef MZ_XFORM
# define XFORM_NONGCING __xform_nongcing__
#else
# define XFORM_NONGCING /* empty */
#endif
#ifdef MZ_XFORM
START_XFORM_SUSPEND;
#endif
#include <stdio.h>
#include <setjmp.h>
#include <stdarg.h>
#include <stdlib.h>
#include <string.h>
#include <stddef.h>
#ifdef MZ_XFORM
END_XFORM_SUSPEND;
#endif
#ifdef PALMOS_STUFF
typedef jmpbuf jmp_buf[1];
#endif
#define GC_MIGHT_USE_REGISTERED_STATICS
#ifdef MACINTOSH_EVENTS
/* We avoid #including the Carbon headers because we only
need a few abstract struct types: */
typedef struct FSSpec mzFSSpec;
#endif
#ifndef MZ_DONT_USE_JIT
# if defined(MZ_USE_JIT_PPC) || defined(MZ_USE_JIT_I386) || defined(MZ_USE_JIT_X86_64) || defined(MZ_USE_JIT_ARM)
# define MZ_USE_JIT
# endif
#endif
/* Define _W64 for MSC if needed. */
#if defined(_MSC_VER) && !defined(_W64)
# if !defined(__midl) && (defined(_X86_) || defined(_M_IX86)) && _MSC_VER >= 1300
# define _W64 __w64
# else
# define _W64
# endif
#endif
#ifdef MZ_PRECISE_GC
# ifndef MZ_XFORM
# define XFORM_SKIP_PROC /* empty */
# define XFORM_CAN_IGNORE /**/
# endif
#else
# define XFORM_HIDE_EXPR(x) x
# define XFORM_START_SKIP /**/
# define XFORM_END_SKIP /**/
# define XFORM_START_SUSPEND /**/
# define XFORM_END_SUSPEND /**/
# define XFORM_SKIP_PROC /**/
# define XFORM_START_TRUST_ARITH /**/
# define XFORM_END_TRUST_ARITH /**/
# define XFORM_CAN_IGNORE /**/
# define XFORM_TRUST_PLUS +
# define XFORM_TRUST_MINUS -
#endif
/* PPC Linux plays a slimy trick: it defines strcpy() as a macro that
uses __extension__. This breaks the 3m xform. */
#if defined(MZ_XFORM) && defined(strcpy)
START_XFORM_SKIP;
# ifdef __clang__
# pragma clang diagnostic push
# pragma clang diagnostic ignored "-Wunused-function"
# endif
static inline void _mzstrcpy(char *a, const char *b)
{
strcpy(a, b);
}
# ifdef __clang__
# pragma clang diagnostic pop
# endif
END_XFORM_SKIP;
# undef strcpy
# define strcpy _mzstrcpy
#endif
#ifdef __cplusplus
extern "C"
{
#endif
/* Allowed by all configurations, currently: */
#define MZ_CAN_ACCESS_THREAD_LOCAL_DIRECTLY
/*========================================================================*/
/* basic Scheme values */
/*========================================================================*/
typedef short Scheme_Type;
typedef int mzshort;
typedef unsigned int mzchar;
typedef int mzchar_int; /* includes EOF */
#ifdef INT64_AS_LONG_LONG
typedef _int64 mzlonglong;
typedef unsigned _int64 umzlonglong;
#else
# if defined(NO_LONG_LONG_TYPE) || defined(SIXTY_FOUR_BIT_INTEGERS)
typedef intptr_t mzlonglong;
typedef uintptr_t umzlonglong;
# else
typedef long long mzlonglong;
typedef unsigned long long umzlonglong;
# endif
#endif
/* Racket values have the type `Scheme_Object *'. The Scheme_Object
structure declares just the header: a type tag and space for
hashing or extra flags; actual object types will extend this
structure.
For example, Scheme_Simple_Object defines a few variants. The
important thing is that it starts with a nested Scheme_Object
record.
The Scheme_Simple_Object struct is defined here, instead of in a
private header, so that macros can provide quick access. Of course,
don't access the fields of these structures directly; use the
macros instead. */
typedef struct Scheme_Object
{
Scheme_Type type; /* Anything that starts with a type field
can be a Scheme_Object */
/* For precise GC, the keyex field is used for all object types to
store a hash key extension. The low bit is not used for this
purpose, though. For string, pair, vector, and box values in all
variants of Racket, the low bit is set to 1 to indicate that
the object is immutable. Thus, the keyex field is needed even in
non-precise GC mode, so such structures embed
Scheme_Inclhash_Object */
MZ_HASH_KEY_EX
} Scheme_Object;
/* See note above on MZ_HASH_KEY_EX. To get the keyex field,
use MZ_OPT_HASH_KEY(iso), where iso is a pointer to a
Scheme_Inclhash_Object */
typedef struct Scheme_Inclhash_Object
{
Scheme_Object so;
MZ_OPT_HASH_KEY_EX
} Scheme_Inclhash_Object;
typedef struct Scheme_Simple_Object
{
Scheme_Inclhash_Object iso;
union
{
struct { mzchar *string_val; intptr_t tag_val; } char_str_val;
struct { char *string_val; intptr_t tag_val; } byte_str_val;
struct { void *ptr1, *ptr2; } two_ptr_val;
struct { int int1; int int2; } two_int_val;
struct { void *ptr; int pint; } ptr_int_val;
struct { void *ptr; intptr_t pint; } ptr_long_val;
struct { struct Scheme_Object *car, *cdr; } pair_val;
struct { mzshort len; mzshort *vec; } svector_val;
struct { void *val; Scheme_Object *type; } cptr_val;
} u;
} Scheme_Simple_Object;
typedef struct Scheme_Object *(*Scheme_Closure_Func)(struct Scheme_Object *);
/* Scheme_Small_Object is used for several types of Racket values: */
typedef struct {
Scheme_Inclhash_Object iso;
union {
mzchar char_val;
Scheme_Object *ptr_value;
intptr_t int_val;
Scheme_Object *ptr_val;
} u;
} Scheme_Small_Object;
/* A floating-point number: */
typedef struct {
Scheme_Object so;
double double_val;
} Scheme_Double;
#ifdef MZ_LONG_DOUBLE
typedef struct {
Scheme_Object so;
mz_long_double long_double_val;
} Scheme_Long_Double;
#else
typedef struct {
Scheme_Object so;
const char *printed_form;
} Scheme_Long_Double;
#endif
#ifdef MZ_USE_SINGLE_FLOATS
typedef struct {
Scheme_Object so;
float float_val;
} Scheme_Float;
#endif
typedef struct Scheme_Symbol {
Scheme_Inclhash_Object iso; /* 1 in low bit of keyex indicates uninterned */
intptr_t len;
char s[mzFLEX_ARRAY4_DECL];
} Scheme_Symbol;
typedef struct Scheme_Vector {
Scheme_Inclhash_Object iso; /* 1 in low bit of keyex indicates immutable */
intptr_t size;
Scheme_Object *els[mzFLEX_ARRAY_DECL];
} Scheme_Vector;
# define SHARED_ALLOCATED 0x2
# define SHARED_ALLOCATEDP(so) (MZ_OPT_HASH_KEY((Scheme_Inclhash_Object *)(so)) & SHARED_ALLOCATED)
# define SHARED_ALLOCATED_SET(so) (MZ_OPT_HASH_KEY((Scheme_Inclhash_Object *)(so)) |= SHARED_ALLOCATED)
typedef struct Scheme_Double_Vector {
Scheme_Inclhash_Object iso; /* & 0x2 indicates allocated in the MASTERGC */
intptr_t size;
double els[mzFLEX_ARRAY_DECL];
} Scheme_Double_Vector;
#ifdef MZ_LONG_DOUBLE
typedef struct Scheme_Long_Double_Vector {
Scheme_Inclhash_Object iso; /* & 0x2 indicates allocated in the MASTERGC */
intptr_t size;
mz_long_double els[mzFLEX_ARRAY_DECL];
} Scheme_Long_Double_Vector;
#endif
typedef struct Scheme_Print_Params Scheme_Print_Params;
typedef void (*Scheme_Type_Printer)(Scheme_Object *v, int for_display, Scheme_Print_Params *pp);
typedef int (*Scheme_Equal_Proc)(Scheme_Object *obj1, Scheme_Object *obj2, void *cycle_data);
typedef intptr_t (*Scheme_Primary_Hash_Proc)(Scheme_Object *obj, intptr_t base, void *cycle_data);
typedef intptr_t (*Scheme_Secondary_Hash_Proc)(Scheme_Object *obj, void *cycle_data);
/* This file defines all the built-in types */
#ifdef INCLUDE_WITHOUT_PATHS
# include "stypes.h"
#else
# include "../src/stypes.h"
#endif
#define OBJ_TO_LONG(ptr) ((intptr_t)(ptr))
#define LONG_TO_OBJ(l) ((Scheme_Object *)(void *)(intptr_t)(l))
/* Scheme Objects are always aligned on 2-byte boundaries, so */
/* words of type Scheme_Object * will always have zero in the */
/* least significant bit. Therefore, we can use this bit as a */
/* tag to indicate that the `pointer' isn't really a pointer */
/* but a 31-bit signed immediate integer. */
#define SCHEME_INTP(obj) (OBJ_TO_LONG(obj) & 0x1)
#define SAME_PTR(a, b) ((a) == (b))
#define NOT_SAME_PTR(a, b) ((a) != (b))
#define SAME_OBJ(a, b) SAME_PTR(a, b)
#define NOT_SAME_OBJ(a, b) NOT_SAME_PTR(a, b)
#define SAME_TYPE(a, b) ((Scheme_Type)(a) == (Scheme_Type)(b))
#define NOT_SAME_TYPE(a, b) ((Scheme_Type)(a) != (Scheme_Type)(b))
# define SCHEME_TYPE(obj) (SCHEME_INTP(obj)?(Scheme_Type)scheme_integer_type:((Scheme_Object *)(obj))->type)
# define _SCHEME_TYPE(obj) ((obj)->type) /* unsafe version */
/*========================================================================*/
/* basic Scheme predicates */
/*========================================================================*/
#define SCHEME_CHARP(obj) SAME_TYPE(SCHEME_TYPE(obj), scheme_char_type)
/* SCHEME_INTP defined above */
#define SCHEME_DBLP(obj) SAME_TYPE(SCHEME_TYPE(obj), scheme_double_type)
#ifdef MZ_USE_SINGLE_FLOATS
# define SCHEME_FLTP(obj) SAME_TYPE(SCHEME_TYPE(obj), scheme_float_type)
# define SCHEME_FLOATP(obj) (SCHEME_FLTP(obj) || SCHEME_DBLP(obj))
#else
# define SCHEME_FLTP SCHEME_DBLP
# define SCHEME_FLOATP SCHEME_DBLP
#endif
#define SCHEME_BIGNUMP(obj) SAME_TYPE(SCHEME_TYPE(obj), scheme_bignum_type)
#define SCHEME_RATIONALP(obj) SAME_TYPE(SCHEME_TYPE(obj), scheme_rational_type)
#define SCHEME_COMPLEXP(obj) (!SCHEME_INTP(obj) && ((_SCHEME_TYPE(obj) == scheme_complex_type)))
#define SCHEME_EXACT_INTEGERP(obj) (SCHEME_INTP(obj) || (_SCHEME_TYPE(obj) == scheme_bignum_type))
#define SCHEME_EXACT_REALP(obj) (SCHEME_INTP(obj) || (_SCHEME_TYPE(obj) == scheme_bignum_type) || (_SCHEME_TYPE(obj) == scheme_rational_type))
#define SCHEME_REALP(obj) (SCHEME_INTP(obj) || ((_SCHEME_TYPE(obj) >= scheme_bignum_type) && (_SCHEME_TYPE(obj) < scheme_complex_type)))
#define SCHEME_NUMBERP(obj) (SCHEME_INTP(obj) || ((_SCHEME_TYPE(obj) >= scheme_bignum_type) && (_SCHEME_TYPE(obj) <= scheme_complex_type)))
#define SCHEME_LONG_DBLP(obj) SAME_TYPE(SCHEME_TYPE(obj), scheme_long_double_type)
#define SCHEME_CHAR_STRINGP(obj) SAME_TYPE(SCHEME_TYPE(obj), scheme_char_string_type)
#define SCHEME_MUTABLE_CHAR_STRINGP(obj) (SCHEME_CHAR_STRINGP(obj) && SCHEME_MUTABLEP(obj))
#define SCHEME_IMMUTABLE_CHAR_STRINGP(obj) (SCHEME_CHAR_STRINGP(obj) && SCHEME_IMMUTABLEP(obj))
#define SCHEME_BYTE_STRINGP(obj) SAME_TYPE(SCHEME_TYPE(obj), scheme_byte_string_type)
#define SCHEME_MUTABLE_BYTE_STRINGP(obj) (SCHEME_BYTE_STRINGP(obj) && SCHEME_MUTABLEP(obj))
#define SCHEME_IMMUTABLE_BYTE_STRINGP(obj) (SCHEME_BYTE_STRINGP(obj) && SCHEME_IMMUTABLEP(obj))
#define SCHEME_PATHP(obj) SAME_TYPE(SCHEME_TYPE(obj), SCHEME_PLATFORM_PATH_KIND)
#define SCHEME_GENERAL_PATHP(obj) ((SCHEME_TYPE(obj) >= scheme_unix_path_type) && (SCHEME_TYPE(obj) <= scheme_windows_path_type))
/* A path is guaranteed to have the same shape as a byte string */
#define SCHEME_PATH_STRINGP(x) (SCHEME_CHAR_STRINGP(x) || SCHEME_PATHP(x))
#define SCHEME_PATH_STRING_STR "path or string"
#define SCHEME_GENERAL_PATH_STRINGP(x) (SCHEME_CHAR_STRINGP(x) || SCHEME_GENERAL_PATHP(x))
#define SCHEME_GENERAL_PATH_STRING_STR "path (for any platform) or string"
#define SCHEME_SYMBOLP(obj) SAME_TYPE(SCHEME_TYPE(obj), scheme_symbol_type)
#define SCHEME_KEYWORDP(obj) SAME_TYPE(SCHEME_TYPE(obj), scheme_keyword_type)
#define SCHEME_STRSYMP(obj) (SCHEME_CHAR_STRINGP(obj) || SCHEME_SYMBOLP(obj))
#define SCHEME_BOOLP(obj) (SAME_OBJ(obj, scheme_true) || SAME_OBJ(obj, scheme_false))
#define SCHEME_FALSEP(obj) SAME_OBJ((obj), scheme_false)
#define SCHEME_TRUEP(obj) (!SCHEME_FALSEP(obj))
#define SCHEME_EOFP(obj) SAME_OBJ((obj), scheme_eof)
#define SCHEME_VOIDP(obj) SAME_OBJ((obj), scheme_void)
#define SCHEME_NULLP(obj) SAME_OBJ(obj, scheme_null)
#define SCHEME_PAIRP(obj) SAME_TYPE(SCHEME_TYPE(obj), scheme_pair_type)
#define SCHEME_MPAIRP(obj) SAME_TYPE(SCHEME_TYPE(obj), scheme_mutable_pair_type)
#define SCHEME_MUTABLE_PAIRP(obj) SCHEME_MPAIRP(obj)
#define SCHEME_LISTP(obj) (SCHEME_NULLP(obj) || SCHEME_PAIRP(obj))
#define SCHEME_RPAIRP(obj) SAME_TYPE(SCHEME_TYPE(obj), scheme_raw_pair_type)
#define SCHEME_BOXP(obj) SAME_TYPE(SCHEME_TYPE(obj), scheme_box_type)
#define SCHEME_MUTABLE_BOXP(obj) (SCHEME_BOXP(obj) && SCHEME_MUTABLEP(obj))
#define SCHEME_IMMUTABLE_BOXP(obj) (SCHEME_BOXP(obj) && SCHEME_IMMUTABLEP(obj))
#define SCHEME_PROMPT_TAGP(obj) SAME_TYPE(SCHEME_TYPE(obj), scheme_prompt_tag_type)
#define SCHEME_CONTINUATION_MARK_KEYP(obj) SAME_TYPE(SCHEME_TYPE(obj), scheme_continuation_mark_key_type)
#define SCHEME_BUCKTP(obj) SAME_TYPE(SCHEME_TYPE(obj),scheme_bucket_table_type)
#define SCHEME_HASHTP(obj) SAME_TYPE(SCHEME_TYPE(obj),scheme_hash_table_type)
#define SCHEME_HASHTRP(obj) ((SCHEME_TYPE(obj) >= scheme_hash_tree_type) && (SCHEME_TYPE(obj) <= scheme_hash_tree_indirection_type))
#define SCHEME_VECTORP(obj) SAME_TYPE(SCHEME_TYPE(obj), scheme_vector_type)
#define SCHEME_MUTABLE_VECTORP(obj) (SCHEME_VECTORP(obj) && SCHEME_MUTABLEP(obj))
#define SCHEME_IMMUTABLE_VECTORP(obj) (SCHEME_VECTORP(obj) && SCHEME_IMMUTABLEP(obj))
#define SCHEME_FLVECTORP(obj) SAME_TYPE(SCHEME_TYPE(obj), scheme_flvector_type)
#define SCHEME_EXTFLVECTORP(obj) SAME_TYPE(SCHEME_TYPE(obj), scheme_extflvector_type)
#define SCHEME_FXVECTORP(obj) SAME_TYPE(SCHEME_TYPE(obj), scheme_fxvector_type)
#define SCHEME_STRUCTP(obj) (SAME_TYPE(SCHEME_TYPE(obj), scheme_structure_type) || SAME_TYPE(SCHEME_TYPE(obj), scheme_proc_struct_type))
#define SCHEME_STRUCT_TYPEP(obj) SAME_TYPE(SCHEME_TYPE(obj), scheme_struct_type_type)
#define SCHEME_INPORTP(obj) SAME_TYPE(SCHEME_TYPE(obj), scheme_input_port_type)
#define SCHEME_OUTPORTP(obj) SAME_TYPE(SCHEME_TYPE(obj), scheme_output_port_type)
#define SCHEME_INPUT_PORTP(obj) scheme_is_input_port(obj)
#define SCHEME_OUTPUT_PORTP(obj) scheme_is_output_port(obj)
#define SCHEME_THREADP(obj) SAME_TYPE(SCHEME_TYPE(obj), scheme_thread_type)
#define SCHEME_CUSTODIANP(obj) SAME_TYPE(SCHEME_TYPE(obj), scheme_custodian_type)
#define SCHEME_PLUMBERP(obj) SAME_TYPE(SCHEME_TYPE(obj), scheme_plumber_type)
#define SCHEME_SEMAP(obj) SAME_TYPE(SCHEME_TYPE(obj), scheme_sema_type)
#define SCHEME_CHANNELP(obj) SAME_TYPE(SCHEME_TYPE(obj), scheme_channel_type)
#define SCHEME_CHANNEL_PUTP(obj) SAME_TYPE(SCHEME_TYPE(obj), scheme_channel_put_type)
#define SCHEME_CONFIGP(obj) SAME_TYPE(SCHEME_TYPE(obj), scheme_config_type)
#define SCHEME_NAMESPACEP(obj) SAME_TYPE(SCHEME_TYPE(obj), scheme_namespace_type)
#define SCHEME_WEAKP(obj) SAME_TYPE(SCHEME_TYPE(obj), scheme_weak_box_type)
#define SCHEME_STXP(obj) SAME_TYPE(SCHEME_TYPE(obj), scheme_stx_type)
#define SCHEME_CHAPERONEP(obj) (SAME_TYPE(SCHEME_TYPE(obj), scheme_chaperone_type) \
|| SAME_TYPE(SCHEME_TYPE(obj), scheme_proc_chaperone_type))
#define SCHEME_UDPP(obj) SAME_TYPE(SCHEME_TYPE(obj), scheme_udp_type)
#define SCHEME_UDP_EVTP(obj) SAME_TYPE(SCHEME_TYPE(obj), scheme_udp_evt_type)
#define SCHEME_CPTRP(obj) (SAME_TYPE(SCHEME_TYPE(obj), scheme_cpointer_type))
#define SCHEME_MUTABLEP(obj) (!(MZ_OPT_HASH_KEY((Scheme_Inclhash_Object *)(obj)) & 0x1))
#define SCHEME_IMMUTABLEP(obj) (MZ_OPT_HASH_KEY((Scheme_Inclhash_Object *)(obj)) & 0x1)
#define GUARANTEE_TYPE(fname, argnum, typepred, typenam) \
(typepred (argv [argnum]) \
? argv [argnum] \
: (scheme_wrong_type (fname, typenam, argnum, argc, argv), argv [argnum]))
#define GUARANTEE_BOOL(fname, argnum) GUARANTEE_TYPE (fname, argnum, SCHEME_BOOLP, "boolean")
#define GUARANTEE_CHAR(fname, argnum) GUARANTEE_TYPE (fname, argnum, SCHEME_CHARP, "character")
#define GUARANTEE_INTEGER(fname, argnum) GUARANTEE_TYPE (fname, argnum, SCHEME_INTP, "integer")
#define GUARANTEE_PAIR(fname, argnum) GUARANTEE_TYPE (fname, argnum, SCHEME_PAIRP, "pair")
#define GUARANTEE_PROCEDURE(fname, argnum) GUARANTEE_TYPE (fname, argnum, SCHEME_PROCP, "procedure")
#define GUARANTEE_CHAR_STRING(fname, argnum) GUARANTEE_TYPE (fname, argnum, SCHEME_CHAR_STRINGP, "string")
#define GUARANTEE_STRSYM(fname, argnum) GUARANTEE_TYPE (fname, argnum, SCHEME_STRSYMP, "string or symbol")
#define GUARANTEE_SYMBOL(fname, argnum) GUARANTEE_TYPE (fname, argnum, SCHEME_SYMBOLP, "symbol")
#define SCHEME_UNIX_PATH_KIND scheme_unix_path_type
#define SCHEME_WINDOWS_PATH_KIND scheme_windows_path_type
#ifdef DOS_FILE_SYSTEM
# define SCHEME_PLATFORM_PATH_KIND SCHEME_WINDOWS_PATH_KIND
#else
# define SCHEME_PLATFORM_PATH_KIND SCHEME_UNIX_PATH_KIND
#endif
#define SCHEME_PATH_KIND(p) SCHEME_TYPE(p)
/*========================================================================*/
/* basic Scheme accessors */
/*========================================================================*/
#define SCHEME_CHAR_VAL(obj) (((Scheme_Small_Object *)(obj))->u.char_val)
#define SCHEME_INT_VAL(obj) (OBJ_TO_LONG(obj)>>1)
#define SCHEME_DBL_VAL(obj) (((Scheme_Double *)(obj))->double_val)
#ifdef MZ_LONG_DOUBLE
#define SCHEME_LONG_DBL_VAL(obj) (((Scheme_Long_Double *)(obj))->long_double_val)
#endif
#ifdef MZ_USE_SINGLE_FLOATS
# define SCHEME_FLT_VAL(obj) (((Scheme_Float *)(obj))->float_val)
# define SCHEME_FLOAT_VAL(obj) (SCHEME_DBLP(obj) ? SCHEME_DBL_VAL(obj) : SCHEME_FLT_VAL(obj))
#else
# define SCHEME_FLT_VAL(x) ((float)(SCHEME_DBL_VAL(x)))
# define SCHEME_FLOAT_VAL SCHEME_DBL_VAL
# define scheme_make_float(x) scheme_make_double((double)x)
#endif
#define SCHEME_CHAR_STR_VAL(obj) (((Scheme_Simple_Object *)(obj))->u.char_str_val.string_val)
#define SCHEME_CHAR_STRTAG_VAL(obj) (((Scheme_Simple_Object *)(obj))->u.char_str_val.tag_val)
#define SCHEME_CHAR_STRLEN_VAL(obj) (((Scheme_Simple_Object *)(obj))->u.char_str_val.tag_val)
#define SCHEME_BYTE_STR_VAL(obj) (((Scheme_Simple_Object *)(obj))->u.byte_str_val.string_val)
#define SCHEME_BYTE_STRTAG_VAL(obj) (((Scheme_Simple_Object *)(obj))->u.byte_str_val.tag_val)
#define SCHEME_BYTE_STRLEN_VAL(obj) (((Scheme_Simple_Object *)(obj))->u.byte_str_val.tag_val)
#define SCHEME_PATH_VAL(obj) (((Scheme_Simple_Object *)(obj))->u.byte_str_val.string_val)
#define SCHEME_PATH_LEN(obj) (((Scheme_Simple_Object *)(obj))->u.byte_str_val.tag_val)
#define SCHEME_SYM_VAL(obj) (((Scheme_Symbol *)((Scheme_Simple_Object *)(obj)))->s)
#define SCHEME_SYM_LEN(obj) (((Scheme_Symbol *)((Scheme_Simple_Object *)(obj)))->len)
#define SCHEME_KEYWORD_VAL(obj) SCHEME_SYM_VAL(obj)
#define SCHEME_KEYWORD_LEN(obj) SCHEME_SYM_LEN(obj)
#define SCHEME_SYMSTR_OFFSET(obj) ((uintptr_t)SCHEME_SYM_VAL(obj)-(uintptr_t)(obj))
/* return a `char *' pointing to the string or the symbol name */
#define SCHEME_STRSYM_VAL(obj) (SCHEME_SYMBOLP(obj) ? SCHEME_SYM_VAL(obj) : SCHEME_CHAR_STR_VAL(obj))
#define SCHEME_BOX_VAL(obj) (((Scheme_Small_Object *)(obj))->u.ptr_val)
#define SCHEME_CAR(obj) (((Scheme_Simple_Object *)(obj))->u.pair_val.car)
#define SCHEME_CDR(obj) (((Scheme_Simple_Object *)(obj))->u.pair_val.cdr)
#define SCHEME_CADR(obj) (SCHEME_CAR (SCHEME_CDR (obj)))
#define SCHEME_CAAR(obj) (SCHEME_CAR (SCHEME_CAR (obj)))
#define SCHEME_CDDR(obj) (SCHEME_CDR (SCHEME_CDR (obj)))
#define SCHEME_MCAR(obj) (((Scheme_Simple_Object *)(obj))->u.pair_val.car)
#define SCHEME_MCDR(obj) (((Scheme_Simple_Object *)(obj))->u.pair_val.cdr)
#define SCHEME_VEC_SIZE(obj) (((Scheme_Vector *)(obj))->size)
#define SCHEME_VEC_ELS(obj) (((Scheme_Vector *)(obj))->els)
#define SCHEME_VEC_BASE(obj) SCHEME_VEC_ELS(obj)
#define SCHEME_FLVEC_SIZE(obj) (((Scheme_Double_Vector *)(obj))->size)
#define SCHEME_FLVEC_ELS(obj) (((Scheme_Double_Vector *)(obj))->els)
#ifdef MZ_LONG_DOUBLE
#define SCHEME_EXTFLVEC_SIZE(obj) (((Scheme_Long_Double_Vector *)(obj))->size)
#define SCHEME_EXTFLVEC_ELS(obj) (((Scheme_Long_Double_Vector *)(obj))->els)
#endif
#define SCHEME_FXVEC_SIZE(obj) SCHEME_VEC_SIZE(obj)
#define SCHEME_FXVEC_ELS(obj) SCHEME_VEC_ELS(obj)
#define SCHEME_ENVBOX_VAL(obj) (*((Scheme_Object **)(obj)))
#define SCHEME_WEAK_BOX_VAL(obj) SCHEME_BOX_VAL(obj)
#define SCHEME_PTR_VAL(obj) (((Scheme_Small_Object *)(obj))->u.ptr_val)
#define SCHEME_PTR1_VAL(obj) (((Scheme_Simple_Object *)(obj))->u.two_ptr_val.ptr1)
#define SCHEME_PTR2_VAL(obj) (((Scheme_Simple_Object *)(obj))->u.two_ptr_val.ptr2)
#define SCHEME_IPTR_VAL(obj) (((Scheme_Simple_Object *)(obj))->u.ptr_int_val.ptr)
#define SCHEME_LPTR_VAL(obj) (((Scheme_Simple_Object *)(obj))->u.ptr_long_val.ptr)
#define SCHEME_INT1_VAL(obj) (((Scheme_Simple_Object *)(obj))->u.two_int_val.int1)
#define SCHEME_INT2_VAL(obj) (((Scheme_Simple_Object *)(obj))->u.two_int_val.int2)
#define SCHEME_PINT_VAL(obj) (((Scheme_Simple_Object *)(obj))->u.ptr_int_val.pint)
#define SCHEME_PLONG_VAL(obj) (((Scheme_Simple_Object *)(obj))->u.ptr_long_val.pint)
typedef struct Scheme_Cptr
{
Scheme_Inclhash_Object so; /* 0x1 => an external pointer (not GCable); 0x2 => has offset */
void *val;
Scheme_Object *type;
} Scheme_Cptr;
typedef struct Scheme_Offset_Cptr
{
Scheme_Cptr cptr;
intptr_t offset;
} Scheme_Offset_Cptr;
#define SCHEME_CPTR_VAL(obj) (((Scheme_Cptr *)(obj))->val)
#define SCHEME_CPTR_TYPE(obj) (((Scheme_Cptr *)(obj))->type)
#define SCHEME_CPTR_OFFSET(obj) (SCHEME_CPTR_HAS_OFFSET(obj) ? ((Scheme_Offset_Cptr *)obj)->offset : 0)
#define SCHEME_CPTR_FLAGS(obj) MZ_OPT_HASH_KEY(&((Scheme_Cptr *)(obj))->so)
#define SCHEME_CPTR_HAS_OFFSET(obj) (SCHEME_CPTR_FLAGS(obj) & 0x2)
#define SCHEME_SET_IMMUTABLE(obj) ((MZ_OPT_HASH_KEY((Scheme_Inclhash_Object *)(obj)) |= 0x1))
#define SCHEME_SET_CHAR_STRING_IMMUTABLE(obj) SCHEME_SET_IMMUTABLE(obj)
#define SCHEME_SET_BYTE_STRING_IMMUTABLE(obj) SCHEME_SET_IMMUTABLE(obj)
#define SCHEME_SET_VECTOR_IMMUTABLE(obj) SCHEME_SET_IMMUTABLE(obj)
#define SCHEME_SET_BOX_IMMUTABLE(obj) SCHEME_SET_IMMUTABLE(obj)
/*========================================================================*/
/* fast basic Scheme constructor macros */
/*========================================================================*/
#define scheme_make_integer(i) LONG_TO_OBJ ((OBJ_TO_LONG(i) << 1) | 0x1)
#define scheme_make_character(ch) ((((mzchar)ch) < 256) ? scheme_char_constants[(unsigned char)(ch)] : scheme_make_char(ch))
#define scheme_make_ascii_character(ch) scheme_char_constants[(unsigned char)(ch)]
#define scheme_uchar_find(table, x) (table[(x >> 8) & 0x1FFF][x & 0xFF])
#define scheme_isblank(x) ((scheme_uchar_find(scheme_uchar_table, x)) & 0x1)
#define scheme_issymbol(x) ((scheme_uchar_find(scheme_uchar_table, x)) & 0x2)
#define scheme_ispunc(x) ((scheme_uchar_find(scheme_uchar_table, x)) & 0x4)
#define scheme_iscontrol(x) ((scheme_uchar_find(scheme_uchar_table, x)) & 0x8)
#define scheme_isspace(x) ((scheme_uchar_find(scheme_uchar_table, x)) & 0x10)
/* #define scheme_isSOMETHING(x) ((scheme_uchar_find(scheme_uchar_table, x)) & 0x20) - not yet used */
#define scheme_isdigit(x) ((scheme_uchar_find(scheme_uchar_table, x)) & 0x40)
#define scheme_isalpha(x) ((scheme_uchar_find(scheme_uchar_table, x)) & 0x80)
#define scheme_istitle(x) ((scheme_uchar_find(scheme_uchar_table, x)) & 0x100)
#define scheme_isupper(x) ((scheme_uchar_find(scheme_uchar_table, x)) & 0x200)
#define scheme_islower(x) ((scheme_uchar_find(scheme_uchar_table, x)) & 0x400)
#define scheme_isgraphic(x) ((scheme_uchar_find(scheme_uchar_table, x)) & 0x800)
#define scheme_iscaseignorable(x) ((scheme_uchar_find(scheme_uchar_table, x)) & 0x1000)
#define scheme_isspecialcasing(x) ((scheme_uchar_find(scheme_uchar_table, x)) & 0x2000)
#define scheme_needs_decompose(x) ((scheme_uchar_find(scheme_uchar_table, x)) & 0x4000)
#define scheme_needs_maybe_compose(x) ((scheme_uchar_find(scheme_uchar_table, x)) & 0x8000)
#define scheme_iscased(x) ((scheme_uchar_find(scheme_uchar_table, x)) & 0x700)
#define scheme_toupper(x) (x + scheme_uchar_ups[scheme_uchar_find(scheme_uchar_cases_table, x)])
#define scheme_tolower(x) (x + scheme_uchar_downs[scheme_uchar_find(scheme_uchar_cases_table, x)])
#define scheme_totitle(x) (x + scheme_uchar_titles[scheme_uchar_find(scheme_uchar_cases_table, x)])
#define scheme_tofold(x) (x + scheme_uchar_folds[scheme_uchar_find(scheme_uchar_cases_table, x)])
#define scheme_combining_class(x) (scheme_uchar_combining_classes[scheme_uchar_find(scheme_uchar_cases_table, x)])
#define scheme_general_category(x) ((scheme_uchar_find(scheme_uchar_cats_table, x)) & 0x1F)
/* Note: 3 bits available in the cats table */
/*========================================================================*/
/* procedure values */
/*========================================================================*/
/* Constants for flags in Scheme_Primitive_[Closed]_Proc.
Do not use them directly. */
#define SCHEME_PRIM_OPT_MASK (1 | 2)
#define SCHEME_PRIM_IS_PRIMITIVE 4
#define SCHEME_PRIM_IS_MULTI_RESULT 8
#define SCHEME_PRIM_IS_CLOSURE 16
#define SCHEME_PRIM_OTHER_TYPE_MASK (32 | 64 | 128 | 256)
#define SCHEME_PRIM_IS_METHOD 512
#define SCHEME_PRIM_OPT_INDEX_SIZE 6
#define SCHEME_PRIM_OPT_INDEX_SHIFT 10
#define SCHEME_PRIM_OPT_INDEX_MASK ((1 << SCHEME_PRIM_OPT_INDEX_SIZE) - 1)
/* Values with SCHEME_PRIM_OPT_MASK, earlier implies later: */
#define SCHEME_PRIM_OPT_FOLDING 3
#define SCHEME_PRIM_OPT_IMMEDIATE 2
#define SCHEME_PRIM_OPT_NONCM 1
/* Values with SCHEME_PRIM_OTHER_TYPE_MASK */
#define SCHEME_PRIM_STRUCT_TYPE_INDEXLESS_GETTER (32 | 256)
#define SCHEME_PRIM_STRUCT_TYPE_CONSTR 128
#define SCHEME_PRIM_STRUCT_TYPE_SIMPLE_CONSTR (32 | 64 | 128)
#define SCHEME_PRIM_STRUCT_TYPE_INDEXLESS_SETTER 256
#define SCHEME_PRIM_STRUCT_TYPE_INDEXED_SETTER (128 | 256)
#define SCHEME_PRIM_STRUCT_TYPE_BROKEN_INDEXED_SETTER (32 | 128)
#define SCHEME_PRIM_TYPE_PARAMETER 64
#define SCHEME_PRIM_TYPE_STRUCT_PROP_GETTER (64 | 128)
#define SCHEME_PRIM_STRUCT_TYPE_STRUCT_PROP_PRED (64 | 128 | 256)
#define SCHEME_PRIM_STRUCT_TYPE_INDEXED_GETTER 32
#define SCHEME_PRIM_STRUCT_TYPE_PRED (32 | 64)
#define SCHEME_PRIM_PROC_FLAGS(x) (((Scheme_Prim_Proc_Header *)x)->flags)
typedef struct Scheme_Object *(Scheme_Prim)(int argc, Scheme_Object *argv[]);
typedef struct Scheme_Object *(Scheme_Primitive_Closure_Proc)(int argc, struct Scheme_Object *argv[], Scheme_Object *p);
#define SCHEME_MAX_ARGS 0x3FFFFFFE
typedef struct {
Scheme_Object so;
unsigned short flags;
} Scheme_Prim_Proc_Header;
typedef struct {
Scheme_Prim_Proc_Header pp;
Scheme_Primitive_Closure_Proc *prim_val;
const char *name;
mzshort mina;
/* If mina < 0; mina is negated case count minus one for a case-lambda
generated by mzc, where the primitive checks argument arity
itself, and mu.cases is available instead of mu.maxa. */
union {
mzshort *cases;
mzshort maxa; /* > SCHEME_MAX_ARGS => any number of arguments */
} mu;
} Scheme_Primitive_Proc;
typedef struct {
Scheme_Primitive_Proc pp;
mzshort minr, maxr;
/* Never combined with a closure */
} Scheme_Prim_W_Result_Arity;
typedef struct Scheme_Primitive_Closure {
Scheme_Primitive_Proc p;
/* The rest is here only if SCHEME_PRIM_IS_CLOSURE
is set in p.pp.flags. */
#ifdef MZ_PRECISE_GC
mzshort count;
#endif
Scheme_Object *val[mzFLEX_ARRAY_DECL];
} Scheme_Primitive_Closure;
#define SCHEME_PRIM_CLOSURE_ELS(p) ((Scheme_Primitive_Closure *)p)->val
/* ------ Old-style primitive closures ------- */
typedef struct Scheme_Object *(Scheme_Closed_Prim)(void *d, int argc, struct Scheme_Object *argv[]);
typedef struct {
Scheme_Prim_Proc_Header pp;
Scheme_Closed_Prim *prim_val;
void *data;
const char *name;
mzshort mina, maxa; /* mina == -2 => maxa is negated case count and
record is a Scheme_Closed_Case_Primitive_Proc */
} Scheme_Closed_Primitive_Proc;
typedef struct {
Scheme_Closed_Primitive_Proc p;
mzshort *cases;
} Scheme_Closed_Case_Primitive_Proc;
typedef struct {
Scheme_Closed_Primitive_Proc p;
mzshort minr, maxr;
} Scheme_Closed_Prim_W_Result_Arity;
/* ------------------------------------------------- */
/* mzc closure glue
The following are used by mzc to implement closures.
*/
#define _scheme_fill_prim_closure(rec, cfunc, nm, amin, amax, flgs) \
((rec)->pp.so.type = scheme_prim_type, \
(rec)->prim_val = cfunc, \
(rec)->name = nm, \
(rec)->mina = amin, \
(rec)->mu.maxa = (amax == -1 ? SCHEME_MAX_ARGS + 1 : amax), \
(rec)->pp.flags = flgs, \
rec)
#ifdef MZ_PRECISE_GC
# define _scheme_fill_prim_closure_post(rec, cfunc, nm, amin, amax, flgs, ln) \
((rec)->count = ln, \
_scheme_fill_prim_closure(&(rec)->p, cfunc, nm, amin, amax, \
flgs | SCHEME_PRIM_IS_CLOSURE))
#else
# define _scheme_fill_prim_closure_post(rec, cfunc, nm, amin, amax, flgs, ln) \
_scheme_fill_prim_closure(&(rec)->p, cfunc, nm, amin, amax, flgs)
#endif
#define _scheme_fill_prim_case_closure(rec, cfunc, nm, ccount, cses, flgs) \
((rec)->pp.so.type = scheme_prim_type, \
(rec)->prim_val = cfunc, \
(rec)->name = nm, \
(rec)->mina = -(ccount+1), \
(rec)->pp.flags = flgs, \
(rec)->mu.cases = cses, \
rec)
#ifdef MZ_PRECISE_GC
# define _scheme_fill_prim_case_closure_post(rec, cfunc, nm, ccount, cses, flgs, ln) \
((rec)->count = ln, \
_scheme_fill_prim_case_closure(&((rec)->p), cfunc, nm, ccount, cses, \
flgs | SCHEME_PRIM_IS_CLOSURE))
#else
# define _scheme_fill_prim_case_closure_post(rec, cfunc, nm, ccount, cses, flgs, ln) \
_scheme_fill_prim_case_closure(&((rec)->p), cfunc, nm, ccount, cses, flgs)
#endif
/* ------------------------------------------------- */
#define SCHEME_PROCP(obj) (!SCHEME_INTP(obj) && ((_SCHEME_TYPE(obj) >= scheme_prim_type) && (_SCHEME_TYPE(obj) <= scheme_proc_chaperone_type)))
#define SCHEME_SYNTAXP(obj) SAME_TYPE(SCHEME_TYPE(obj), scheme_syntax_compiler_type)
#define SCHEME_PRIMP(obj) SAME_TYPE(SCHEME_TYPE(obj), scheme_prim_type)
#define SCHEME_CLSD_PRIMP(obj) SAME_TYPE(SCHEME_TYPE(obj), scheme_closed_prim_type)
#define SCHEME_CONTP(obj) SAME_TYPE(SCHEME_TYPE(obj), scheme_cont_type)
#define SCHEME_ECONTP(obj) SAME_TYPE(SCHEME_TYPE(obj), scheme_escaping_cont_type)
#define SCHEME_CONT_MARK_SETP(obj) SAME_TYPE(SCHEME_TYPE(obj), scheme_cont_mark_set_type)
#define SCHEME_PROC_STRUCTP(obj) SAME_TYPE(SCHEME_TYPE(obj), scheme_proc_struct_type)
#define SCHEME_CLOSUREP(obj) (SAME_TYPE(SCHEME_TYPE(obj), scheme_closure_type) || SAME_TYPE(SCHEME_TYPE(obj), scheme_case_closure_type))
#define SCHEME_PRIM(obj) (((Scheme_Primitive_Proc *)(obj))->prim_val)
#define SCHEME_CLSD_PRIM(obj) (((Scheme_Closed_Primitive_Proc *)(obj))->prim_val)
#define SCHEME_CLSD_PRIM_DATA(obj) (((Scheme_Closed_Primitive_Proc *)(obj))->data)
#define SCHEME_CLOS_FUNC(obj) ((Scheme_Closure_Func)SCHEME_CAR(obj))
#define SCHEME_CLOS_DATA(obj) SCHEME_CDR(obj)
/*========================================================================*/
/* hash tables and environments */
/*========================================================================*/
typedef struct Scheme_Hash_Table
{
Scheme_Inclhash_Object iso; /* 0x1 flag => print as opaque (e.g., exports table); 0x2 => misc (e.g., top-level multi_scopes) */
intptr_t size; /* power of 2 */
intptr_t count;
Scheme_Object **keys;
Scheme_Object **vals;
void (*make_hash_indices)(void *v, intptr_t *h1, intptr_t *h2);
int (*compare)(void *v1, void *v2);
Scheme_Object *mutex;
intptr_t mcount; /* number of non-NULL keys, >= count (which is non-NULL vals) */
} Scheme_Hash_Table;
typedef struct Scheme_Hash_Tree Scheme_Hash_Tree;
typedef struct Scheme_Bucket
{
Scheme_Object so;
void *val;
char *key;
} Scheme_Bucket;
typedef struct Scheme_Bucket_Table
{
Scheme_Object so;
intptr_t size; /* power of 2 */
intptr_t count;
Scheme_Bucket **buckets;
char weak; /* 1 => normal weak, 2 => late weak */
char with_home;
void (*make_hash_indices)(void *v, intptr_t *h1, intptr_t *h2);
int (*compare)(void *v1, void *v2);
Scheme_Object *mutex;
} Scheme_Bucket_Table;
/* Hash tablekey types, used with scheme_hash_table */
enum {
SCHEME_hash_string,
SCHEME_hash_ptr,
SCHEME_hash_weak_ptr,
SCHEME_hash_late_weak_ptr
};
typedef struct Scheme_Env Scheme_Env;
#define SCHEME_VAR_BUCKET(obj) ((Scheme_Bucket *)(obj))
/*========================================================================*/
/* setjmpup (continuation) support */
/*========================================================================*/
#ifdef USE_MZ_SETJMP
# if defined(_WIN64)
# define USE_MZ_SETJMP_INDIRECT
typedef intptr_t mz_pre_jmp_buf[31];
# else
typedef intptr_t mz_pre_jmp_buf[8];
# endif
#else
# define mz_pre_jmp_buf jmp_buf
#endif
#ifdef MZ_USE_JIT
typedef struct {
mz_pre_jmp_buf jb;
uintptr_t stack_frame; /* declared as `uintptr_t' to hide pointer from 3m xform */
} mz_one_jit_jmp_buf;
typedef mz_one_jit_jmp_buf mz_jit_jmp_buf[1];
#else
# define mz_jit_jmp_buf mz_pre_jmp_buf
#endif
#ifdef MZ_PRECISE_GC
typedef struct {
XFORM_CAN_IGNORE mz_jit_jmp_buf jb;
intptr_t gcvs; /* declared as `intptr_t' to hide pointer from 3m xform */
intptr_t gcvs_cnt;
} mz_jmp_buf;
#else
# define mz_jmp_buf mz_jit_jmp_buf
#endif
/* Like setjmp & longjmp, but you can jmp to a deeper stack position */
/* Initialize a Scheme_Jumpup_Buf record before using it */
typedef struct Scheme_Jumpup_Buf {
void *stack_from, *stack_copy;
intptr_t stack_size, stack_max_size;
struct Scheme_Cont *cont; /* for sharing continuation tails */
mz_jmp_buf buf;
#ifdef MZ_PRECISE_GC
void *gc_var_stack;
void *external_stack;
#endif
} Scheme_Jumpup_Buf;
typedef struct Scheme_Jumpup_Buf_Holder {