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
|
/* Copyright (c) 1993-2008 by Richard Kelsey and Jonathan Rees.
See file COPYING. */
/*
* For building and linking DLLs on Windows, we need to mark functions
* the DLL calls in Scheme 48 and vice versa explicitly---and differently
* depending on whether we're compiling the DLL or Scheme 48 itself.
*
* Therefore, on Windows, we assume that __COMPILING_SCHEME48_ITSELF__
* is defined when Scheme 48 itself is being compiled, and not when
* we're compiling something external against it.
*/
#if defined(__CYGWIN__) || defined(_WIN32)
# ifdef __COMPILING_SCHEME48_ITSELF__
# define S48_EXTERN_ADD_ONS __declspec(dllexport)
# else
# define S48_EXTERN_ADD_ONS __declspec(dllimport)
# endif
#endif
#ifndef S48_EXTERN_ADD_ONS
# define S48_EXTERN_ADD_ONS
#endif
#define S48_EXTERN extern S48_EXTERN_ADD_ONS
#if defined HAVE_STDINT_H
#include <stdint.h> /* uintXX_t, C99 */
#endif
typedef long s48_value;
#define NO_ERRORS 0 /* errno value */
/* Misc stuff */
#define S48_EQ_P(v1, v2) ((v1) == (v2))
/* Superceded name for the above definition, retained for compatibility. */
#define S48_EQ(v1, v2) ((v1) == (v2))
#if SIZEOF_VOID_P == 4
#define S48_MAX_FIXNUM_VALUE ((1 << 29) - 1)
#define S48_MIN_FIXNUM_VALUE (-1 << 29)
#define S48_LOG_BYTES_PER_CELL 2
#elif SIZEOF_VOID_P == 8
#define S48_MAX_FIXNUM_VALUE ((1L << 61) - 1)
#define S48_MIN_FIXNUM_VALUE (-1L << 61)
#define S48_LOG_BYTES_PER_CELL 3
#else
#error "What size are your pointers, really?"
#endif
S48_EXTERN int s48_stob_has_type(s48_value, int);
S48_EXTERN long s48_stob_length(s48_value, int);
S48_EXTERN long s48_stob_byte_length(s48_value, int);
S48_EXTERN s48_value s48_stob_ref(s48_value, int, long);
S48_EXTERN void s48_stob_set(s48_value, int, long, s48_value);
S48_EXTERN char s48_stob_byte_ref(s48_value, int, long);
S48_EXTERN void s48_stob_byte_set(s48_value, int, long, char);
S48_EXTERN char * s48_register_gc_rootB(char *);
S48_EXTERN void s48_unregister_gc_rootB(char *);
S48_EXTERN void s48_push_gc_rootsB(char *, long);
S48_EXTERN char s48_pop_gc_rootsB(void);
S48_EXTERN s48_value s48_make_string(int, long);
S48_EXTERN void s48_string_set(s48_value s, long i, long c);
S48_EXTERN long s48_string_ref(s48_value s, long i);
S48_EXTERN long s48_string_length(s48_value s);
S48_EXTERN s48_value s48_enter_string_latin_1(char* s);
S48_EXTERN s48_value s48_enter_string_latin_1_n(char* s, long count);
S48_EXTERN void s48_copy_latin_1_to_string(char* s, s48_value sch_s);
S48_EXTERN void s48_copy_latin_1_to_string_n(char* s, long len, s48_value sch_s);
S48_EXTERN void s48_copy_string_to_latin_1(s48_value sch_s, char* s);
S48_EXTERN void s48_copy_string_to_latin_1_n(s48_value sch_s, long start, long count, char* s);
S48_EXTERN s48_value s48_enter_string_utf_8(char* s);
S48_EXTERN s48_value s48_enter_string_utf_8_n(char* s, long count);
S48_EXTERN long s48_string_utf_8_length(s48_value s);
S48_EXTERN long s48_string_utf_8_length_n(s48_value s, long start, long count);
S48_EXTERN void s48_copy_string_to_utf_8(s48_value sch_s, char* s);
S48_EXTERN void s48_copy_string_to_utf_8_n(s48_value sch_s, long start, long count, char* s);
S48_EXTERN s48_value s48_enter_char(long);
S48_EXTERN long s48_extract_char(s48_value);
S48_EXTERN s48_value s48_enter_fixnum(long);
S48_EXTERN long s48_extract_fixnum(s48_value);
S48_EXTERN s48_value s48_enter_integer(long);
S48_EXTERN long s48_extract_integer(s48_value);
S48_EXTERN s48_value s48_enter_unsigned_integer(unsigned long);
S48_EXTERN unsigned long s48_extract_unsigned_integer(s48_value);
S48_EXTERN s48_value s48_enter_double(double);
S48_EXTERN double s48_extract_double(s48_value);
S48_EXTERN s48_value s48_cons(s48_value, s48_value);
S48_EXTERN s48_value s48_enter_byte_vector(char *, long);
S48_EXTERN char * s48_extract_byte_vector(s48_value);
S48_EXTERN s48_value s48_make_vector(int, s48_value);
S48_EXTERN s48_value s48_make_byte_vector(int);
S48_EXTERN s48_value s48_enter_byte_string(char *);
S48_EXTERN s48_value s48_enter_byte_substring(char *, long);
S48_EXTERN s48_value s48_make_record(s48_value);
S48_EXTERN s48_value s48_make_weak_pointer(s48_value);
S48_EXTERN void s48_check_record_type(s48_value, s48_value);
S48_EXTERN long s48_length(s48_value);
S48_EXTERN s48_value s48_enter_pointer(void *);
S48_EXTERN void* s48_extract_pointer(s48_value);
S48_EXTERN s48_value s48_get_imported_binding(char *);
S48_EXTERN void s48_define_exported_binding(char *, s48_value);
S48_EXTERN s48_value s48_set_channel_os_index(s48_value, long);
S48_EXTERN s48_value s48_add_channel(s48_value, s48_value, long);
S48_EXTERN void s48_close_channel(long);
S48_EXTERN long s48_external_event_uid(void);
S48_EXTERN long s48_permanent_external_event_uid(char*);
S48_EXTERN void s48_note_external_event(long);
S48_EXTERN void s48_unregister_external_event_uid(long);
S48_EXTERN void s48_check_enum_set_type(s48_value, s48_value);
S48_EXTERN long s48_enum_set2integer(s48_value);
S48_EXTERN s48_value s48_integer2enum_set(s48_value, long);
S48_EXTERN s48_value s48_call_scheme(s48_value proc, long nargs, ...);
#define S48_EXPORT_FUNCTION(p) (s48_define_exported_binding(#p, s48_enter_pointer((void*) p)))
#define S48_MAKE_VALUE(type) (s48_make_byte_vector(sizeof(type)))
S48_EXTERN void * s48_value_pointer(s48_value);
#define S48_EXTRACT_VALUE_POINTER(x, type) ((type *) s48_value_pointer(x))
#define S48_EXTRACT_VALUE(x, type) (*(S48_EXTRACT_VALUE_POINTER((x), type)))
#define S48_SET_VALUE(x, type, v) (S48_EXTRACT_VALUE((x), type) = (v))
#define S48_UNSAFE_EXTRACT_VALUE_POINTER(x, type) \
(S48_ADDRESS_AFTER_HEADER((x), type))
#define S48_UNSAFE_EXTRACT_VALUE(x, type) \
(*(S48_UNSAFE_EXTRACT_VALUE_POINTER((x), type)))
#define S48_UNSAFE_SET_VALUE(x, type, v) \
(S48_UNSAFE_EXTRACT_VALUE((x), type) = (v))
#define S48_UNSAFE_EXTRACT_DOUBLE(x) \
(*(S48_ADDRESS_AFTER_HEADER((x), double)))
#define S48_DECLARE_GC_PROTECT(n) long ___gc_buffer[(n)+2]
#define S48_GC_PROTECT_1(v) \
(___gc_buffer[2]=(long)&(v), \
s48_push_gc_rootsB((char *) ___gc_buffer, 1))
#define S48_GC_PROTECT_2(v1, v2) \
(___gc_buffer[2]=(long)&(v1), ___gc_buffer[3]=(long)&(v2), \
s48_push_gc_rootsB((char *) ___gc_buffer, 2))
#define S48_GC_PROTECT_3(v1, v2, v3) \
(___gc_buffer[2]=(long)&(v1), \
___gc_buffer[3]=(long)&(v2), \
___gc_buffer[4]=(long)&(v3), \
s48_push_gc_rootsB((char *) ___gc_buffer, 3))
#define S48_GC_PROTECT_4(v1, v2, v3, v4) \
(___gc_buffer[2]=(long)&(v1), \
___gc_buffer[3]=(long)&(v2), \
___gc_buffer[4]=(long)&(v3), \
___gc_buffer[5]=(long)&(v4), \
s48_push_gc_rootsB((char *) ___gc_buffer, 4))
#define S48_GC_PROTECT_5(v1, v2, v3, v4, v5) \
(___gc_buffer[2]=(long)&(v1), \
___gc_buffer[3]=(long)&(v2), \
___gc_buffer[4]=(long)&(v3), \
___gc_buffer[5]=(long)&(v4), \
___gc_buffer[6]=(long)&(v5), \
s48_push_gc_rootsB((char *) ___gc_buffer, 5))
#define S48_GC_PROTECT_6(v1, v2, v3, v4, v5, v6) \
(___gc_buffer[2]=(long)&(v1), \
___gc_buffer[3]=(long)&(v2), \
___gc_buffer[4]=(long)&(v3), \
___gc_buffer[5]=(long)&(v4), \
___gc_buffer[6]=(long)&(v5), \
___gc_buffer[7]=(long)&(v6), \
s48_push_gc_rootsB((char *) ___gc_buffer, 6))
#define S48_GC_PROTECT_7(v1, v2, v3, v4, v5, v6, v7) \
(___gc_buffer[2]=(long)&(v1), \
___gc_buffer[3]=(long)&(v2), \
___gc_buffer[4]=(long)&(v3), \
___gc_buffer[5]=(long)&(v4), \
___gc_buffer[6]=(long)&(v5), \
___gc_buffer[7]=(long)&(v6), \
___gc_buffer[8]=(long)&(v7), \
s48_push_gc_rootsB((char *) ___gc_buffer, 7))
#define S48_GC_PROTECT_8(v1, v2, v3, v4, v5, v6, v7, v8) \
(___gc_buffer[2]=(long)&(v1), \
___gc_buffer[3]=(long)&(v2), \
___gc_buffer[4]=(long)&(v3), \
___gc_buffer[5]=(long)&(v4), \
___gc_buffer[6]=(long)&(v5), \
___gc_buffer[7]=(long)&(v6), \
___gc_buffer[8]=(long)&(v7), \
___gc_buffer[9]=(long)&(v8), \
s48_push_gc_rootsB((char *) ___gc_buffer, 8))
#define S48_GC_PROTECT_9(v1, v2, v3, v4, v5, v6, v7, v8, v9) \
(___gc_buffer[2]=(long)&(v1), \
___gc_buffer[3]=(long)&(v2), \
___gc_buffer[4]=(long)&(v3), \
___gc_buffer[5]=(long)&(v4), \
___gc_buffer[6]=(long)&(v5), \
___gc_buffer[7]=(long)&(v6), \
___gc_buffer[8]=(long)&(v7), \
___gc_buffer[9]=(long)&(v8), \
___gc_buffer[10]=(long)&(v9), \
s48_push_gc_rootsB((char *) ___gc_buffer, 9))
#define S48_GC_PROTECT_10(v1, v2, v3, v4, v5, v6, v7, v8, v9, v10) \
(___gc_buffer[2]=(long)&(v1), \
___gc_buffer[3]=(long)&(v2), \
___gc_buffer[4]=(long)&(v3), \
___gc_buffer[5]=(long)&(v4), \
___gc_buffer[6]=(long)&(v5), \
___gc_buffer[7]=(long)&(v6), \
___gc_buffer[8]=(long)&(v7), \
___gc_buffer[9]=(long)&(v8), \
___gc_buffer[10]=(long)&(v9), \
___gc_buffer[11]=(long)&(v10), \
s48_push_gc_rootsB((char *) ___gc_buffer, 10))
#define S48_GC_UNPROTECT() \
do { if (! s48_pop_gc_rootsB()) \
s48_raise_scheme_exception( S48_EXCEPTION_GC_PROTECTION_MISMATCH, 0); \
} while(0)
#define S48_GC_PROTECT_GLOBAL(v) ((void*)(s48_register_gc_rootB((char *)&(v))))
#define S48_GC_UNPROTECT_GLOBAL(f) (s48_unregister_gc_rootB((char *)(f)))
/* Exceptions */
S48_EXTERN void s48_raise_scheme_exception(long type, long nargs, ...);
S48_EXTERN void s48_raise_argument_type_error(s48_value value);
S48_EXTERN void s48_raise_argument_number_error(s48_value value,
s48_value min,
s48_value max);
S48_EXTERN void s48_raise_range_error(s48_value value,
s48_value min,
s48_value max);
S48_EXTERN void s48_raise_closed_channel_error();
S48_EXTERN void s48_raise_os_error(int the_errno);
S48_EXTERN void s48_raise_string_os_error(char *reason);
S48_EXTERN void s48_raise_out_of_memory_error();
/* Type checking */
#define S48_CHECK_PAIR(v) do { if (!S48_PAIR_P(v)) s48_raise_argument_type_error(v); } while (0)
#define S48_CHECK_FIXNUM(v) do { if (!S48_FIXNUM_P(v)) s48_raise_argument_type_error(v); } while (0)
#define S48_CHECK_STRING(v) do { if (!S48_STRING_P(v)) s48_raise_argument_type_error(v); } while (0)
#define S48_CHECK_BYTE_VECTOR(v) do { if (!S48_BYTE_VECTOR_P(v)) s48_raise_argument_type_error(v); } while (0)
#define S48_CHECK_CHANNEL(v) do { if (!S48_CHANNEL_P(v)) s48_raise_argument_type_error(v); } while (0)
#define S48_CHECK_RECORD(v) do { if (!S48_RECORD_P(v)) s48_raise_argument_type_error(v); } while (0)
#define S48_CHECK_VALUE(v) do { if (!S48_BYTE_VECTOR_P(v)) s48_raise_argument_type_error(v); } while (0)
#define S48_CHECK_EXPORT_BINDING(v) do { if (!S48_EXPORT_BINDING_P(v)) s48_raise_argument_type_error(v); } while (0)
#define S48_CHECK_BOOLEAN(v) \
do { s48_value s48_temp = (v); \
if (s48_temp != S48_TRUE && s48_temp != S48_FALSE) \
s48_raise_argument_type_error(v); } while (0)
#define S48_VALUE_P(v) (S48_BYTE_VECTOR_P(v))
#define S48_TRUE_P(v) ((v) == S48_TRUE)
#define S48_FALSE_P(v) ((v) == S48_FALSE)
#define S48_EXTRACT_BOOLEAN(v) ((v) != S48_FALSE)
#define S48_ENTER_BOOLEAN(v) ((v) ? S48_TRUE : S48_FALSE)
#define S48_SHARED_BINDING_CHECK(binding) \
do { if (S48_UNSPECIFIC == S48_SHARED_BINDING_REF(binding)) \
s48_raise_scheme_exception(S48_EXCEPTION_UNBOUND_EXTERNAL_NAME, 1, \
S48_SHARED_BINDING_NAME(binding)); \
} while(0)
|
