1 /*
2 * Part of Scheme 48 1.9. See file COPYING for notices and license.
3 *
4 * Authors: Richard Kelsey, Jonathan Rees, Marcus Crestani, Mike Sperber,
5 * Robert Ransom, Harald Glab-Phlak, Marcel Turino
6 */
7
8 #include <stdlib.h>
9 #include <stdio.h>
10 #include <string.h>
11 #include <setjmp.h>
12 #include <stdarg.h>
13
14 #include "c-mods.h"
15 #include "scheme48.h"
16 #include "scheme48vm.h"
17 #include "bignum.h"
18 #include "ffi.h"
19
20 /*
21 * The Joy of C
22 * I don't understand why we need this, but we do.
23 */
24
25 struct s_jmp_buf {
26 jmp_buf buf;
27 };
28
29 /*
30 * Longjump target set up by the most recent call into C.
31 */
32 static struct s_jmp_buf current_return_point;
33
34 /*
35 * The name of the procedure we are currently executing; used for error messages.
36 */
37 static s48_ref_t current_procedure = NULL;
38
39 /*
40 * Stack of Scheme stack-block records which represent portions of the process
41 * stack.
42 */
43 static s48_ref_t current_stack_block = NULL;
44
45 /*
46 * These need to agree with the record definition in callback.scm.
47 */
48 #define STACK_BLOCK_FREE(stack_block) S48_UNSAFE_RECORD_REF(stack_block, 0)
49 #define STACK_BLOCK_UNWIND(stack_block) S48_UNSAFE_RECORD_REF(stack_block, 1)
50 #define STACK_BLOCK_PROC(stack_block) S48_UNSAFE_RECORD_REF(stack_block, 2)
51 #define STACK_BLOCK_THREAD(stack_block) S48_UNSAFE_RECORD_REF(stack_block, 3)
52 #define STACK_BLOCK_NEXT(stack_block) S48_UNSAFE_RECORD_REF(stack_block, 4)
53
54 #define STACK_BLOCK_FREE_2(c, stack_block) \
55 s48_unsafe_record_ref_2(c, stack_block, 0)
56 #define STACK_BLOCK_UNWIND_2(c, stack_block) \
57 s48_unsafe_record_ref_2(c, stack_block, 1)
58 #define STACK_BLOCK_PROC_2(c, stack_block) \
59 s48_unsafe_record_ref_2(c, stack_block, 2)
60 #define STACK_BLOCK_THREAD_2(c, stack_block) \
61 s48_unsafe_record_ref_2(c, stack_block, 3)
62 #define STACK_BLOCK_NEXT_2(c, stack_block) \
63 s48_unsafe_record_ref_2(c, stack_block, 4)
64
65 #define s48_push_2(c, x) s48_push(s48_deref(x))
66
67 #ifdef DEBUG_FFI
68 /*
69 * For debugging.
70 */
71
callback_depth()72 static int callback_depth()
73 {
74 int depth = 0;
75 s48_value stack = s48_deref(current_stack_block);
76
77 for(; stack != S48_FALSE; depth++, stack = STACK_BLOCK_NEXT(stack));
78
79 return depth;
80 }
81 #endif
82
83 /*
84 * The value being returned from an external call. The returns may be preceded
85 * by a longjmp(), so we stash the value here.
86 */
87 static s48_value external_return_value;
88
89 /* Exports to Scheme */
90 static s48_value s48_clear_stack_top(void);
91 static s48_ref_t s48_system_2(s48_call_t call, s48_ref_t string);
92
93 /* Imports from Scheme */
94 static s48_ref_t the_record_type_binding = NULL;
95 static s48_ref_t stack_block_type_binding = NULL;
96 static s48_ref_t callback_binding = NULL;
97 static s48_ref_t delay_callback_return_binding = NULL;
98
99 #ifdef DEBUG_FFI
100 static s48_value s48_trampoline(s48_value proc, s48_value nargs);
101 #endif
102 static s48_ref_t s48_trampoline_2(s48_call_t call, s48_ref_t proc, s48_ref_t nargs);
103
104 void
s48_initialize_external()105 s48_initialize_external()
106 {
107 the_record_type_binding =
108 s48_get_imported_binding_2("s48-the-record-type");
109
110 stack_block_type_binding =
111 s48_get_imported_binding_2("s48-stack-block-type");
112
113 callback_binding =
114 s48_get_imported_binding_2("s48-callback");
115
116 delay_callback_return_binding =
117 s48_get_imported_binding_2("s48-delay-callback-return");
118
119 current_stack_block = s48_make_global_ref(_s48_value_false);
120 current_procedure = s48_make_global_ref(_s48_value_false);
121
122 S48_EXPORT_FUNCTION(s48_clear_stack_top);
123 S48_EXPORT_FUNCTION(s48_system_2);
124
125 #ifdef DEBUG_FFI
126 S48_EXPORT_FUNCTION(s48_trampoline);
127 #endif
128 S48_EXPORT_FUNCTION(s48_trampoline_2);
129
130 #ifdef DEBUG_FFI
131 init_debug_ffi ();
132 #endif
133 }
134
135 /* The three reasons for an extern-call longjump. */
136
137 #define NO_THROW 0
138 #define EXCEPTION_THROW 1
139 #define CLEANUP_THROW 2
140
141 /*
142 * Used to call `proc' from Scheme code. `nargs' the number of arguments in
143 * vector `argv'. If `spread_p' is true the procedure is applied to the
144 * arguments, otherwise `proc' is just called on `nargs' and `argv'.
145 *
146 * We do a setjmp() to get a return point for clearing off this portion of
147 * the process stack. This is used when `proc' calls back to Scheme and
148 * then a throw transfers control up past the call to `proc'.
149 */
150
151 typedef s48_value (*proc_0_t)(void);
152 typedef s48_value (*proc_1_t)(s48_value);
153 typedef s48_value (*proc_2_t)(s48_value, s48_value);
154 typedef s48_value (*proc_3_t)(s48_value, s48_value, s48_value);
155 typedef s48_value (*proc_4_t)(s48_value, s48_value, s48_value, s48_value);
156 typedef s48_value (*proc_5_t)(s48_value, s48_value, s48_value, s48_value,
157 s48_value);
158 typedef s48_value (*proc_6_t)(s48_value, s48_value, s48_value, s48_value,
159 s48_value, s48_value);
160 typedef s48_value (*proc_7_t)(s48_value, s48_value, s48_value, s48_value,
161 s48_value, s48_value, s48_value);
162 typedef s48_value (*proc_8_t)(s48_value, s48_value, s48_value, s48_value,
163 s48_value, s48_value, s48_value, s48_value);
164 typedef s48_value (*proc_9_t)(s48_value, s48_value, s48_value, s48_value,
165 s48_value, s48_value, s48_value, s48_value,
166 s48_value);
167 typedef s48_value (*proc_10_t)(s48_value, s48_value, s48_value, s48_value,
168 s48_value, s48_value, s48_value, s48_value,
169 s48_value, s48_value);
170 typedef s48_value (*proc_11_t)(s48_value, s48_value, s48_value, s48_value,
171 s48_value, s48_value, s48_value, s48_value,
172 s48_value, s48_value, s48_value);
173 typedef s48_value (*proc_12_t)(s48_value, s48_value, s48_value, s48_value,
174 s48_value, s48_value, s48_value, s48_value,
175 s48_value, s48_value, s48_value, s48_value);
176 typedef s48_value (*proc_n_t)(int, s48_value []);
177
178 s48_value
s48_external_call(s48_value sch_proc,s48_value proc_name,long nargs,char * char_argv)179 s48_external_call(s48_value sch_proc, s48_value proc_name,
180 long nargs, char *char_argv)
181 {
182 volatile char *gc_roots_marker; /* volatile to survive longjumps */
183 volatile s48_value name = proc_name; /* volatile to survive longjumps */
184
185 #ifdef DEBUG_FFI
186 int depth; /* debugging */
187 #endif
188
189 long *argv = (long *) char_argv;
190
191 proc_0_t proc = S48_EXTRACT_VALUE(sch_proc, proc_0_t);
192
193 int throw_reason;
194
195 s48_setref(current_procedure, name);
196
197 S48_CHECK_VALUE(sch_proc);
198 S48_CHECK_STRING(name);
199
200 gc_roots_marker = s48_set_gc_roots_baseB();
201
202 #ifdef DEBUG_FFI
203 depth = callback_depth();
204 fprintf(stderr, "[external_call at depth %d]\n", depth);
205 #endif
206
207 throw_reason = setjmp(current_return_point.buf);
208
209 if (throw_reason == NO_THROW) { /* initial entry */
210 switch (nargs) {
211 case 0:
212 external_return_value = proc();
213 break;
214 case 1:
215 external_return_value = ((proc_1_t)proc)(argv[0]);
216 break;
217 case 2:
218 external_return_value = ((proc_2_t)proc)(argv[1], argv[0]);
219 break;
220 case 3:
221 external_return_value = ((proc_3_t)proc)(argv[2], argv[1], argv[0]);
222 break;
223 case 4:
224 external_return_value = ((proc_4_t)proc)(argv[3], argv[2], argv[1], argv[0]);
225 break;
226 case 5:
227 external_return_value = ((proc_5_t)proc)(argv[4],
228 argv[3], argv[2], argv[1], argv[0]);
229 break;
230 case 6:
231 external_return_value = ((proc_6_t)proc)(argv[5], argv[4],
232 argv[3], argv[2], argv[1], argv[0]);
233 break;
234 case 7:
235 external_return_value = ((proc_7_t)proc)(argv[6], argv[5], argv[4],
236 argv[3], argv[2], argv[1], argv[0]);
237 break;
238 case 8:
239 external_return_value = ((proc_8_t)proc)(argv[7], argv[6], argv[5], argv[4],
240 argv[3], argv[2], argv[1], argv[0]);
241 break;
242 case 9:
243 external_return_value = ((proc_9_t)proc)(argv[8],
244 argv[7], argv[6], argv[5], argv[4],
245 argv[3], argv[2], argv[1], argv[0]);
246 break;
247 case 10:
248 external_return_value = ((proc_10_t)proc)(argv[9], argv[8],
249 argv[7], argv[6], argv[5], argv[4],
250 argv[3], argv[2], argv[1], argv[0]);
251 break;
252 case 11:
253 external_return_value = ((proc_11_t)proc)(argv[10], argv[9], argv[8],
254 argv[7], argv[6], argv[5], argv[4],
255 argv[3], argv[2], argv[1], argv[0]);
256 break;
257 case 12:
258 external_return_value = ((proc_12_t)proc)(argv[11], argv[10], argv[9], argv[8],
259 argv[7], argv[6], argv[5], argv[4],
260 argv[3], argv[2], argv[1], argv[0]);
261 break;
262 default:
263 external_return_value = ((proc_n_t)proc)((int)nargs, (s48_value *)argv);
264 }
265
266 /* Raise an exception if the user neglected to pop off some gc roots. */
267
268 if (! s48_release_gc_roots_baseB((char *)gc_roots_marker)) {
269 s48_raise_scheme_exception(S48_EXCEPTION_GC_PROTECTION_MISMATCH, 0);
270 }
271
272 /* Clear any free stack-blocks off of the top of the stack-block stack and
273 then longjmp past the corresponding portions of the process stack. */
274
275 if (s48_deref(current_stack_block) != S48_FALSE &&
276 STACK_BLOCK_FREE(s48_deref(current_stack_block)) == S48_TRUE) {
277
278 s48_value bottom_free_block;
279
280 do {
281 bottom_free_block = s48_deref(current_stack_block);
282 s48_setref(current_stack_block, STACK_BLOCK_NEXT(s48_deref(current_stack_block)));
283 }
284 while (s48_deref(current_stack_block) != S48_FALSE &&
285 STACK_BLOCK_FREE(s48_deref(current_stack_block)) == S48_TRUE);
286
287 #ifdef DEBUG_FFI
288 fprintf(stderr, "[Freeing stack blocks from %d to %d]\n",
289 depth,
290 callback_depth());
291 #endif
292
293 longjmp(S48_EXTRACT_VALUE_POINTER(STACK_BLOCK_UNWIND(bottom_free_block),
294 struct s_jmp_buf)->buf,
295 CLEANUP_THROW);
296 }
297 }
298 else { /* throwing an exception or unwinding the stack */
299 #ifdef DEBUG_FFI
300 fprintf(stderr, "[external_call throw; was %d and now %d]\n",
301 depth,
302 callback_depth());
303 fprintf(stderr, "[throw unrolling to %ld]\n", gc_roots_marker);
304 #endif
305 s48_release_gc_roots_baseB((char *)gc_roots_marker);
306 }
307
308 /* Check to see if a thread is waiting to return to the next block down. */
309
310 if (s48_deref(current_stack_block) != S48_FALSE &&
311 STACK_BLOCK_THREAD(s48_deref(current_stack_block)) != S48_FALSE) {
312 #ifdef DEBUG_FFI
313 fprintf(stderr, "[releasing return at %d]\n", callback_depth());
314 #endif
315
316 if (throw_reason == EXCEPTION_THROW) {
317 /* We are in the midst of raising an exception, so we need to piggyback
318 our exception on that one. */
319 s48_value old_exception
320 = s48_resetup_external_exception(S48_EXCEPTION_CALLBACK_RETURN_UNCOVERED,
321 2);
322 s48_push(old_exception);
323 s48_push(s48_deref(current_stack_block));
324 external_return_value = S48_UNSPECIFIC;
325 }
326 else {
327 s48_setup_external_exception(S48_EXCEPTION_CALLBACK_RETURN_UNCOVERED, 2);
328 s48_push(s48_deref(current_stack_block));
329 s48_push(external_return_value);
330 external_return_value = S48_UNSPECIFIC;
331 }
332 }
333
334 return external_return_value;
335 }
336
337 /*
338 * The value being returned from an external call. The returns may be preceded
339 * by a longjmp(), so we stash the value here.
340 */
341 static s48_ref_t cexternal_return_value;
342
343 typedef s48_ref_t (*cproc_0_t)(s48_call_t);
344 typedef s48_ref_t (*cproc_1_t)(s48_call_t,
345 s48_ref_t);
346 typedef s48_ref_t (*cproc_2_t)(s48_call_t,
347 s48_ref_t, s48_ref_t);
348 typedef s48_ref_t (*cproc_3_t)(s48_call_t,
349 s48_ref_t, s48_ref_t, s48_ref_t);
350 typedef s48_ref_t (*cproc_4_t)(s48_call_t,
351 s48_ref_t, s48_ref_t, s48_ref_t, s48_ref_t);
352 typedef s48_ref_t (*cproc_5_t)(s48_call_t,
353 s48_ref_t, s48_ref_t, s48_ref_t, s48_ref_t,
354 s48_ref_t);
355 typedef s48_ref_t (*cproc_6_t)(s48_call_t,
356 s48_ref_t, s48_ref_t, s48_ref_t, s48_ref_t,
357 s48_ref_t, s48_ref_t);
358 typedef s48_ref_t (*cproc_7_t)(s48_call_t,
359 s48_ref_t, s48_ref_t, s48_ref_t, s48_ref_t,
360 s48_ref_t, s48_ref_t, s48_ref_t);
361 typedef s48_ref_t (*cproc_8_t)(s48_call_t,
362 s48_ref_t, s48_ref_t, s48_ref_t, s48_ref_t,
363 s48_ref_t, s48_ref_t, s48_ref_t, s48_ref_t);
364 typedef s48_ref_t (*cproc_9_t)(s48_call_t,
365 s48_ref_t, s48_ref_t, s48_ref_t, s48_ref_t,
366 s48_ref_t, s48_ref_t, s48_ref_t, s48_ref_t,
367 s48_ref_t);
368 typedef s48_ref_t (*cproc_10_t)(s48_call_t,
369 s48_ref_t, s48_ref_t, s48_ref_t, s48_ref_t,
370 s48_ref_t, s48_ref_t, s48_ref_t, s48_ref_t,
371 s48_ref_t, s48_ref_t);
372 typedef s48_ref_t (*cproc_11_t)(s48_call_t,
373 s48_ref_t, s48_ref_t, s48_ref_t, s48_ref_t,
374 s48_ref_t, s48_ref_t, s48_ref_t, s48_ref_t,
375 s48_ref_t, s48_ref_t, s48_ref_t);
376 typedef s48_ref_t (*cproc_12_t)(s48_call_t,
377 s48_ref_t, s48_ref_t, s48_ref_t, s48_ref_t,
378 s48_ref_t, s48_ref_t, s48_ref_t, s48_ref_t,
379 s48_ref_t, s48_ref_t, s48_ref_t, s48_ref_t);
380 typedef s48_ref_t (*cproc_n_t)(s48_call_t, int, s48_ref_t []);
381
382 s48_value
s48_external_ecall(s48_call_t call,s48_value sch_proc,s48_value proc_name,long nargs,char * char_argv)383 s48_external_ecall(s48_call_t call,
384 s48_value sch_proc, s48_value proc_name,
385 long nargs, char *char_argv)
386 {
387 volatile char *gc_roots_marker; /* volatile to survive longjumps */
388 volatile s48_value name = proc_name; /* volatile to survive longjumps */
389 s48_call_t new_call;
390 s48_ref_t argv_ref[12];
391 s48_ref_t sch_proc_ref, proc_name_ref;
392 s48_value result;
393
394 #ifdef DEBUG_FFI
395 int depth = callback_depth(); /* debugging */
396 #endif
397
398 long *argv = (long *) char_argv;
399
400 cproc_0_t cproc = S48_EXTRACT_VALUE(sch_proc, cproc_0_t);
401
402 int throw_reason;
403
404 s48_ref_t sbt = NULL;
405
406 s48_setref(current_procedure, name);
407
408 S48_CHECK_VALUE(sch_proc);
409 S48_CHECK_STRING(name);
410
411 gc_roots_marker = s48_set_gc_roots_baseB();
412
413 #ifdef DEBUG_FFI
414 fprintf(stderr, "[external_call_2 at depth %d]\n", depth);
415 #endif
416
417 throw_reason = setjmp(current_return_point.buf);
418
419 if (throw_reason == NO_THROW) { /* initial entry */
420 long i;
421 new_call = s48_push_call (call);
422 for (i = 0; i < nargs; i++)
423 argv_ref[i] = s48_make_local_ref (new_call, argv[i]);
424 sch_proc_ref = s48_make_local_ref (new_call, sch_proc);
425 proc_name_ref = s48_make_local_ref (new_call, proc_name);
426
427 switch (nargs) {
428 case 0:
429 cexternal_return_value = ((cproc_0_t)cproc)(new_call);
430 break;
431 case 1:
432 cexternal_return_value = ((cproc_1_t)cproc)(new_call, argv_ref[0]);
433 break;
434 case 2:
435 cexternal_return_value = ((cproc_2_t)cproc)(new_call, argv_ref[1], argv_ref[0]);
436 break;
437 case 3:
438 cexternal_return_value = ((cproc_3_t)cproc)(new_call, argv_ref[2], argv_ref[1], argv_ref[0]);
439 break;
440 case 4:
441 cexternal_return_value = ((cproc_4_t)cproc)(new_call,
442 argv_ref[3], argv_ref[2], argv_ref[1], argv_ref[0]);
443 break;
444 case 5:
445 cexternal_return_value = ((cproc_5_t)cproc)(new_call, argv_ref[4],
446 argv_ref[3], argv_ref[2], argv_ref[1], argv_ref[0]);
447 break;
448 case 6:
449 cexternal_return_value = ((cproc_6_t)cproc)(new_call, argv_ref[5], argv_ref[4],
450 argv_ref[3], argv_ref[2], argv_ref[1], argv_ref[0]);
451 break;
452 case 7:
453 cexternal_return_value = ((cproc_7_t)cproc)(new_call, argv_ref[6], argv_ref[5], argv_ref[4],
454 argv_ref[3], argv_ref[2], argv_ref[1], argv_ref[0]);
455 break;
456 case 8:
457 cexternal_return_value = ((cproc_8_t)cproc)(new_call,
458 argv_ref[7], argv_ref[6], argv_ref[5], argv_ref[4],
459 argv_ref[3], argv_ref[2], argv_ref[1], argv_ref[0]);
460 break;
461 case 9:
462 cexternal_return_value = ((cproc_9_t)cproc)(new_call, argv_ref[8],
463 argv_ref[7], argv_ref[6], argv_ref[5], argv_ref[4],
464 argv_ref[3], argv_ref[2], argv_ref[1], argv_ref[0]);
465 break;
466 case 10:
467 cexternal_return_value = ((cproc_10_t)cproc)(new_call, argv_ref[9], argv_ref[8],
468 argv_ref[7], argv_ref[6], argv_ref[5], argv_ref[4],
469 argv_ref[3], argv_ref[2], argv_ref[1], argv_ref[0]);
470 break;
471 case 11:
472 cexternal_return_value = ((cproc_11_t)cproc)(new_call, argv_ref[10], argv_ref[9], argv_ref[8],
473 argv_ref[7], argv_ref[6], argv_ref[5], argv_ref[4],
474 argv_ref[3], argv_ref[2], argv_ref[1], argv_ref[0]);
475 break;
476 case 12:
477 cexternal_return_value = ((cproc_12_t)cproc)(new_call,
478 argv_ref[11], argv_ref[10], argv_ref[9], argv_ref[8],
479 argv_ref[7], argv_ref[6], argv_ref[5], argv_ref[4],
480 argv_ref[3], argv_ref[2], argv_ref[1], argv_ref[0]);
481 break;
482 default:
483 cexternal_return_value = ((cproc_n_t)cproc)(new_call, (int) nargs, argv_ref);
484 }
485
486 /* Raise an exception if the user neglected to pop off some gc roots. */
487
488 if (! s48_release_gc_roots_baseB((char *)gc_roots_marker)) {
489 s48_raise_scheme_exception(S48_EXCEPTION_GC_PROTECTION_MISMATCH, 0);
490 }
491
492 /* Clear any free stack-blocks off of the top of the stack-block stack and
493 then longjmp past the corresponding portions of the process stack. */
494
495 if (!s48_false_p_2(new_call, current_stack_block) &&
496 s48_true_p_2(new_call, STACK_BLOCK_FREE_2(new_call, current_stack_block))) {
497
498 s48_ref_t bottom_free_block;
499
500 do {
501 s48_setref(bottom_free_block, s48_deref(current_stack_block));
502 s48_setref(current_stack_block, s48_deref(STACK_BLOCK_NEXT_2(new_call, current_stack_block)));
503 }
504 while (!s48_false_p_2(new_call, current_stack_block) &&
505 s48_false_p_2(new_call, STACK_BLOCK_FREE_2(new_call, current_stack_block)));
506
507 #ifdef DEBUG_FFI
508 fprintf(stderr, "[Freeing stack blocks from %d to %d]\n",
509 depth,
510 callback_depth());
511 #endif
512
513 longjmp(s48_extract_value_pointer_2(new_call,
514 STACK_BLOCK_UNWIND_2(new_call, bottom_free_block),
515 struct s_jmp_buf)->buf,
516 CLEANUP_THROW);
517 }
518 }
519 else { /* throwing an exception or unwinding the stack */
520 #ifdef DEBUG_FFI
521 fprintf(stderr, "[external_call_2 throw; was %d and now %d]\n",
522 depth,
523 callback_depth());
524 fprintf(stderr, "[throw unrolling to %ld]\n", gc_roots_marker);
525 #endif
526 s48_release_gc_roots_baseB((char *)gc_roots_marker);
527 }
528
529 /* otherwise the pop_to will kill us */
530 if (cexternal_return_value)
531 cexternal_return_value = s48_copy_local_ref(call, cexternal_return_value);
532
533 s48_pop_to (call);
534
535 if (cexternal_return_value)
536 result = s48_deref(cexternal_return_value);
537 else
538 result = S48_UNSPECIFIC;
539
540 /* Check to see if a thread is waiting to return to the next block down. */
541 if (!s48_false_p_2(call, current_stack_block) &&
542 !s48_false_p_2(call, sbt = STACK_BLOCK_THREAD_2(call, current_stack_block))) {
543 #ifdef DEBUG_FFI
544 fprintf(stderr, "[releasing return at %d]\n", callback_depth());
545 #endif
546
547 if (throw_reason == EXCEPTION_THROW) {
548 /* We are in the midst of raising an exception, so we need to piggyback
549 our exception on that one. */
550 s48_value old_exception
551 = s48_resetup_external_exception(S48_EXCEPTION_CALLBACK_RETURN_UNCOVERED,
552 2);
553 s48_push(old_exception);
554 s48_push_2(call, current_stack_block);
555
556 if (cexternal_return_value)
557 s48_free_local_ref(call, cexternal_return_value);
558
559 result = S48_UNSPECIFIC;
560 } else {
561 if (cexternal_return_value) {
562 s48_setup_external_exception(S48_EXCEPTION_CALLBACK_RETURN_UNCOVERED, 2);
563 s48_push_2(call, current_stack_block);
564 s48_push_2(call, cexternal_return_value);
565 } else {
566 s48_setup_external_exception(S48_EXCEPTION_CALLBACK_RETURN_UNCOVERED, 1);
567 s48_push_2(call, current_stack_block);
568 }
569 result = S48_UNSPECIFIC;
570 }
571 } else {
572 if (cexternal_return_value)
573 s48_free_local_ref(call, cexternal_return_value);
574 }
575
576 if(sbt != NULL)
577 s48_free_local_ref(call, sbt);
578
579 return result;
580 }
581
582 s48_value
s48_external_call_2(s48_value sch_proc,s48_value proc_name,long nargs,char * char_argv)583 s48_external_call_2(s48_value sch_proc, s48_value proc_name,
584 long nargs, char *char_argv)
585 {
586 return s48_external_ecall (s48_get_current_call(), sch_proc,
587 proc_name, nargs, char_argv);
588 }
589
590 /*
591 * Call Scheme function `proc' from C. We push the call-back depth, `proc',
592 * and the arguments on the Scheme stack and then restart the VM. The restarted
593 * VM calls the Scheme procedure `callback' which wraps the call to `proc' with
594 * a dynamic-wind. This prevents downward throws back into the call to `proc',
595 * which C can't handle, and allows the C stack to be cleaned up if an upward
596 * throw occurs.
597 *
598 * The maximum number of arguments is determined by the amount of space reserved
599 * on the Scheme stack for exceptions. See the definition of stack-slack in
600 * scheme/vm/stack.scm.
601 */
602 s48_value
s48_call_scheme(s48_value proc,long nargs,...)603 s48_call_scheme(s48_value proc, long nargs, ...)
604 {
605 int i;
606 va_list arguments;
607 s48_value value;
608 s48_value unwind, stack_block;
609 S48_DECLARE_GC_PROTECT(2);
610
611 S48_GC_PROTECT_2(unwind, proc);
612
613 va_start(arguments, nargs);
614
615 S48_SHARED_BINDING_CHECK(s48_deref(callback_binding));
616
617 /* It would be nice to push a list of the arguments, but we have no way
618 of preserving them across a cons. */
619 if (nargs < 0 || 12 < nargs) { /* DO NOT INCREASE THIS NUMBER */
620 s48_value sch_nargs = s48_enter_integer(nargs); /* `proc' is protected */
621 s48_raise_scheme_exception(S48_EXCEPTION_TOO_MANY_ARGUMENTS_IN_CALLBACK,
622 2, proc, sch_nargs);
623 }
624
625 #ifdef DEBUG_FFI
626 fprintf(stderr, "[s48_call_scheme, %ld args, depth %d]\n",
627 nargs, callback_depth());
628 #endif
629
630 s48_push(S48_UNSPECIFIC); /* placeholder */
631 s48_push(proc);
632 for (i = 0; i < nargs; i++)
633 s48_push(va_arg(arguments, s48_value));
634
635 va_end(arguments);
636
637 /* With everything safely on the stack we can do the necessary allocation. */
638
639 unwind = S48_MAKE_VALUE(struct s_jmp_buf);
640 S48_EXTRACT_VALUE(unwind, struct s_jmp_buf) = current_return_point;
641
642 stack_block = s48_make_record(s48_deref(stack_block_type_binding));
643 STACK_BLOCK_UNWIND(stack_block) = unwind;
644 STACK_BLOCK_PROC(stack_block) = s48_deref(current_procedure);
645 STACK_BLOCK_NEXT(stack_block) = s48_deref(current_stack_block);
646 STACK_BLOCK_FREE(stack_block) = S48_FALSE;
647 STACK_BLOCK_THREAD(stack_block) = S48_FALSE;
648
649 S48_GC_UNPROTECT(); /* no more references to `unwind' or `proc'. */
650
651 s48_setref(current_stack_block, stack_block);
652
653 #ifdef DEBUG_FFI
654 if(s48_stack_ref(nargs + 1) != S48_UNSPECIFIC)
655 fprintf(stderr, "[stack_block set missed]\n");
656 #endif
657
658 s48_stack_setB(nargs + 1, stack_block);
659
660 #ifdef DEBUG_FFI
661 fprintf(stderr, "[s48_call_scheme, %ld args, depth %d, off we go]\n",
662 nargs, callback_depth());
663 #endif
664
665 value = s48_restart(S48_UNSAFE_SHARED_BINDING_REF(s48_deref(callback_binding)),
666 nargs + 2);
667
668 for (;s48_Scallback_return_stack_blockS != s48_deref(current_stack_block);) {
669 if (s48_Scallback_return_stack_blockS == S48_FALSE) {
670
671 #ifdef DEBUG_FFI
672 fprintf(stderr, "[s48_call_scheme returning from VM %ld]\n", callback_depth());
673 #endif
674
675 exit(value);
676 }
677 else {
678
679 /* Someone has returned (because of threads) to the wrong section of the
680 C stack. We call back to a Scheme procedure that will suspend until
681 our block is at the top of the stack. */
682
683 s48_push(s48_Scallback_return_stack_blockS);
684 s48_push(S48_UNSAFE_SHARED_BINDING_REF(s48_deref(delay_callback_return_binding)));
685 s48_push(s48_Scallback_return_stack_blockS);
686 s48_push(value);
687
688 #ifdef DEBUG_FFI
689 fprintf(stderr, "[Premature return, %ld args, depth %d, back we go]\n",
690 nargs, callback_depth());
691 #endif
692
693 s48_disable_interruptsB();
694 value = s48_restart(S48_UNSAFE_SHARED_BINDING_REF(s48_deref(callback_binding)), 4);
695 }
696 }
697
698 /* Restore the state of the current stack block. */
699
700 unwind = STACK_BLOCK_UNWIND(s48_deref(current_stack_block));
701 current_return_point = S48_EXTRACT_VALUE(unwind, struct s_jmp_buf);
702 s48_setref(current_procedure, STACK_BLOCK_PROC(s48_deref(current_stack_block)));
703 s48_setref(current_stack_block, STACK_BLOCK_NEXT(s48_deref(current_stack_block)));
704
705 #ifdef DEBUG_FFI
706 fprintf(stderr, "[s48_call_scheme returns from depth %d]\n", callback_depth());
707 #endif
708
709 return value;
710 }
711
712 s48_ref_t
s48_call_scheme_2(s48_call_t call,s48_ref_t proc,long nargs,...)713 s48_call_scheme_2(s48_call_t call, s48_ref_t proc, long nargs, ...)
714 {
715 int i;
716 va_list arguments;
717 s48_value value;
718 s48_ref_t unwind;
719 s48_value stack_block;
720
721 va_start(arguments, nargs);
722
723 #ifdef DEBUG_FFI
724 fprintf(stderr, "[s48_call_scheme_2, %ld args, depth %d]\n",
725 nargs, callback_depth());
726 #endif
727
728 s48_copy_local_bvs_to_scheme (call);
729
730 s48_shared_binding_check_2(call, callback_binding);
731
732 /* It would be nice to push a list of the arguments, but we have no way
733 of preserving them across a cons. */
734 if (nargs < 0 || 12 < nargs) { /* DO NOT INCREASE THIS NUMBER */
735 s48_value sch_nargs = s48_enter_integer(nargs); /* `proc' is protected */
736 s48_raise_scheme_exception(S48_EXCEPTION_TOO_MANY_ARGUMENTS_IN_CALLBACK,
737 2, s48_deref(proc), sch_nargs);
738 }
739
740 #ifdef DEBUG_FFI
741 fprintf(stderr, "[s48_call_scheme_2, %ld args, depth %d]\n",
742 nargs, callback_depth());
743 #endif
744
745 s48_push(S48_UNSPECIFIC); /* placeholder */
746 s48_push(s48_deref(proc));
747 for (i = 0; i < nargs; i++) {
748 s48_ref_t ref = va_arg(arguments, s48_ref_t);
749 #ifdef DEBUG_FFI
750 fprintf(stderr, "call_scheme_2: pushing arg %d ref %x\n", i, ref);
751 #endif
752 s48_push(s48_deref(ref));
753 }
754
755 va_end(arguments);
756
757 /* With everything safely on the stack we can do the necessary allocation. */
758
759 unwind = s48_make_value_2(call, struct s_jmp_buf);
760 s48_extract_value_2(call, unwind, struct s_jmp_buf) = current_return_point;
761
762 stack_block = s48_make_record(s48_deref(stack_block_type_binding));
763 STACK_BLOCK_UNWIND(stack_block) = s48_deref(unwind);
764 STACK_BLOCK_PROC(stack_block) = s48_deref(current_procedure);
765 STACK_BLOCK_NEXT(stack_block) = s48_deref(current_stack_block);
766 STACK_BLOCK_FREE(stack_block) = S48_FALSE;
767 STACK_BLOCK_THREAD(stack_block) = S48_FALSE;
768
769 s48_setref(current_stack_block, stack_block);
770
771 #ifdef DEBUG_FFI
772 if(s48_stack_ref(nargs + 1) != S48_UNSPECIFIC)
773 fprintf(stderr, "[stack_block set missed]\n");
774 #endif
775
776 s48_stack_setB(nargs + 1, stack_block);
777
778 #ifdef DEBUG_FFI
779 fprintf(stderr, "[s48_call_scheme_2, %ld args, depth %d, off we go]\n",
780 nargs, callback_depth());
781 #endif
782
783 value = s48_restart(s48_deref(s48_unsafe_shared_binding_ref_2(call, callback_binding)),
784 nargs + 2);
785
786 for (;s48_Scallback_return_stack_blockS != s48_deref(current_stack_block);) {
787 if (s48_Scallback_return_stack_blockS == S48_FALSE) {
788
789 #ifdef DEBUG_FFI
790 fprintf(stderr, "[s48_call_scheme_2 returning from VM %ld]\n", callback_depth());
791 #endif
792
793 exit(value);
794 }
795 else {
796
797 /* Someone has returned (because of threads) to the wrong section of the
798 C stack. We call back to a Scheme procedure that will suspend until
799 our block is at the top of the stack. */
800
801 s48_push(s48_Scallback_return_stack_blockS);
802 s48_push_2(call, s48_unsafe_shared_binding_ref_2(call, delay_callback_return_binding));
803 s48_push(s48_Scallback_return_stack_blockS);
804 s48_push(value);
805
806 #ifdef DEBUG_FFI
807 fprintf(stderr, "[Premature return, %ld args, depth %d, back we go]\n",
808 nargs, callback_depth());
809 #endif
810
811 s48_disable_interruptsB();
812 value = s48_restart(s48_deref(s48_unsafe_shared_binding_ref_2(call, callback_binding)), 4);
813 }
814 }
815
816 /* Restore the state of the current stack block. */
817
818 unwind = STACK_BLOCK_UNWIND_2(call, current_stack_block);
819 current_return_point = s48_extract_value_2(call, unwind, struct s_jmp_buf);
820 s48_setref(current_procedure, s48_deref(STACK_BLOCK_PROC_2(call, current_stack_block)));
821 s48_setref(current_stack_block, s48_deref(STACK_BLOCK_NEXT_2(call, current_stack_block)));
822
823 #ifdef DEBUG_FFI
824 fprintf(stderr, "[s48_call_scheme_2 returns from depth %d]\n", callback_depth());
825 #endif
826
827 s48_copy_local_bvs_from_scheme (call);
828
829 return s48_make_local_ref (call, value);
830 }
831
832 /*
833 * Because the top of the stack is cleared on the return from every external
834 * call, this doesn't have to do anything but exist.
835 */
836 static s48_value
s48_clear_stack_top()837 s48_clear_stack_top()
838 {
839 #ifdef DEBUG_FFI
840 fprintf(stderr, "[Clearing stack top]\n");
841 #endif
842 return S48_UNSPECIFIC;
843 }
844
845 #ifdef DEBUG_FFI
846 /*
847 * For testing callbacks. This just calls its argument on the specified number
848 * of values.
849 */
850 static s48_value
s48_trampoline(s48_value proc,s48_value nargs)851 s48_trampoline(s48_value proc, s48_value nargs)
852 {
853
854 fprintf(stderr, "[C trampoline, %ld args]\n", S48_UNSAFE_EXTRACT_FIXNUM(nargs));
855
856 switch (s48_extract_fixnum(nargs)) {
857 case -2: { /* provoke exception: GC protection mismatch */
858 S48_DECLARE_GC_PROTECT(1);
859
860 S48_GC_PROTECT_1(proc);
861
862 return S48_FALSE;
863 }
864 case -1: { /* this is broken, dunno what this should do, anyway --Marcus */
865 long n = - s48_extract_integer(proc);
866 fprintf(stderr, "[extract magnitude is %ld (%lx)]\n", n, n);
867 return s48_enter_integer(n);
868 }
869 case 0: {
870 s48_value value = s48_call_scheme(proc, 0);
871 if (value == S48_FALSE)
872 s48_assertion_violation("s48_trampoline", "trampoline bouncing", 0);
873 return value;
874 }
875 case 1:
876 return s48_call_scheme(proc, 1, s48_enter_fixnum(100));
877 case 2:
878 return s48_call_scheme(proc, 2, s48_enter_fixnum(100), s48_enter_fixnum(200));
879 case 3:
880 return s48_call_scheme(proc, 3, s48_enter_fixnum(100), s48_enter_fixnum(200),
881 s48_enter_fixnum(300));
882 default:
883 s48_assertion_violation("s48_trampoline", "invalid number of arguments", 1, nargs);
884 return S48_UNDEFINED; /* not that we ever get here */
885 }
886 }
887 #endif
888
889 static s48_ref_t
s48_trampoline_2(s48_call_t call,s48_ref_t proc,s48_ref_t nargs)890 s48_trampoline_2(s48_call_t call, s48_ref_t proc, s48_ref_t nargs)
891 {
892 #ifdef DEBUG_FFI
893 fprintf(stderr, "[C trampoline_2, %ld args]\n", s48_unsafe_extract_long_2(call, nargs));
894 #endif
895 switch (s48_extract_long_2(call, nargs)) {
896 case -2: { /* provoke exception: GC protection mismatch */
897 S48_DECLARE_GC_PROTECT(1);
898
899 S48_GC_PROTECT_1(proc);
900
901 return s48_false_2(call);
902 }
903 case 0: {
904 s48_ref_t result = s48_call_scheme_2(call, proc, 0);
905 if (s48_false_p_2(call, result))
906 s48_assertion_violation_2(call, "s48_trampoline_2", "trampoline bouncing", 0);
907 return result;
908 }
909 case 1:
910 return s48_call_scheme_2(call, proc, 1,
911 s48_make_local_ref (call, s48_enter_fixnum(100)));
912 case 2:
913 return s48_call_scheme_2(call, proc, 2,
914 s48_make_local_ref (call, s48_enter_fixnum(100)),
915 s48_make_local_ref (call, s48_enter_fixnum(200)));
916 case 3:
917 return s48_call_scheme_2(call, proc, 3,
918 s48_make_local_ref (call, s48_enter_fixnum(100)),
919 s48_make_local_ref (call, s48_enter_fixnum(200)),
920 s48_make_local_ref (call, s48_enter_fixnum(300)));
921 default:
922 s48_assertion_violation_2(call, "s48_trampoline_2", "invalid number of arguments", 1, nargs);
923 return s48_undefined_2(call); /* not that we ever get here */
924 }
925 }
926
927 static s48_ref_t
s48_system_2(s48_call_t call,s48_ref_t string)928 s48_system_2(s48_call_t call, s48_ref_t string)
929 {
930 return s48_enter_long_2(call,
931 system(s48_false_p_2(call, string)
932 ? NULL
933 : s48_extract_byte_vector_readonly_2(call, string)));
934 }
935
936 /********************************/
937 /*
938 * Raising exceptions. We push the arguments on the stack end then throw out
939 * of the most recent call from Scheme.
940 *
941 * The maximum number of arguments is determined by the amount of space reserved
942 * on the Scheme stack for exceptions. See the definition of stack-slack in
943 * scheme/vm/interp/stack.scm.
944 */
945
946 static long
raise_scheme_exception_prelude(long why,long nargs)947 raise_scheme_exception_prelude(long why, long nargs)
948 {
949 s48_setup_external_exception(why, nargs);
950
951 if (11 < nargs) { /* DO NOT INCREASE THIS NUMBER */
952 fprintf(stderr, "too many arguments to external exception, discarding surplus\n");
953 nargs = 11;
954 }
955 return nargs;
956 }
957
958 static long
raise_scheme_exception_prelude_2(s48_call_t call,long why,long nargs)959 raise_scheme_exception_prelude_2(s48_call_t call, long why, long nargs)
960 {
961 s48_copy_local_bvs_to_scheme(call);
962 return raise_scheme_exception_prelude(why, nargs);
963 }
964
965 static void
raise_scheme_exception_postlude(void)966 raise_scheme_exception_postlude(void)
967 {
968 external_return_value = S48_UNSPECIFIC;
969 longjmp(current_return_point.buf, EXCEPTION_THROW);
970 }
971
972 void
s48_raise_scheme_exception(long why,long nargs,...)973 s48_raise_scheme_exception(long why, long nargs, ...)
974 {
975 int i;
976 va_list irritants;
977
978 nargs = raise_scheme_exception_prelude(why, nargs + 1) - 1;
979
980 s48_push(s48_deref(current_procedure));
981
982 va_start(irritants, nargs);
983
984 for (i = 0; i < nargs; i++)
985 s48_push(va_arg(irritants, s48_value));
986
987 va_end(irritants);
988
989 raise_scheme_exception_postlude();
990 }
991
992 void
s48_raise_scheme_exception_2(s48_call_t call,long why,long nargs,...)993 s48_raise_scheme_exception_2(s48_call_t call, long why, long nargs, ...)
994 {
995 int i;
996 va_list irritants;
997
998 nargs = raise_scheme_exception_prelude_2(call, why, nargs + 1) - 1;
999
1000 s48_push_2(call, current_procedure);
1001
1002 va_start(irritants, nargs);
1003
1004 for (i = 0; i < nargs; i++)
1005 s48_push_2(call, va_arg(irritants, s48_ref_t));
1006
1007 va_end(irritants);
1008
1009 raise_scheme_exception_postlude();
1010 }
1011
1012 static void
raise_scheme_standard_exception(long why,const char * who,const char * message,long irritant_count,va_list irritants)1013 raise_scheme_standard_exception(long why, const char* who, const char* message,
1014 long irritant_count, va_list irritants)
1015 {
1016 int i;
1017 long nargs = irritant_count + 2; /* who and message */
1018
1019 nargs = raise_scheme_exception_prelude(why, nargs);
1020 irritant_count = nargs - 2;
1021
1022 for (i = 0; i < irritant_count; i++)
1023 s48_push(va_arg(irritants, s48_value));
1024
1025 va_end(irritants);
1026
1027 /* these must be last because of GC protection */
1028 if (who == NULL)
1029 s48_push(s48_deref(current_procedure));
1030 else
1031 s48_push(s48_enter_string_utf_8((char*)who));
1032 s48_push(s48_enter_byte_string((char*)message));
1033
1034 raise_scheme_exception_postlude();
1035 }
1036
1037 static void
raise_scheme_standard_exception_2(s48_call_t call,long why,const char * who,const char * message,long irritant_count,va_list irritants)1038 raise_scheme_standard_exception_2(s48_call_t call, long why, const char* who, const char* message,
1039 long irritant_count, va_list irritants)
1040 {
1041 int i;
1042 long nargs = irritant_count + 2; /* who and message */
1043
1044 nargs = raise_scheme_exception_prelude_2(call, why, nargs);
1045 irritant_count = nargs - 2;
1046
1047 for (i = 0; i < irritant_count; i++)
1048 s48_push_2(call, va_arg(irritants, s48_ref_t));
1049
1050 va_end(irritants);
1051
1052 /* these must be last because of GC protection */
1053 if (who == NULL)
1054 s48_push_2(call, current_procedure);
1055 else
1056 s48_push_2(call, s48_enter_string_utf_8_2(call, (char*) who));
1057 s48_push_2(call, s48_enter_byte_string_2(call, (char*) message));
1058
1059 raise_scheme_exception_postlude();
1060 }
1061
1062 /* Specific exceptions */
1063
1064 void
s48_error(const char * who,const char * message,long irritant_count,...)1065 s48_error(const char* who, const char* message,
1066 long irritant_count, ...)
1067 {
1068 va_list irritants;
1069 va_start(irritants, irritant_count);
1070 raise_scheme_standard_exception(S48_EXCEPTION_EXTERNAL_ERROR,
1071 who, message, irritant_count, irritants);
1072 }
1073
1074 void
s48_error_2(s48_call_t call,const char * who,const char * message,long irritant_count,...)1075 s48_error_2(s48_call_t call, const char* who, const char* message,
1076 long irritant_count, ...)
1077 {
1078 va_list irritants;
1079 va_start(irritants, irritant_count);
1080 raise_scheme_standard_exception_2(call, S48_EXCEPTION_EXTERNAL_ERROR,
1081 who, message, irritant_count, irritants);
1082 }
1083
1084 void
s48_assertion_violation(const char * who,const char * message,long irritant_count,...)1085 s48_assertion_violation(const char* who, const char* message,
1086 long irritant_count, ...)
1087 {
1088 va_list irritants;
1089 va_start(irritants, irritant_count);
1090 raise_scheme_standard_exception(S48_EXCEPTION_EXTERNAL_ASSERTION_VIOLATION,
1091 who, message, irritant_count, irritants);
1092 }
1093
1094 void
s48_assertion_violation_2(s48_call_t call,const char * who,const char * message,long irritant_count,...)1095 s48_assertion_violation_2(s48_call_t call, const char* who, const char* message,
1096 long irritant_count, ...)
1097 {
1098 va_list irritants;
1099 va_start(irritants, irritant_count);
1100 raise_scheme_standard_exception_2(call, S48_EXCEPTION_EXTERNAL_ASSERTION_VIOLATION,
1101 who, message, irritant_count, irritants);
1102 }
1103
1104 void
s48_os_error(const char * who,int the_errno,long irritant_count,...)1105 s48_os_error(const char* who, int the_errno,
1106 long irritant_count, ...)
1107 {
1108 int i;
1109 long nargs = irritant_count + 2; /* who and errno */
1110 va_list irritants;
1111
1112 nargs = raise_scheme_exception_prelude(S48_EXCEPTION_EXTERNAL_OS_ERROR, nargs);
1113 irritant_count = nargs - 2;
1114
1115 va_start(irritants, irritant_count);
1116
1117 for (i = 0; i < irritant_count; i++)
1118 s48_push(va_arg(irritants, s48_value));
1119
1120 va_end(irritants);
1121
1122 /* last because of GC protection */
1123 if (who == NULL)
1124 s48_push(s48_deref(current_procedure));
1125 else
1126 s48_push(s48_enter_string_utf_8((char*)who));
1127 s48_push(s48_enter_fixnum(the_errno));
1128
1129 raise_scheme_exception_postlude();
1130 }
1131
1132 void
s48_os_error_2(s48_call_t call,const char * who,int the_errno,long irritant_count,...)1133 s48_os_error_2(s48_call_t call, const char* who, int the_errno,
1134 long irritant_count, ...)
1135 {
1136 int i;
1137 long nargs = irritant_count + 2; /* who and errno */
1138 va_list irritants;
1139
1140 nargs = raise_scheme_exception_prelude_2(call, S48_EXCEPTION_EXTERNAL_OS_ERROR, nargs);
1141 irritant_count = nargs - 2;
1142
1143 va_start(irritants, irritant_count);
1144
1145 for (i = 0; i < irritant_count; i++)
1146 s48_push_2(call, va_arg(irritants, s48_ref_t));
1147
1148 va_end(irritants);
1149
1150 /* last because of GC protection */
1151 if (who == NULL)
1152 s48_push_2(call, current_procedure);
1153 else
1154 s48_push_2(call, s48_enter_string_utf_8_2(call, who));
1155 s48_push_2(call, s48_enter_long_as_fixnum_2(call, the_errno));
1156
1157 raise_scheme_exception_postlude();
1158 }
1159
1160 void
s48_out_of_memory_error()1161 s48_out_of_memory_error()
1162 {
1163 s48_raise_scheme_exception(S48_EXCEPTION_OUT_OF_MEMORY, 0);
1164 }
1165
1166 void
s48_out_of_memory_error_2(s48_call_t call)1167 s48_out_of_memory_error_2(s48_call_t call)
1168 {
1169 s48_raise_scheme_exception_2(call, S48_EXCEPTION_OUT_OF_MEMORY, 0);
1170 }
1171
1172 /* For internal use by the VM: */
1173
1174 void
s48_argument_type_violation(s48_value value)1175 s48_argument_type_violation(s48_value value) {
1176 s48_assertion_violation(NULL, "argument-type violation", 1, value);
1177 }
1178
1179 void
s48_argument_type_violation_2(s48_call_t call,s48_ref_t value)1180 s48_argument_type_violation_2(s48_call_t call, s48_ref_t value) {
1181 s48_assertion_violation_2(call, NULL, "argument-type violation", 1, value);
1182 }
1183
1184 void
s48_range_violation(s48_value value,s48_value min,s48_value max)1185 s48_range_violation(s48_value value, s48_value min, s48_value max) {
1186 s48_assertion_violation(NULL, "argument out of range", 3, value, min, max);
1187 }
1188
1189 void
s48_range_violation_2(s48_call_t call,s48_ref_t value,s48_ref_t min,s48_ref_t max)1190 s48_range_violation_2(s48_call_t call, s48_ref_t value, s48_ref_t min, s48_ref_t max) {
1191 s48_assertion_violation_2(call, NULL, "argument out of range", 3, value, min, max);
1192 }
1193
1194 /* The following are deprecated: */
1195
1196 void
s48_raise_argument_type_error(s48_value value)1197 s48_raise_argument_type_error(s48_value value) {
1198 s48_raise_scheme_exception(S48_EXCEPTION_WRONG_TYPE_ARGUMENT, 1, value);
1199 }
1200
1201 void
s48_raise_argument_number_error(s48_value value,s48_value min,s48_value max)1202 s48_raise_argument_number_error(s48_value value, s48_value min, s48_value max) {
1203 s48_raise_scheme_exception(S48_EXCEPTION_WRONG_NUMBER_OF_ARGUMENTS,
1204 3, value, min, max);
1205 }
1206
1207 void
s48_raise_range_error(s48_value value,s48_value min,s48_value max)1208 s48_raise_range_error(s48_value value, s48_value min, s48_value max) {
1209 s48_raise_scheme_exception(S48_EXCEPTION_INDEX_OUT_OF_RANGE,
1210 3, value, min, max);
1211 }
1212
1213 void
s48_raise_closed_channel_error()1214 s48_raise_closed_channel_error() {
1215 s48_raise_scheme_exception(S48_EXCEPTION_CLOSED_CHANNEL, 0);
1216 }
1217
1218 void
s48_raise_os_error(int the_errno)1219 s48_raise_os_error(int the_errno) {
1220 s48_os_error(NULL, the_errno, 0);
1221 }
1222
1223 void
s48_raise_string_os_error(char * reason)1224 s48_raise_string_os_error(char *reason) {
1225 s48_error(NULL, (const char*)s48_enter_string_latin_1(reason), 0);
1226 }
1227
1228 void
s48_raise_out_of_memory_error()1229 s48_raise_out_of_memory_error() {
1230 s48_raise_scheme_exception(S48_EXCEPTION_OUT_OF_MEMORY, 0);
1231 }
1232
1233
1234 /********************************/
1235 /* Support routines for external code */
1236
1237 /*
1238 * Type-safe procedures for checking types and dereferencing and setting slots.
1239 */
1240
1241 int
s48_stob_has_type(s48_value thing,int type)1242 s48_stob_has_type(s48_value thing, int type)
1243 {
1244 return S48_STOB_P(thing) && (S48_STOB_TYPE(thing) == type);
1245 }
1246
1247 int
s48_stob_has_type_2(s48_call_t call,s48_ref_t thing,int type)1248 s48_stob_has_type_2(s48_call_t call, s48_ref_t thing, int type)
1249 {
1250 return s48_stob_p_2(call, thing) && (s48_stob_type_2(call, thing) == type);
1251 }
1252
1253 long
s48_stob_length(s48_value thing,int type)1254 s48_stob_length(s48_value thing, int type)
1255 {
1256 if (!(S48_STOB_P(thing) && (S48_STOB_TYPE(thing) == type)))
1257 s48_assertion_violation("s48_stob_length", "not a stob", 1, thing);
1258
1259 return S48_STOB_DESCRIPTOR_LENGTH(thing);
1260 }
1261
1262 long
s48_stob_length_2(s48_call_t call,s48_ref_t thing,int type)1263 s48_stob_length_2(s48_call_t call, s48_ref_t thing, int type)
1264 {
1265 if (!(s48_stob_p_2(call, thing) && (s48_stob_type_2(call, thing) == type)))
1266 s48_assertion_violation_2(call, "s48_stob_length_2", "not a stob", 1, thing);
1267
1268 return s48_unsafe_stob_descriptor_length_2(call, thing);
1269 }
1270
1271 long
s48_stob_byte_length(s48_value thing,int type)1272 s48_stob_byte_length(s48_value thing, int type)
1273 {
1274 if (!(S48_STOB_P(thing) && (S48_STOB_TYPE(thing) == type)))
1275 s48_assertion_violation("s48_stob_byte_length", "not a stob", 1, thing);
1276
1277 if (type == S48_STOBTYPE_STRING)
1278 return S48_STOB_BYTE_LENGTH(thing) - 1;
1279 else
1280 return S48_STOB_BYTE_LENGTH(thing);
1281 }
1282
1283 long
s48_stob_byte_length_2(s48_call_t call,s48_ref_t thing,int type)1284 s48_stob_byte_length_2(s48_call_t call, s48_ref_t thing, int type)
1285 {
1286 if (!(s48_stob_p_2(call, thing) && (s48_stob_type_2(call, thing) == type)))
1287 s48_assertion_violation_2(call, "s48_stob_byte_length_2", "not a stob", 1, thing);
1288
1289 if (type == S48_STOBTYPE_STRING)
1290 return s48_unsafe_stob_byte_length_2(call, thing) - 1;
1291 else
1292 return s48_unsafe_stob_byte_length_2(call, thing);
1293 }
1294
1295
1296 s48_value
s48_stob_ref(s48_value thing,int type,long offset)1297 s48_stob_ref(s48_value thing, int type, long offset)
1298 {
1299 long length;
1300
1301 if (!(S48_STOB_P(thing) && (S48_STOB_TYPE(thing) == type)))
1302 s48_assertion_violation("s48_stob_ref", "not a stob", 1, thing);
1303
1304 length = S48_STOB_DESCRIPTOR_LENGTH(thing);
1305
1306 if (offset < 0 || length <= offset)
1307 s48_assertion_violation("s48_stob_ref", "invalid stob index", 3,
1308 s48_enter_integer(offset),
1309 S48_UNSAFE_ENTER_FIXNUM(0),
1310 S48_UNSAFE_ENTER_FIXNUM(length - 1));
1311
1312 return S48_STOB_REF(thing, offset);
1313 }
1314
1315 s48_ref_t
s48_stob_ref_2(s48_call_t call,s48_ref_t thing,int type,long offset)1316 s48_stob_ref_2(s48_call_t call, s48_ref_t thing, int type, long offset)
1317 {
1318 long length;
1319
1320 if (!(s48_stob_p_2(call, thing) && (s48_stob_type_2(call, thing) == type)))
1321 s48_assertion_violation_2(call, "s48_stob_ref_2", "not a stob", 1, thing);
1322
1323 length = s48_unsafe_stob_descriptor_length_2(call, thing);
1324
1325 if (offset < 0 || length <= offset)
1326 s48_assertion_violation_2(call, "s48_stob_ref_2", "invalid stob index", 3,
1327 s48_enter_long_2(call, offset),
1328 s48_unsafe_enter_long_as_fixnum_2(call, 0),
1329 s48_unsafe_enter_long_as_fixnum_2(call, length - 1));
1330
1331 return s48_unsafe_stob_ref_2(call, thing, offset);
1332 }
1333
1334 void
s48_stob_set(s48_value thing,int type,long offset,s48_value value)1335 s48_stob_set(s48_value thing, int type, long offset, s48_value value)
1336 {
1337 long length;
1338
1339 if (!(S48_STOB_P(thing) &&
1340 (S48_STOB_TYPE(thing) == type) &&
1341 !S48_STOB_IMMUTABLEP(thing)))
1342 s48_assertion_violation("s48_stob_set", "not a mutable stob", 1, thing);
1343
1344 length = S48_STOB_DESCRIPTOR_LENGTH(thing);
1345
1346 if (offset < 0 || length <= offset)
1347 s48_assertion_violation("s48_stob_set", "invalid stob index", 3,
1348 s48_enter_integer(offset),
1349 S48_UNSAFE_ENTER_FIXNUM(0),
1350 S48_UNSAFE_ENTER_FIXNUM(length - 1));
1351
1352 S48_STOB_SET(thing, offset, value);
1353 }
1354
1355 void
s48_stob_set_2(s48_call_t call,s48_ref_t thing,int type,long offset,s48_ref_t value)1356 s48_stob_set_2(s48_call_t call, s48_ref_t thing, int type, long offset, s48_ref_t value)
1357 {
1358 long length;
1359
1360 if (!(s48_stob_p_2(call, thing) &&
1361 (s48_stob_type_2(call, thing) == type) &&
1362 !s48_stob_immutablep_2(call, thing)))
1363 s48_assertion_violation_2(call, "s48_stob_set_2",
1364 "not a mutable stob", 1, thing);
1365
1366 length = s48_unsafe_stob_descriptor_length_2(call, thing);
1367
1368 if (offset < 0 || length <= offset)
1369 s48_assertion_violation_2(call, "s48_stob_set_2", "invalid stob index", 3,
1370 s48_enter_integer(offset),
1371 s48_unsafe_enter_long_as_fixnum_2(call, 0),
1372 s48_unsafe_enter_long_as_fixnum_2(call, length - 1));
1373
1374 s48_unsafe_stob_set_2(call, thing, offset, value);
1375 }
1376
1377 char
s48_stob_byte_ref(s48_value thing,int type,long offset)1378 s48_stob_byte_ref(s48_value thing, int type, long offset)
1379 {
1380 long length;
1381
1382 if (!(S48_STOB_P(thing) && (S48_STOB_TYPE(thing) == type)))
1383 s48_assertion_violation("s48_stob_byte_ref", "not a stob", 1, thing);
1384
1385 length = (type == S48_STOBTYPE_STRING) ?
1386 S48_STOB_BYTE_LENGTH(thing) - 1 :
1387 S48_STOB_BYTE_LENGTH(thing);
1388
1389 if (offset < 0 || length <= offset)
1390 s48_assertion_violation("s48_stob_byte_ref", "invalid stob index", 3,
1391 s48_enter_integer(offset),
1392 S48_UNSAFE_ENTER_FIXNUM(0),
1393 S48_UNSAFE_ENTER_FIXNUM(length - 1));
1394
1395 return S48_STOB_BYTE_REF(thing, offset);
1396 }
1397
1398 char
s48_stob_byte_ref_2(s48_call_t call,s48_ref_t thing,int type,long offset)1399 s48_stob_byte_ref_2(s48_call_t call, s48_ref_t thing, int type, long offset)
1400 {
1401 long length;
1402
1403 if (!(s48_stob_p_2(call, thing) && (s48_stob_type_2(call, thing) == type)))
1404 s48_assertion_violation_2(call, "s48_stob_byte_ref_2", "not a stob", 1, thing);
1405
1406 length = (type == s48_stobtype_string) ?
1407 s48_unsafe_stob_byte_length_2(call, thing) - 1 :
1408 s48_unsafe_stob_byte_length_2(call, thing);
1409
1410 if (offset < 0 || length <= offset)
1411 s48_assertion_violation_2(call, "s48_stob_byte_ref_2", "invalid stob index", 3,
1412 s48_enter_integer(offset),
1413 s48_unsafe_enter_long_as_fixnum_2(call, 0),
1414 s48_unsafe_enter_long_as_fixnum_2(call, length - 1));
1415
1416 return s48_unsafe_stob_byte_ref_2(call, thing, offset);
1417 }
1418
1419 void
s48_stob_byte_set(s48_value thing,int type,long offset,char value)1420 s48_stob_byte_set(s48_value thing, int type, long offset, char value)
1421 {
1422 long length;
1423
1424 if (!(S48_STOB_P(thing) && (S48_STOB_TYPE(thing) == type)))
1425 s48_assertion_violation("s48_stob_byte_set", "not a stob", 1, thing);
1426
1427 length = (type == S48_STOBTYPE_STRING) ?
1428 S48_STOB_BYTE_LENGTH(thing) - 1 :
1429 S48_STOB_BYTE_LENGTH(thing);
1430
1431 if (offset < 0 || length <= offset)
1432 s48_assertion_violation("s48_stob_byte_set", "invalid stob index", 3,
1433 s48_enter_integer(offset),
1434 S48_UNSAFE_ENTER_FIXNUM(0),
1435 S48_UNSAFE_ENTER_FIXNUM(length - 1));
1436
1437 S48_STOB_BYTE_SET(thing, offset, value);
1438 }
1439
1440 void
s48_stob_byte_set_2(s48_call_t call,s48_ref_t thing,int type,long offset,char value)1441 s48_stob_byte_set_2(s48_call_t call, s48_ref_t thing, int type, long offset, char value)
1442 {
1443 long length;
1444
1445 if (!(s48_stob_p_2(call, thing) && (s48_stob_type_2(call, thing) == type)))
1446 s48_assertion_violation_2(call, "s48_stob_byte_set_2", "not a stob", 1, thing);
1447
1448 length = (type == S48_STOBTYPE_STRING) ?
1449 s48_unsafe_stob_byte_length_2(call, thing) - 1 :
1450 s48_unsafe_stob_byte_length_2(call, thing);
1451
1452 if (offset < 0 || length <= offset)
1453 s48_assertion_violation_2(call, "s48_stob_byte_set_2", "invalid stob index", 3,
1454 s48_enter_integer(offset),
1455 s48_unsafe_enter_long_as_fixnum_2(call, 0),
1456 s48_unsafe_enter_long_as_fixnum_2(call, length - 1));
1457
1458 s48_unsafe_stob_byte_set_2(call, thing, offset, value);
1459 }
1460
1461 void *
s48_value_pointer(s48_value value)1462 s48_value_pointer(s48_value value)
1463 {
1464 S48_CHECK_VALUE(value);
1465
1466 return S48_ADDRESS_AFTER_HEADER(value, void *);
1467 }
1468
1469 void *
s48_value_pointer_2(s48_call_t call,s48_ref_t value)1470 s48_value_pointer_2(s48_call_t call, s48_ref_t value)
1471 {
1472 s48_check_value_2(call, value);
1473
1474 return s48_address_after_header_2(call, value, void *);
1475 }
1476
1477 /********************************/
1478 /* Numbers, characters, and pointers. */
1479
1480 /*
1481 * These two functions have the same range as the unsafe macros, but they signal
1482 * an error if things go wrong, instead of silently producing garbage. Unlike
1483 * the integer versions they cannot cause a GC.
1484 */
1485
1486 s48_value
s48_enter_fixnum(long value)1487 s48_enter_fixnum(long value)
1488 {
1489 if (value < S48_MIN_FIXNUM_VALUE || S48_MAX_FIXNUM_VALUE < value)
1490 s48_assertion_violation("s48_enter_fixnum", "not a fixnum", 1, s48_enter_integer(value));
1491
1492 return S48_UNSAFE_ENTER_FIXNUM(value);
1493 }
1494
1495 s48_ref_t
s48_enter_long_as_fixnum_2(s48_call_t call,long value)1496 s48_enter_long_as_fixnum_2(s48_call_t call, long value)
1497 {
1498 if (value < S48_MIN_FIXNUM_VALUE || S48_MAX_FIXNUM_VALUE < value)
1499 s48_assertion_violation_2(call, "s48_enter_long_as_fixnum_2", "not a fixnum",
1500 1, s48_enter_long_2(call, value));
1501
1502 return s48_unsafe_enter_long_as_fixnum_2(call, value);
1503 }
1504
1505 long
s48_extract_fixnum(s48_value value)1506 s48_extract_fixnum(s48_value value)
1507 {
1508 if (! S48_FIXNUM_P(value))
1509 s48_assertion_violation("s48_extract_fixnum", "not a fixnum", 1, value);
1510
1511 return S48_UNSAFE_EXTRACT_FIXNUM(value);
1512 }
1513
1514 /* If we have a fixnum we just extract it. For bignums call the
1515 * functions in bignum.c.
1516 */
1517
1518 s48_ref_t
s48_enter_long_2(s48_call_t call,long value)1519 s48_enter_long_2(s48_call_t call, long value)
1520 {
1521 return s48_make_local_ref(call, s48_enter_integer(value));
1522 }
1523
1524 long
s48_extract_integer(s48_value value)1525 s48_extract_integer(s48_value value)
1526 {
1527 if (S48_FIXNUM_P(value))
1528 return S48_UNSAFE_EXTRACT_FIXNUM(value);
1529
1530 if (S48_BIGNUM_P(value)){
1531 bignum_type bignum = S48_ADDRESS_AFTER_HEADER(value, long);
1532
1533 if (! s48_bignum_fits_in_word_p(bignum, 32, 1))
1534 s48_assertion_violation("s48_extract_integer", "does not fit in word", 1, value);
1535 else return s48_bignum_to_long(bignum);
1536 }
1537 else s48_assertion_violation("s48_extract_integer", "not an exact integer", 1, value);
1538 }
1539
1540 long
s48_extract_long_2(s48_call_t call,s48_ref_t value)1541 s48_extract_long_2(s48_call_t call, s48_ref_t value)
1542 {
1543 if (s48_fixnum_p_2(call, value))
1544 return s48_unsafe_extract_long_2(call, value);
1545
1546 if (s48_bignum_p_2(call, value)){
1547 bignum_type bignum = s48_address_after_header_2(call, value, long);
1548
1549 if (! s48_bignum_fits_in_word_p(bignum, sizeof(long) * BITS_PER_BYTE, 1))
1550 s48_assertion_violation_2(call, "s48_extract_long_2",
1551 "does not fit in word", 1, value);
1552 else return s48_bignum_to_long(bignum);
1553 }
1554 else s48_assertion_violation_2(call, "s48_extract_long_2",
1555 "not an exact integer", 1, value);
1556 }
1557
1558 s48_ref_t
s48_enter_unsigned_long_2(s48_call_t call,unsigned long value)1559 s48_enter_unsigned_long_2(s48_call_t call, unsigned long value)
1560 {
1561 return s48_make_local_ref(call, s48_enter_unsigned_integer(value));
1562 }
1563
1564 unsigned long
s48_extract_unsigned_integer(s48_value value)1565 s48_extract_unsigned_integer(s48_value value)
1566 {
1567 if (S48_FIXNUM_P(value))
1568 {
1569 long fixnum = S48_UNSAFE_EXTRACT_FIXNUM(value);
1570 if (fixnum < 0)
1571 s48_assertion_violation("s48_extract_unsigned_integer", "negative argument", 1,
1572 value);
1573 return (unsigned long) fixnum;
1574 }
1575
1576 if (S48_BIGNUM_P(value)){
1577 bignum_type bignum = S48_ADDRESS_AFTER_HEADER(value, long);
1578
1579 if (! s48_bignum_fits_in_word_p(bignum, 32, 0))
1580 s48_assertion_violation("s48_extract_unsigned_integer", "does not fit in word", 1,
1581 value);
1582 else return s48_bignum_to_ulong(bignum);
1583 }
1584 else s48_assertion_violation("s48_extract_unsigned_integer", "not an exact integer", 1,
1585 value);
1586 }
1587
1588 unsigned long
s48_extract_unsigned_long_2(s48_call_t call,s48_ref_t value)1589 s48_extract_unsigned_long_2(s48_call_t call, s48_ref_t value)
1590 {
1591 if (s48_fixnum_p_2(call, value))
1592 {
1593 long fixnum = s48_unsafe_extract_long_2(call, value);
1594 if (fixnum < 0)
1595 s48_assertion_violation_2(call, "s48_extract_unsigned_long_2",
1596 "negative argument", 1, value);
1597 return (unsigned long) fixnum;
1598 }
1599
1600 if (s48_bignum_p_2(call, value)){
1601 bignum_type bignum = s48_address_after_header_2(call, value, long);
1602
1603 if (! s48_bignum_fits_in_word_p(bignum, sizeof(long) * BITS_PER_BYTE, 0))
1604 s48_assertion_violation_2(call, "s48_extract_unsigned_long_2",
1605 "does not fit in word", 1, value);
1606 else return s48_bignum_to_ulong(bignum);
1607 }
1608 else s48_assertion_violation_2(call, "s48_extract_unsigned_long_2",
1609 "not an exact integer", 1, value);
1610 }
1611
1612 /*
1613 * Strings from and to encodings
1614 */
1615
1616 /*
1617 * These are just wrappers to ensure the right types.
1618 */
1619
1620 s48_ref_t
s48_enter_string_latin_1_2(s48_call_t call,const char * s)1621 s48_enter_string_latin_1_2(s48_call_t call, const char *s)
1622 {
1623 return s48_make_local_ref(call, s48_enter_string_latin_1((char*) s));
1624 }
1625
1626 s48_ref_t
s48_enter_string_latin_1_n_2(s48_call_t call,const char * s,long count)1627 s48_enter_string_latin_1_n_2(s48_call_t call, const char *s, long count)
1628 {
1629 return s48_make_local_ref(call, s48_enter_string_latin_1_n((char*) s, count));
1630 }
1631
1632 void
s48_copy_string_to_latin_1_2(s48_call_t call,s48_ref_t sch_s,char * s)1633 s48_copy_string_to_latin_1_2(s48_call_t call, s48_ref_t sch_s, char *s)
1634 {
1635 s48_copy_string_to_latin_1(s48_deref(sch_s), s);
1636 }
1637
1638 void
s48_copy_string_to_latin_1_n_2(s48_call_t call,s48_ref_t sch_s,long start,long count,char * s)1639 s48_copy_string_to_latin_1_n_2(s48_call_t call, s48_ref_t sch_s, long start, long count, char *s)
1640 {
1641 s48_copy_string_to_latin_1_n(s48_deref(sch_s), start, count, s);
1642 }
1643
1644 void
s48_copy_latin_1_to_string_2(s48_call_t call,const char * s,s48_ref_t sch_s)1645 s48_copy_latin_1_to_string_2(s48_call_t call, const char *s, s48_ref_t sch_s)
1646 {
1647 s48_copy_latin_1_to_string((char*) s, s48_deref(sch_s));
1648 }
1649
1650 void
s48_copy_latin_1_to_string_n_2(s48_call_t call,const char * s,long len,s48_ref_t sch_s)1651 s48_copy_latin_1_to_string_n_2(s48_call_t call, const char *s, long len, s48_ref_t sch_s)
1652 {
1653 s48_copy_latin_1_to_string_n((char*) s, len, s48_deref(sch_s));
1654 }
1655
1656 s48_ref_t
s48_enter_string_utf_8_2(s48_call_t call,const char * s)1657 s48_enter_string_utf_8_2(s48_call_t call, const char *s)
1658 {
1659 return s48_make_local_ref(call, s48_enter_string_utf_8((char*) s));
1660 }
1661
1662 s48_value
s48_enter_string_utf_16be(const uint16_t * s)1663 s48_enter_string_utf_16be(const uint16_t *s)
1664 {
1665 return s48_enter_string_utf_16beU((char*) s);
1666 }
1667
1668 s48_ref_t
s48_enter_string_utf_16be_2(s48_call_t call,const uint16_t * s)1669 s48_enter_string_utf_16be_2(s48_call_t call, const uint16_t *s)
1670 {
1671 return s48_make_local_ref(call, s48_enter_string_utf_16beU((char*) s));
1672 }
1673
1674 s48_value
s48_enter_string_utf_16be_n(const uint16_t * s,long l)1675 s48_enter_string_utf_16be_n(const uint16_t * s, long l)
1676 {
1677 return s48_enter_string_utf_16be_nU((char*) s, l);
1678 }
1679
1680 s48_ref_t
s48_enter_string_utf_16be_n_2(s48_call_t call,const uint16_t * s,long l)1681 s48_enter_string_utf_16be_n_2(s48_call_t call, const uint16_t * s, long l)
1682 {
1683 return s48_make_local_ref(call, s48_enter_string_utf_16be_nU((char*) s, l));
1684 }
1685
1686 long
s48_copy_string_to_utf_16be(s48_value sch_s,uint16_t * s)1687 s48_copy_string_to_utf_16be(s48_value sch_s, uint16_t * s)
1688 {
1689 return s48_copy_string_to_utf_16beU(sch_s, (char*) s);
1690 }
1691
1692 long
s48_copy_string_to_utf_16be_2(s48_call_t call,s48_ref_t sch_s,uint16_t * s)1693 s48_copy_string_to_utf_16be_2(s48_call_t call, s48_ref_t sch_s, uint16_t * s)
1694 {
1695 return s48_copy_string_to_utf_16beU(s48_deref(sch_s), (char*) s);
1696 }
1697
1698 long
s48_copy_string_to_utf_16be_n(s48_value sch_s,long start,long count,uint16_t * s)1699 s48_copy_string_to_utf_16be_n(s48_value sch_s, long start, long count, uint16_t *s)
1700 {
1701 return s48_copy_string_to_utf_16be_nU(sch_s, start, count, (char*) s);
1702 }
1703
1704 long
s48_copy_string_to_utf_16be_n_2(s48_call_t call,s48_ref_t sch_s,long start,long count,uint16_t * s)1705 s48_copy_string_to_utf_16be_n_2(s48_call_t call, s48_ref_t sch_s, long start, long count, uint16_t *s)
1706 {
1707 return s48_copy_string_to_utf_16be_nU(s48_deref(sch_s), start, count, (char*) s);
1708 }
1709
1710 s48_value
s48_enter_string_utf_16le(const uint16_t * s)1711 s48_enter_string_utf_16le(const uint16_t *s)
1712 {
1713 return s48_enter_string_utf_16leU((char *) s);
1714 }
1715
1716 s48_ref_t
s48_enter_string_utf_16le_2(s48_call_t call,const uint16_t * s)1717 s48_enter_string_utf_16le_2(s48_call_t call, const uint16_t *s)
1718 {
1719 return s48_make_local_ref(call, s48_enter_string_utf_16leU((char *) s));
1720 }
1721
1722
1723 s48_value
s48_enter_string_utf_16le_n(const uint16_t * s,long l)1724 s48_enter_string_utf_16le_n(const uint16_t *s, long l)
1725 {
1726 return s48_enter_string_utf_16le_nU((char *) s,l);
1727 }
1728
1729 s48_ref_t
s48_enter_string_utf_16le_n_2(s48_call_t call,const uint16_t * s,long l)1730 s48_enter_string_utf_16le_n_2(s48_call_t call, const uint16_t *s, long l)
1731 {
1732 return s48_make_local_ref(call, s48_enter_string_utf_16le_nU((char *) s,l));
1733 }
1734
1735 long
s48_copy_string_to_utf_16le(s48_value sch_s,uint16_t * s)1736 s48_copy_string_to_utf_16le(s48_value sch_s, uint16_t *s)
1737 {
1738 return s48_copy_string_to_utf_16leU(sch_s, (char *) s);
1739 }
1740
1741 long
s48_copy_string_to_utf_16le_2(s48_call_t call,s48_ref_t sch_s,uint16_t * s)1742 s48_copy_string_to_utf_16le_2(s48_call_t call, s48_ref_t sch_s, uint16_t *s)
1743 {
1744 return s48_copy_string_to_utf_16leU(s48_deref(sch_s), (char *) s);
1745 }
1746
1747 long
s48_copy_string_to_utf_16le_n(s48_value sch_s,long start,long count,uint16_t * s)1748 s48_copy_string_to_utf_16le_n(s48_value sch_s, long start, long count, uint16_t *s)
1749 {
1750 return s48_copy_string_to_utf_16le_nU(sch_s, start, count, (char *) s);
1751 }
1752
1753 long
s48_copy_string_to_utf_16le_n_2(s48_call_t call,s48_ref_t sch_s,long start,long count,uint16_t * s)1754 s48_copy_string_to_utf_16le_n_2(s48_call_t call, s48_ref_t sch_s, long start, long count, uint16_t *s)
1755 {
1756 return s48_copy_string_to_utf_16le_nU(s48_deref(sch_s), start, count, (char *) s);
1757 }
1758
1759 s48_ref_t
s48_enter_string_utf_8_n_2(s48_call_t call,const char * s,long count)1760 s48_enter_string_utf_8_n_2(s48_call_t call, const char* s, long count)
1761 {
1762 return s48_make_local_ref(call, s48_enter_string_utf_8_n((char*) s, count));
1763 }
1764
1765 long
s48_string_utf_8_length_2(s48_call_t call,s48_ref_t s)1766 s48_string_utf_8_length_2(s48_call_t call, s48_ref_t s)
1767 {
1768 return s48_string_utf_8_length(s48_deref(s));
1769 }
1770
1771 long
s48_string_utf_8_length_n_2(s48_call_t call,s48_ref_t s,long start,long count)1772 s48_string_utf_8_length_n_2(s48_call_t call, s48_ref_t s, long start, long count)
1773 {
1774 return s48_string_utf_8_length_n(s48_deref(s), start, count);
1775 }
1776
1777 long
s48_copy_string_to_utf_8_2(s48_call_t call,s48_ref_t sch_s,char * s)1778 s48_copy_string_to_utf_8_2(s48_call_t call, s48_ref_t sch_s, char* s)
1779 {
1780 return s48_copy_string_to_utf_8(s48_deref(sch_s), s);
1781 }
1782
1783 long
s48_copy_string_to_utf_8_n_2(s48_call_t call,s48_ref_t sch_s,long start,long count,char * s)1784 s48_copy_string_to_utf_8_n_2(s48_call_t call, s48_ref_t sch_s, long start, long count, char* s)
1785 {
1786 return s48_copy_string_to_utf_8_n(s48_deref(sch_s), start, count, s);
1787 }
1788
1789 long
s48_string_utf_16be_length_2(s48_call_t call,s48_ref_t sch_s)1790 s48_string_utf_16be_length_2(s48_call_t call, s48_ref_t sch_s)
1791 {
1792 return s48_string_utf_16be_length(s48_deref(sch_s));
1793 }
1794
1795 long
s48_string_utf_16be_length_n_2(s48_call_t call,s48_ref_t sch_s,long start,long count)1796 s48_string_utf_16be_length_n_2(s48_call_t call, s48_ref_t sch_s, long start, long count)
1797 {
1798 return s48_string_utf_16be_length_n(s48_deref(sch_s), start, count);
1799 }
1800
1801 long
s48_string_utf_16le_length_2(s48_call_t call,s48_ref_t sch_s)1802 s48_string_utf_16le_length_2(s48_call_t call, s48_ref_t sch_s)
1803 {
1804 return s48_string_utf_16le_length(s48_deref(sch_s));
1805 }
1806
1807 long
s48_string_utf_16le_length_n_2(s48_call_t call,s48_ref_t sch_s,long start,long count)1808 s48_string_utf_16le_length_n_2(s48_call_t call, s48_ref_t sch_s, long start, long count)
1809 {
1810 return s48_string_utf_16le_length_n(s48_deref(sch_s), start, count);
1811 }
1812
1813 long
s48_string_length_2(s48_call_t call,s48_ref_t string)1814 s48_string_length_2(s48_call_t call, s48_ref_t string)
1815 {
1816 return s48_string_length(s48_deref(string));
1817 }
1818
1819 long
s48_string_latin_1_length_2(s48_call_t call,s48_ref_t string)1820 s48_string_latin_1_length_2(s48_call_t call, s48_ref_t string)
1821 {
1822 return s48_string_length_2(call, string);
1823 }
1824
1825 long
s48_string_latin_1_length_n_2(s48_call_t call,s48_ref_t string,long start,long count)1826 s48_string_latin_1_length_n_2(s48_call_t call, s48_ref_t string, long start, long count)
1827 {
1828 return count;
1829 }
1830
1831 void
s48_string_set_2(s48_call_t call,s48_ref_t s,long i,long c)1832 s48_string_set_2(s48_call_t call, s48_ref_t s, long i, long c)
1833 {
1834 s48_string_set(s48_deref(s), i, c);
1835 }
1836
1837 long
s48_string_ref_2(s48_call_t call,s48_ref_t s,long i)1838 s48_string_ref_2(s48_call_t call, s48_ref_t s, long i)
1839 {
1840 return s48_string_ref(s48_deref(s), i);
1841 }
1842
1843 /*
1844 * Extract strings to local buffer
1845 */
1846
1847 #define MAKE_STRING_EXTRACT_FUNCTION(encoding) \
1848 char *s48_extract_##encoding##_from_string_2(s48_call_t call, s48_ref_t sch_s) { \
1849 char *buf = s48_make_local_buf(call, s48_string_##encoding##_length_2(call, sch_s)); \
1850 s48_copy_string_to_##encoding##_2(call, sch_s, buf); \
1851 return buf; \
1852 }
1853
1854 char *
s48_extract_latin_1_from_string_2(s48_call_t call,s48_ref_t sch_s)1855 s48_extract_latin_1_from_string_2(s48_call_t call, s48_ref_t sch_s) {
1856 long size = s48_string_latin_1_length_2(call, sch_s) + 1;
1857 char *buf = s48_make_local_buf(call, size + 1);
1858 s48_copy_string_to_latin_1_2(call, sch_s, buf);
1859 buf[size] = '\0';
1860 return buf;
1861 }
1862
1863 char *
s48_extract_utf_8_from_string_2(s48_call_t call,s48_ref_t sch_s)1864 s48_extract_utf_8_from_string_2(s48_call_t call, s48_ref_t sch_s) {
1865 long size = s48_string_utf_8_length_2(call, sch_s) + 1;
1866 char *buf = s48_make_local_buf(call, size + 1);
1867 s48_copy_string_to_utf_8_2(call, sch_s, buf);
1868 buf[size] = '\0';
1869 return buf;
1870 }
1871
1872 uint16_t *
s48_extract_utf_16be_from_string_2(s48_call_t call,s48_ref_t sch_s)1873 s48_extract_utf_16be_from_string_2(s48_call_t call, s48_ref_t sch_s) {
1874 long size = s48_string_utf_16be_length_2(call, sch_s);
1875 uint16_t *buf =
1876 (uint16_t *) s48_make_local_buf(call, (size + 1) * sizeof(uint16_t));
1877 s48_copy_string_to_utf_16be_2(call, sch_s, buf);
1878 buf[size] = 0;
1879 return buf;
1880 }
1881
1882 uint16_t *
s48_extract_utf_16le_from_string_2(s48_call_t call,s48_ref_t sch_s)1883 s48_extract_utf_16le_from_string_2(s48_call_t call, s48_ref_t sch_s) {
1884 long size = s48_string_utf_16le_length_2(call, sch_s);
1885 uint16_t *buf =
1886 (uint16_t *) s48_make_local_buf(call, (size + 1) * sizeof(uint16_t));
1887 s48_copy_string_to_utf_16le_2(call, sch_s, buf);
1888 buf[size] = 0;
1889 return buf;
1890 }
1891
1892 /*
1893 * Doubles and characters are straightforward.
1894 */
1895
1896 s48_value
s48_enter_double(double value)1897 s48_enter_double(double value)
1898 {
1899 s48_value obj;
1900
1901 obj = s48_allocate_stob(S48_STOBTYPE_DOUBLE, sizeof(double));
1902 S48_UNSAFE_EXTRACT_DOUBLE(obj) = value;
1903
1904 return obj;
1905 }
1906
1907 s48_ref_t
s48_enter_double_2(s48_call_t call,double value)1908 s48_enter_double_2(s48_call_t call, double value)
1909 {
1910 s48_ref_t ref;
1911 ref = s48_make_local_ref(call, s48_allocate_stob(S48_STOBTYPE_DOUBLE, sizeof(double)));
1912 s48_unsafe_extract_double_2(call, ref) = value;
1913
1914 return ref;
1915 }
1916
1917 double
s48_extract_double(s48_value s48_double)1918 s48_extract_double(s48_value s48_double)
1919 {
1920 if (! S48_DOUBLE_P(s48_double))
1921 s48_assertion_violation("s48_extract_double", "not a double", 1, s48_double);
1922
1923 return S48_UNSAFE_EXTRACT_DOUBLE(s48_double);
1924 }
1925
1926 double
s48_extract_double_2(s48_call_t call,s48_ref_t s48_double)1927 s48_extract_double_2(s48_call_t call, s48_ref_t s48_double)
1928 {
1929 if (! s48_double_p_2(call, s48_double))
1930 s48_assertion_violation_2(call, "s48_extract_double_2",
1931 "not a double", 1, s48_double);
1932
1933 return s48_unsafe_extract_double_2(call, s48_double);
1934 }
1935
1936 s48_value
s48_enter_char(long a_char)1937 s48_enter_char(long a_char)
1938 {
1939 if (! ((a_char >= 0)
1940 && ((a_char <= 0xd7ff)
1941 || ((a_char >= 0xe000) && (a_char <= 0x10ffff)))))
1942 s48_assertion_violation("s48_enter_char", "not a scalar value", 1, s48_enter_fixnum(a_char));
1943
1944 return S48_UNSAFE_ENTER_CHAR(a_char);
1945 }
1946
1947 s48_ref_t
s48_enter_char_2(s48_call_t call,long a_char)1948 s48_enter_char_2(s48_call_t call, long a_char)
1949 {
1950 if (! ((a_char >= 0)
1951 && ((a_char <= 0xd7ff)
1952 || ((a_char >= 0xe000) && (a_char <= 0x10ffff)))))
1953 s48_assertion_violation_2(call, "s48_enter_char_2",
1954 "not a scalar value", 1, s48_enter_long_as_fixnum_2(call, a_char));
1955
1956 return s48_unsafe_enter_char_2(call, a_char);
1957 }
1958
1959 long
s48_extract_char(s48_value a_char)1960 s48_extract_char(s48_value a_char)
1961 {
1962 if (! S48_CHAR_P(a_char))
1963 s48_assertion_violation("s48_extract_char", "not a char", 1, a_char);
1964
1965 return S48_UNSAFE_EXTRACT_CHAR(a_char);
1966 }
1967
1968 long
s48_extract_char_2(s48_call_t call,s48_ref_t a_char)1969 s48_extract_char_2(s48_call_t call, s48_ref_t a_char)
1970 {
1971 if (! s48_char_p_2(call, a_char))
1972 s48_assertion_violation_2(call, "s48_extract_char_2", "not a char", 1, a_char);
1973
1974 return s48_unsafe_extract_char_2(call, a_char);
1975 }
1976
1977 /********************************/
1978 /* Allocation */
1979
1980 s48_value
s48_enter_pointer(void * pointer)1981 s48_enter_pointer(void *pointer)
1982 {
1983 s48_value obj;
1984
1985 obj = s48_allocate_stob(S48_STOBTYPE_BYTE_VECTOR, sizeof(void *));
1986 *(S48_ADDRESS_AFTER_HEADER(obj, void *)) = pointer;
1987
1988 return obj;
1989 }
1990
1991 s48_ref_t
s48_enter_pointer_2(s48_call_t call,void * pointer)1992 s48_enter_pointer_2(s48_call_t call, void *pointer)
1993 {
1994 s48_ref_t ref;
1995
1996 ref = s48_make_local_ref(call, s48_allocate_stob(S48_STOBTYPE_BYTE_VECTOR, sizeof(void *)));
1997 *(s48_address_after_header_2(call, ref, void *)) = pointer;
1998
1999 return ref;
2000 }
2001
2002 void*
s48_extract_pointer(s48_value sch_pointer)2003 s48_extract_pointer(s48_value sch_pointer)
2004 {
2005 S48_CHECK_VALUE(sch_pointer);
2006 return *(S48_ADDRESS_AFTER_HEADER(sch_pointer, void *));
2007 }
2008
2009 void*
s48_extract_pointer_2(s48_call_t call,s48_ref_t sch_pointer)2010 s48_extract_pointer_2(s48_call_t call, s48_ref_t sch_pointer)
2011 {
2012 s48_check_value_2(call, sch_pointer);
2013 return *(s48_address_after_header_2(call, sch_pointer, void *));
2014 }
2015
2016 s48_ref_t
s48_get_imported_binding_2(char * name)2017 s48_get_imported_binding_2(char *name)
2018 {
2019 return s48_make_global_ref(s48_get_imported_binding(name));
2020 }
2021
2022 s48_ref_t
s48_get_imported_binding_local_2(s48_call_t call,char * name)2023 s48_get_imported_binding_local_2(s48_call_t call, char *name)
2024 {
2025 return s48_make_local_ref(call, s48_get_imported_binding(name));
2026 }
2027
2028 s48_ref_t
s48_define_exported_binding_2(s48_call_t call,char * name,s48_ref_t binding)2029 s48_define_exported_binding_2(s48_call_t call, char *name, s48_ref_t binding)
2030 {
2031 return s48_make_local_ref(call, s48_define_exported_binding(name, s48_deref(binding)));
2032 }
2033
2034 s48_value
s48_cons(s48_value v1,s48_value v2)2035 s48_cons(s48_value v1, s48_value v2)
2036 {
2037 s48_value obj;
2038 S48_DECLARE_GC_PROTECT(2);
2039
2040 S48_GC_PROTECT_2(v1, v2);
2041
2042 obj = s48_allocate_stob(S48_STOBTYPE_PAIR, 2);
2043 S48_UNSAFE_SET_CAR(obj, v1);
2044 S48_UNSAFE_SET_CDR(obj, v2);
2045
2046 S48_GC_UNPROTECT();
2047 return obj;
2048 }
2049
2050 s48_ref_t
s48_cons_2(s48_call_t call,s48_ref_t v1,s48_ref_t v2)2051 s48_cons_2(s48_call_t call, s48_ref_t v1, s48_ref_t v2)
2052 {
2053 s48_ref_t ref;
2054 ref = s48_make_local_ref(call, s48_allocate_stob(S48_STOBTYPE_PAIR, 2));
2055 s48_unsafe_set_car_2(call, ref, v1);
2056 s48_unsafe_set_cdr_2(call, ref, v2);
2057 return ref;
2058 }
2059
2060 s48_value
s48_make_weak_pointer(s48_value value)2061 s48_make_weak_pointer(s48_value value)
2062 {
2063 s48_value obj;
2064 S48_DECLARE_GC_PROTECT(1);
2065
2066 S48_GC_PROTECT_1(value);
2067
2068 obj = s48_allocate_weak_stob(S48_STOBTYPE_WEAK_POINTER, 1);
2069 S48_STOB_SET(obj, 0, value);
2070
2071 S48_GC_UNPROTECT();
2072 return obj;
2073 }
2074
2075 s48_ref_t
s48_make_weak_pointer_2(s48_call_t call,s48_ref_t value)2076 s48_make_weak_pointer_2(s48_call_t call, s48_ref_t value)
2077 {
2078 s48_ref_t ref = s48_make_local_ref(call, s48_allocate_weak_stob(S48_STOBTYPE_WEAK_POINTER, 1));
2079 s48_unsafe_stob_set_2(call, ref, 0, value);
2080 return ref;
2081 }
2082
2083 /*
2084 * Entering and extracting byte vectors.
2085 */
2086
2087 s48_value
s48_enter_byte_vector(char * bytes,long length)2088 s48_enter_byte_vector(char *bytes, long length)
2089 {
2090 s48_value obj = s48_make_byte_vector(length);
2091 memcpy(S48_UNSAFE_EXTRACT_BYTE_VECTOR(obj), bytes, length);
2092 return obj;
2093 }
2094
2095 s48_ref_t
s48_enter_byte_vector_2(s48_call_t call,const char * bytes,long length)2096 s48_enter_byte_vector_2(s48_call_t call, const char *bytes, long length)
2097 {
2098 s48_ref_t ref = s48_make_byte_vector_2(call, length);
2099 s48_enter_byte_vector_region_2(call, ref, 0, length, (char *) bytes);
2100 return ref;
2101 }
2102
2103 s48_value
s48_enter_unmovable_byte_vector(char * bytes,long length)2104 s48_enter_unmovable_byte_vector(char *bytes, long length)
2105 {
2106 s48_value obj = s48_make_unmovable_byte_vector(length);
2107 memcpy(S48_UNSAFE_EXTRACT_BYTE_VECTOR(obj), bytes, length);
2108 return obj;
2109 }
2110
2111 s48_ref_t
s48_enter_unmovable_byte_vector_2(s48_call_t call,const char * bytes,long length)2112 s48_enter_unmovable_byte_vector_2(s48_call_t call, const char *bytes, long length)
2113 {
2114 s48_ref_t ref = s48_make_unmovable_byte_vector_2(call, length);
2115 s48_enter_byte_vector_region_2(call, ref, 0, length, (char *) bytes);
2116 return ref;
2117 }
2118
2119 char *
s48_extract_byte_vector(s48_value byte_vector)2120 s48_extract_byte_vector(s48_value byte_vector)
2121 {
2122 S48_CHECK_VALUE(byte_vector);
2123
2124 return S48_UNSAFE_EXTRACT_BYTE_VECTOR(byte_vector);
2125 }
2126
2127 char *
s48_extract_byte_vector_2(s48_call_t call,s48_ref_t byte_vector)2128 s48_extract_byte_vector_2(s48_call_t call, s48_ref_t byte_vector)
2129 {
2130 long s = s48_byte_vector_length_2(call, byte_vector);
2131 char *buf = s48_make_local_bv(call, byte_vector, s);
2132 return buf;
2133 }
2134
2135 char *
s48_extract_byte_vector_readonly_2(s48_call_t call,s48_ref_t byte_vector)2136 s48_extract_byte_vector_readonly_2(s48_call_t call, s48_ref_t byte_vector)
2137 {
2138 long s = s48_byte_vector_length_2(call, byte_vector);
2139 char *buf = s48_make_local_bv_readonly(call, byte_vector, s);
2140 return buf;
2141 }
2142
2143 void
s48_extract_byte_vector_region_2(s48_call_t call,s48_ref_t byte_vector,long start,long length,char * buf)2144 s48_extract_byte_vector_region_2(s48_call_t call, s48_ref_t byte_vector,
2145 long start, long length, char *buf)
2146 {
2147 char *scheme_buf;
2148 s48_check_value_2(call, byte_vector);
2149 scheme_buf = s48_unsafe_extract_byte_vector_2(call, byte_vector);
2150 memcpy(buf, scheme_buf + start, length);
2151 }
2152
2153 void
s48_enter_byte_vector_region_2(s48_call_t call,s48_ref_t byte_vector,long start,long length,char * buf)2154 s48_enter_byte_vector_region_2(s48_call_t call, s48_ref_t byte_vector,
2155 long start, long length, char *buf)
2156 {
2157 char *scheme_buf;
2158 s48_check_value_2(call, byte_vector);
2159 scheme_buf = s48_unsafe_extract_byte_vector_2(call, byte_vector);
2160 memcpy(scheme_buf + start, buf, length);
2161 }
2162
2163 void
s48_copy_from_byte_vector_2(s48_call_t call,s48_ref_t byte_vector,char * buf)2164 s48_copy_from_byte_vector_2(s48_call_t call, s48_ref_t byte_vector, char *buf)
2165 {
2166 s48_extract_byte_vector_region_2(call, byte_vector, 0,
2167 s48_byte_vector_length_2(call, byte_vector), buf);
2168 }
2169
2170 void
s48_copy_to_byte_vector_2(s48_call_t call,s48_ref_t byte_vector,char * buf)2171 s48_copy_to_byte_vector_2(s48_call_t call, s48_ref_t byte_vector, char *buf)
2172 {
2173 s48_enter_byte_vector_region_2(call, byte_vector, 0,
2174 s48_byte_vector_length_2(call, byte_vector), buf);
2175 }
2176
2177 psbool
s48_unmovable_p(s48_call_t call,s48_ref_t ref)2178 s48_unmovable_p(s48_call_t call, s48_ref_t ref)
2179 {
2180 return s48_unmovableP(s48_deref(ref));
2181 }
2182
2183 char *
s48_extract_unmovable_byte_vector_2(s48_call_t call,s48_ref_t byte_vector)2184 s48_extract_unmovable_byte_vector_2(s48_call_t call, s48_ref_t byte_vector)
2185 {
2186 s48_check_value_2(call, byte_vector);
2187 if (!s48_unmovable_p(call, byte_vector))
2188 s48_assertion_violation("s48_extract_unmovable_byte_vector_2",
2189 "not an unmovable byte vector", 1, byte_vector);
2190 return s48_unsafe_extract_byte_vector_2(call, byte_vector);
2191 }
2192
2193 /*
2194 The returned byte vector by s48_extract_byte_vector_unmanaged_2 may
2195 be a copy of the Scheme byte vector, changes made to the returned
2196 byte vector will not necessarily be reflected in Scheme until
2197 s48_release_byte_vector_2 is called.
2198 */
2199 char *
s48_extract_byte_vector_unmanaged_2(s48_call_t call,s48_ref_t byte_vector)2200 s48_extract_byte_vector_unmanaged_2(s48_call_t call, s48_ref_t byte_vector)
2201 {
2202 if (s48_unmovable_p(call, byte_vector))
2203 {
2204 return s48_extract_unmovable_byte_vector_2(call, byte_vector);
2205 }
2206 else
2207 {
2208 long len = s48_byte_vector_length_2(call, byte_vector);
2209 char *buf = s48_make_local_buf(call, len);
2210 s48_extract_byte_vector_region_2(call, byte_vector, 0, len, buf);
2211 return buf;
2212 }
2213 }
2214
2215 void
s48_release_byte_vector_2(s48_call_t call,s48_ref_t byte_vector,char * buf)2216 s48_release_byte_vector_2(s48_call_t call, s48_ref_t byte_vector, char *buf)
2217 {
2218 if (!s48_unmovable_p(call, byte_vector))
2219 s48_copy_to_byte_vector_2(call, byte_vector, buf);
2220 }
2221
2222 /*
2223 * Making various kinds of stored objects.
2224 */
2225
2226 s48_value
s48_make_string(int length,long init)2227 s48_make_string(int length, long init)
2228 {
2229 int i;
2230 s48_value obj = s48_allocate_string(length);
2231 /* We should probably offer a VM function for this. */
2232 for (i = 0; i < length; ++i)
2233 s48_string_set(obj, i, init);
2234 return obj;
2235 }
2236
2237 s48_ref_t
s48_make_string_2(s48_call_t call,int length,long init)2238 s48_make_string_2(s48_call_t call, int length, long init)
2239 {
2240 int i;
2241 s48_ref_t ref = s48_make_local_ref(call, s48_allocate_string(length));
2242 /* We should probably offer a VM function for this. */
2243 for (i = 0; i < length; ++i)
2244 s48_string_set(s48_deref(ref), i, init);
2245 return ref;
2246 }
2247
2248 s48_value
s48_make_vector(long length,s48_value init)2249 s48_make_vector(long length, s48_value init)
2250 {
2251 long i;
2252 s48_value obj;
2253 S48_DECLARE_GC_PROTECT(1);
2254
2255 S48_GC_PROTECT_1(init);
2256
2257 obj = s48_allocate_stob(S48_STOBTYPE_VECTOR, length);
2258 for (i = 0; i < length; ++i)
2259 S48_UNSAFE_VECTOR_SET(obj, i, init);
2260
2261 S48_GC_UNPROTECT();
2262
2263 return obj;
2264 }
2265
2266 s48_ref_t
s48_make_vector_2(s48_call_t call,long length,s48_ref_t init)2267 s48_make_vector_2(s48_call_t call, long length, s48_ref_t init)
2268 {
2269 long i;
2270 s48_ref_t ref = s48_make_local_ref(call, s48_allocate_stob(S48_STOBTYPE_VECTOR, length));
2271 for (i = 0; i < length; ++i)
2272 s48_unsafe_vector_set_2(call, ref, i, init);
2273 return ref;
2274 }
2275
2276 s48_value
s48_make_byte_vector(long length)2277 s48_make_byte_vector(long length)
2278 {
2279 return s48_allocate_stob(S48_STOBTYPE_BYTE_VECTOR, length);
2280 }
2281
2282 s48_ref_t
s48_make_byte_vector_2(s48_call_t call,long length)2283 s48_make_byte_vector_2(s48_call_t call, long length)
2284 {
2285 return s48_make_local_ref(call, s48_allocate_stob(S48_STOBTYPE_BYTE_VECTOR, length));
2286 }
2287
2288 s48_value
s48_make_unmovable_byte_vector(long length)2289 s48_make_unmovable_byte_vector(long length)
2290 {
2291 return s48_allocate_unmovable_stob(S48_STOBTYPE_BYTE_VECTOR, length);
2292 }
2293
2294 s48_ref_t
s48_make_unmovable_byte_vector_2(s48_call_t call,long length)2295 s48_make_unmovable_byte_vector_2(s48_call_t call, long length)
2296 {
2297 return s48_make_local_ref(call, s48_allocate_unmovable_stob(S48_STOBTYPE_BYTE_VECTOR, length));
2298 }
2299
2300 s48_value
s48_enter_byte_substring(char * str,long length)2301 s48_enter_byte_substring(char *str, long length)
2302 {
2303 s48_value obj = s48_allocate_stob(S48_STOBTYPE_BYTE_VECTOR, length + 1);
2304 memcpy(S48_UNSAFE_EXTRACT_BYTE_VECTOR(obj), str, length);
2305 *(S48_UNSAFE_EXTRACT_BYTE_VECTOR(obj) + length) = '\0';
2306 return obj;
2307 }
2308
2309 s48_ref_t
s48_enter_byte_substring_2(s48_call_t call,const char * str,long length)2310 s48_enter_byte_substring_2(s48_call_t call, const char *str, long length)
2311 {
2312 s48_ref_t ref = s48_make_byte_vector_2(call, length + 1);
2313 s48_enter_byte_vector_region_2(call, ref, 0, length, (char *) str);
2314 s48_byte_vector_set_2(call, ref, length, '\0');
2315 return ref;
2316 }
2317
2318 s48_value
s48_enter_byte_string(char * str)2319 s48_enter_byte_string(char *str)
2320 {
2321 return s48_enter_byte_substring(str, strlen(str));
2322 }
2323
2324 s48_ref_t
s48_enter_byte_string_2(s48_call_t call,const char * str)2325 s48_enter_byte_string_2(s48_call_t call, const char *str)
2326 {
2327 return s48_enter_byte_substring_2(call, str, strlen(str));
2328 }
2329
2330 s48_value
s48_make_record(s48_value type_shared_binding)2331 s48_make_record(s48_value type_shared_binding)
2332 {
2333 long i, number_of_fields;
2334 s48_value record = S48_FALSE;
2335 s48_value record_type = S48_FALSE;
2336 S48_DECLARE_GC_PROTECT(1);
2337
2338 S48_GC_PROTECT_1(record_type);
2339
2340 S48_SHARED_BINDING_CHECK(type_shared_binding);
2341 S48_SHARED_BINDING_CHECK(s48_deref(the_record_type_binding));
2342
2343 record_type = S48_SHARED_BINDING_REF(type_shared_binding);
2344
2345 s48_check_record_type(record_type, s48_deref(the_record_type_binding));
2346
2347 number_of_fields =
2348 S48_UNSAFE_EXTRACT_FIXNUM(S48_RECORD_TYPE_NUMBER_OF_FIELDS(record_type));
2349
2350 record = s48_allocate_stob(S48_STOBTYPE_RECORD, number_of_fields + 1);
2351
2352 S48_UNSAFE_RECORD_SET(record, -1, record_type);
2353 for (i = 0; i < number_of_fields; ++i)
2354 S48_UNSAFE_RECORD_SET(record, i, S48_UNSPECIFIC);
2355
2356 S48_GC_UNPROTECT();
2357
2358 return record;
2359 }
2360
2361 s48_ref_t
s48_make_record_2(s48_call_t call,s48_ref_t type_shared_binding)2362 s48_make_record_2(s48_call_t call, s48_ref_t type_shared_binding)
2363 {
2364 long i, number_of_fields;
2365 s48_ref_t record;
2366 s48_ref_t record_type;
2367
2368 s48_shared_binding_check_2(call, type_shared_binding);
2369 s48_shared_binding_check_2(call, the_record_type_binding);
2370
2371 record_type = s48_shared_binding_ref_2(call, type_shared_binding);
2372
2373 s48_check_record_type_2(call, record_type, the_record_type_binding);
2374
2375 number_of_fields =
2376 s48_unsafe_extract_long_2(call,
2377 s48_record_type_number_of_fields_2(call, record_type));
2378
2379 record = s48_make_local_ref(call, s48_allocate_stob(S48_STOBTYPE_RECORD, number_of_fields + 1));
2380
2381 s48_unsafe_record_set_2(call, record, -1, record_type);
2382 for (i = 0; i < number_of_fields; ++i)
2383 s48_unsafe_record_set_2(call, record, i, s48_unspecific_2(call));
2384
2385 return record;
2386 }
2387
2388 /*
2389 * Raise an exception if `record' is not a record whose type is the one
2390 * found in `type_binding'.
2391 */
2392 void
s48_check_record_type(s48_value record,s48_value type_binding)2393 s48_check_record_type(s48_value record, s48_value type_binding)
2394 {
2395 if (! S48_RECORD_P(S48_SHARED_BINDING_REF(type_binding)))
2396 s48_raise_scheme_exception(S48_EXCEPTION_UNBOUND_EXTERNAL_NAME, 1,
2397 S48_SHARED_BINDING_NAME(type_binding));
2398
2399 if ((! S48_RECORD_P(record)) ||
2400 (S48_UNSAFE_SHARED_BINDING_REF(type_binding) !=
2401 S48_UNSAFE_RECORD_REF(record, -1)))
2402 s48_assertion_violation("s48_check_record_type", "not a record of the appropriate type", 2,
2403 record, S48_SHARED_BINDING_REF(type_binding));
2404 }
2405
2406 void
s48_check_record_type_2(s48_call_t call,s48_ref_t record,s48_ref_t type_binding)2407 s48_check_record_type_2(s48_call_t call, s48_ref_t record, s48_ref_t type_binding)
2408 {
2409 if (! s48_record_p_2(call, s48_shared_binding_ref_2(call, type_binding)))
2410 s48_raise_scheme_exception_2(call,S48_EXCEPTION_UNBOUND_EXTERNAL_NAME, 1,
2411 s48_shared_binding_name_2(call, type_binding));
2412
2413 if ((! s48_record_p_2(call, record)) ||
2414 (!s48_eq_p_2(call,
2415 s48_unsafe_shared_binding_ref_2(call, type_binding),
2416 s48_unsafe_record_ref_2(call, record, -1))))
2417 s48_assertion_violation_2(call, "s48_check_record_type_2",
2418 "not a record of the appropriate type", 2,
2419 record, s48_shared_binding_ref_2(call, type_binding));
2420 }
2421
2422 long
s48_length(s48_value list)2423 s48_length(s48_value list)
2424 {
2425 long i = 0;
2426
2427 while (!(S48_EQ(list, S48_NULL)))
2428 {
2429 list = S48_CDR(list);
2430 ++i;
2431 }
2432 return S48_UNSAFE_ENTER_FIXNUM(i);
2433 }
2434
2435 s48_ref_t
s48_length_2(s48_call_t call,s48_ref_t list)2436 s48_length_2(s48_call_t call, s48_ref_t list)
2437 {
2438 s48_ref_t l = s48_copy_local_ref(call, list);
2439 long i = 0;
2440 while (!(s48_null_p_2(call, l)))
2441 {
2442 s48_ref_t temp = l;
2443 l = s48_cdr_2(call, l);
2444 s48_free_local_ref(call, temp);
2445 ++i;
2446 }
2447 return s48_unsafe_enter_long_as_fixnum_2(call, i);
2448 }
2449