1 /* chicken.h - General headerfile for compiler generated executables
2 ;
3 ; Copyright (c) 2008-2021, The CHICKEN Team
4 ; Copyright (c) 2000-2007, Felix L. Winkelmann
5 ; All rights reserved.
6 ;
7 ; Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following
8 ; conditions are met:
9 ;
10 ; Redistributions of source code must retain the above copyright notice, this list of conditions and the following
11 ; disclaimer.
12 ; Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following
13 ; disclaimer in the documentation and/or other materials provided with the distribution.
14 ; Neither the name of the author nor the names of its contributors may be used to endorse or promote
15 ; products derived from this software without specific prior written permission.
16 ;
17 ; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS
18 ; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
19 ; AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
20 ; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
21 ; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
22 ; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
23 ; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
24 ; OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
25 ; POSSIBILITY OF SUCH DAMAGE.
26 */
27
28 /* Configuration: */
29
30 #ifndef ___CHICKEN
31 #define ___CHICKEN
32
33 #define C_MAJOR_VERSION 5
34 #define C_MINOR_VERSION 3
35
36 #ifndef _ISOC99_SOURCE
37 # define _ISOC99_SOURCE
38 #endif
39
40 #ifndef __C99FEATURES__
41 # define __C99FEATURES__
42 #endif
43
44 /*
45 * N.B. This file MUST not rely upon "chicken-config.h"
46 */
47 #if defined(HAVE_CONFIG_H) || defined(HAVE_CHICKEN_CONFIG_H)
48 # include "chicken-config.h"
49 #endif
50
51 /* Some OSes really dislike feature macros for standard levels */
52 #ifdef C_USE_STD_FEATURE_MACROS
53
54 # ifndef _XOPEN_SOURCE
55 # define _XOPEN_SOURCE 700
56 # endif
57
58 # ifndef _BSD_SOURCE
59 # define _BSD_SOURCE
60 # endif
61
62 # ifndef _NETBSD_SOURCE
63 # define _NETBSD_SOURCE
64 # endif
65
66 # ifndef _SVID_SOURCE
67 # define _SVID_SOURCE
68 # endif
69
70 /*
71 * glibc >= 2.20 synonym for _BSD_SOURCE & _SVID_SOURCE.
72 */
73 # ifndef _DEFAULT_SOURCE
74 # define _DEFAULT_SOURCE
75 # endif
76
77 #endif /* C_USE_STD_FEATURE_MACROS */
78
79 /* Kind of platform */
80
81 #if defined(__LP64__) || defined(_LP64) || defined(__MINGW64__) || defined(_WIN64)
82 # define C_SIXTY_FOUR
83 #endif
84
85 #if defined(__APPLE__) && defined(__MACH__)
86 # define C_MACOSX
87 #endif
88
89 #if defined(C_MACOSX) || defined(__FreeBSD__) || defined(__NetBSD__) || defined(__DragonFly__) || defined(__OpenBSD__)
90 # define C_XXXBSD
91 #endif
92
93 #if /*defined(__GNUC__) &&*/ (defined(__linux__) || defined(C_XXXBSD) || defined(__HAIKU__))
94 # define C_GNU_ENV
95 #endif
96
97 #if defined(__MINGW32__)
98 /*
99 * XXX This should probably be renamed or changed because it's misleading.
100 * For example, Haiku is not a Unix either, but this doesn't get defined there.
101 */
102 # define C_NONUNIX
103 #endif
104
105 #if defined(__sun) && defined(__SVR4)
106 # define C_SOLARIS
107 #endif
108
109 #if defined(__MINGW64__) || defined(_WIN64)
110 # define C_LLP
111 #endif
112
113 /* Declare base Win32 version: we require Vista or later */
114
115 #ifdef __MINGW32__
116 # define _WIN32_WINNT 0x0600
117 #endif
118
119
120 /* Headers */
121
122 #include <ctype.h>
123 #include <errno.h>
124 #include <inttypes.h>
125 #include <limits.h>
126 #include <math.h>
127 #include <setjmp.h>
128 #include <stdarg.h>
129 #include <stddef.h>
130 #include <stdio.h>
131 #include <stdlib.h>
132 #include <string.h>
133 #include <time.h>
134 #include <unistd.h>
135 #include <sys/types.h>
136 #include <sys/stat.h>
137
138
139 /* Byteorder in machine word */
140
141 #if defined(__MINGW32__)
142 # include <sys/param.h>
143 #elif defined(__CYGWIN__)
144 # include <endian.h>
145 #elif defined(__linux__)
146 # include <endian.h>
147 #elif defined(C_XXXBSD)
148 # include <machine/endian.h>
149 #elif defined(__hpux__)
150 # include <arpa/nameser.h>
151 #elif defined(_AIX)
152 # include <sys/machine.h>
153 #elif defined(__sun)
154 # include <sys/isa_defs.h>
155 #elif defined(__SVR4)
156 # include <sys/byteorder.h>
157 #endif
158
159 #if defined(__MINGW32__)
160 # include <malloc.h>
161 #endif
162
163 /* Much better with stack allocation API */
164
165 #ifdef HAVE_ALLOCA_H
166 # include <alloca.h>
167 #elif !defined(alloca) /* predefined by HP cc +Olibcalls */
168 void *alloca ();
169 #endif
170
171
172 /* CHICKEN Core C API */
173
174 #if defined(__BYTE_ORDER) && __BYTE_ORDER == __BIG_ENDIAN
175 # define C_BIG_ENDIAN
176 #elif defined(BYTE_ORDER) && defined(BIG_ENDIAN) && BYTE_ORDER == BIG_ENDIAN
177 # define C_BIG_ENDIAN
178 #elif defined(__BIG_ENDIAN__)
179 # define C_BIG_ENDIAN
180 #elif defined(__MIPSEL__) || defined(__MIPSEL)
181 # define C_LITTLE_ENDIAN
182 #elif defined(__sparc__) || defined(__POWERPC__) || defined(__MC68K__) || defined(__mips__)
183 # define C_BIG_ENDIAN
184 #endif
185
186 #if defined(__BYTE_ORDER) && defined(__LITTLE_ENDIAN) && __BYTE_ORDER == __LITTLE_ENDIAN
187 # define C_LITTLE_ENDIAN
188 #elif defined(BYTE_ORDER) && defined(LITTLE_ENDIAN) && BYTE_ORDER == LITTLE_ENDIAN
189 # define C_LITTLE_ENDIAN
190 #elif defined(__LITTLE_ENDIAN__)
191 # define C_LITTLE_ENDIAN
192 #elif defined (__alpha__) || defined(_M_IX86) || defined(__i386__) || defined(__x86_64__) || defined(__ia64__)
193 # define C_LITTLE_ENDIAN
194 #endif
195
196 /* Make sure some common C identifiers are availble w/ Windows */
197
198 /* Could be used by C++ source */
199
200 #ifdef __cplusplus
201 # define C_extern extern "C"
202 # define C_BEGIN_C_DECLS extern "C" {
203 # define C_END_C_DECLS }
204 #else
205 # define C_extern extern
206 # define C_BEGIN_C_DECLS
207 # define C_END_C_DECLS
208 #endif
209
210
211 /* Function declaration modes */
212
213 /* Visibility */
214 #define C_varextern C_extern
215 #define C_fctimport
216 #define C_fctexport
217 #define C_externimport C_extern
218 #define C_externexport C_extern
219 #if defined(PIC)
220 # if defined(__CYGWIN__) || defined(__MINGW32__)
221 # ifndef C_BUILDING_LIBCHICKEN
222 # undef C_varextern
223 # define C_varextern C_extern __declspec(dllimport)
224 # endif
225 # endif
226 #endif
227
228 /* Language specifics: */
229 #if defined(__GNUC__) || defined(__INTEL_COMPILER)
230 #define HAVE_STATEMENT_EXPRESSIONS 1
231 #endif
232
233 #if !defined(__clang__) && !defined(__has_attribute)
234 /* Define so it won't error on other compilers with keywords like "noreturn" */
235 #define __has_attribute(x) 0
236 #endif
237
238 #if defined(__GNUC__) || defined(__INTEL_COMPILER)
239 # define C_unlikely(x) __builtin_expect((x), 0)
240 # define C_likely(x) __builtin_expect((x), 1)
241 # ifndef __cplusplus
242 # define C_cblock ({
243 # define C_cblockend })
244 # if defined(__clang__) && !__has_attribute(noreturn)
245 # define C_noret
246 # else
247 # define C_noret __attribute__ ((noreturn))
248 # endif
249 # define C_noret_decl(name)
250 # define C_aligned __attribute__ ((aligned))
251 # endif
252 # if defined(__i386__) && !defined(__clang__)
253 # define C_regparm __attribute__ ((regparm(3)))
254 # endif
255 #else
256 # define C_unlikely(x) (x)
257 # define C_likely(x) (x)
258 #endif
259
260 #ifndef C_cblock
261 # define C_cblock do{
262 # define C_cblockend }while(0)
263 # define C_noret
264 # define C_noret_decl(name)
265 #endif
266
267 #ifndef C_regparm
268 # define C_regparm
269 #endif
270
271 #ifndef C_fcall
272 # define C_fcall
273 #endif
274
275 #ifndef C_ccall
276 # define C_ccall
277 #endif
278
279 #ifndef C_aligned
280 # define C_aligned
281 #endif
282
283 /* Thread Local Storage */
284 #ifdef C_ENABLE_TLS
285 # if defined(__GNUC__)
286 # define C_TLS __thread
287 # endif
288 #endif
289
290 #ifndef C_TLS
291 # define C_TLS
292 #endif
293
294
295 /* Stack growth direction; used to compute stack addresses */
296 #ifndef C_STACK_GROWS_DOWNWARD
297 # ifdef __hppa__
298 # define C_STACK_GROWS_DOWNWARD 0
299 # else
300 # define C_STACK_GROWS_DOWNWARD 1
301 # endif
302 #endif
303
304 /* Have a GUI? */
305
306 #if defined(C_GUI) || defined(C_PRIVATE_REPOSITORY)
307 # ifdef _WIN32
308 # include <windows.h>
309 # ifndef WINAPI
310 # define WINAPI
311 # endif
312 # endif
313 #endif
314
315 /* Needed for pre-emptive threading */
316
317 #define C_TIMER_INTERRUPTS
318
319
320 /* Constants: */
321
322 #define C_STACK_RESERVE 0x10000
323 #define C_DEFAULT_MAX_PENDING_FINALIZERS 2048
324
325 #define C_IMMEDIATE_MARK_BITS 0x00000003
326 #define C_IMMEDIATE_TYPE_BITS 0x0000000f
327
328 #define C_BOOLEAN_BITS 0x00000006
329 #define C_CHARACTER_BITS 0x0000000a
330 #define C_SPECIAL_BITS 0x0000000e
331
332 #define C_SCHEME_FALSE ((C_word)(C_BOOLEAN_BITS | 0x00000000))
333 #define C_SCHEME_TRUE ((C_word)(C_BOOLEAN_BITS | 0x00000010))
334
335 #define C_SCHEME_END_OF_LIST ((C_word)(C_SPECIAL_BITS | 0x00000000))
336 #define C_SCHEME_UNDEFINED ((C_word)(C_SPECIAL_BITS | 0x00000010))
337 #define C_SCHEME_UNBOUND ((C_word)(C_SPECIAL_BITS | 0x00000020))
338 #define C_SCHEME_END_OF_FILE ((C_word)(C_SPECIAL_BITS | 0x00000030))
339
340 #define C_FIXNUM_BIT 0x00000001
341 #define C_FIXNUM_SHIFT 1
342
343 /* Character range is that of a UTF-8 codepoint, not representable range */
344 #define C_CHAR_BIT_MASK 0x1fffff
345 #define C_CHAR_SHIFT 8
346
347 #ifdef C_SIXTY_FOUR
348 # define C_MOST_POSITIVE_FIXNUM 0x3fffffffffffffffL
349 # define C_WORD_SIZE 64
350 # define C_HALF_WORD_SIZE 32
351 #else
352 # define C_MOST_POSITIVE_FIXNUM 0x3fffffff
353 # define C_WORD_SIZE 32
354 # define C_HALF_WORD_SIZE 16
355 #endif
356
357 /* Tunable performance-related constants */
358 #ifndef C_KARATSUBA_THRESHOLD
359 /* This defines when we'll switch from schoolbook to Karatsuba
360 * multiplication. The smallest of the two numbers determines the
361 * switch. It is pretty high right now because it generates a bit
362 * more garbage and GC overhead dominates the algorithmic performance
363 * gains. If the GC is improved, this can be readjusted.
364 */
365 # define C_KARATSUBA_THRESHOLD 70
366 #endif
367 #ifndef C_BURNIKEL_ZIEGLER_THRESHOLD
368 /* This defines when to switch from schoolbook to Burnikel-Ziegler
369 * division. It creates even more garbage than Karatsuba :(
370 */
371 # define C_BURNIKEL_ZIEGLER_THRESHOLD 300
372 #endif
373 #ifndef C_RECURSIVE_TO_STRING_THRESHOLD
374 /* This threshold is in terms of the expected string length. */
375 # define C_RECURSIVE_TO_STRING_THRESHOLD 750
376 #endif
377
378 /* These might fit better in runtime.c? */
379 #define C_fitsinbignumhalfdigitp(n) (C_BIGNUM_DIGIT_HI_HALF(n) == 0)
380 #define C_BIGNUM_DIGIT_LENGTH C_WORD_SIZE
381 #define C_BIGNUM_HALF_DIGIT_LENGTH C_HALF_WORD_SIZE
382 #define C_BIGNUM_BITS_TO_DIGITS(n) \
383 (((n) + (C_BIGNUM_DIGIT_LENGTH - 1)) / C_BIGNUM_DIGIT_LENGTH)
384 #define C_BIGNUM_DIGIT_LO_HALF(d) (C_uhword)(d)
385 #define C_BIGNUM_DIGIT_HI_HALF(d) (C_uhword)((d) >> C_BIGNUM_HALF_DIGIT_LENGTH)
386 #define C_BIGNUM_DIGIT_COMBINE(h,l) ((C_uword)(h) << C_BIGNUM_HALF_DIGIT_LENGTH|(C_uhword)(l))
387
388 #define C_MOST_POSITIVE_32_BIT_FIXNUM 0x3fffffff
389 #define C_MOST_NEGATIVE_FIXNUM (-C_MOST_POSITIVE_FIXNUM - 1)
390
391 #ifdef C_SIXTY_FOUR
392 # define C_INT_SIGN_BIT 0x8000000000000000L
393 # define C_INT_TOP_BIT 0x4000000000000000L
394 # define C_HEADER_BITS_MASK 0xff00000000000000L
395 # define C_HEADER_TYPE_BITS 0x0f00000000000000L
396 # define C_HEADER_SIZE_MASK 0x00ffffffffffffffL
397 # define C_GC_FORWARDING_BIT 0x8000000000000000L /* header contains forwarding pointer */
398 # define C_BYTEBLOCK_BIT 0x4000000000000000L /* block contains bytes instead of slots */
399 # define C_SPECIALBLOCK_BIT 0x2000000000000000L /* 1st item is a non-value */
400 # define C_8ALIGN_BIT 0x1000000000000000L /* data is aligned to 8-byte boundary */
401
402 # define C_SYMBOL_TYPE (0x0100000000000000L)
403 # define C_STRING_TYPE (0x0200000000000000L | C_BYTEBLOCK_BIT)
404 # define C_PAIR_TYPE (0x0300000000000000L)
405 # define C_CLOSURE_TYPE (0x0400000000000000L | C_SPECIALBLOCK_BIT)
406 # define C_FLONUM_TYPE (0x0500000000000000L | C_BYTEBLOCK_BIT | C_8ALIGN_BIT)
407 # define C_BIGNUM_TYPE (0x0600000000000000L) /* Just the wrapper */
408 # define C_PORT_TYPE (0x0700000000000000L | C_SPECIALBLOCK_BIT)
409 # define C_STRUCTURE_TYPE (0x0800000000000000L)
410 # define C_POINTER_TYPE (0x0900000000000000L | C_SPECIALBLOCK_BIT)
411 # define C_LOCATIVE_TYPE (0x0a00000000000000L | C_SPECIALBLOCK_BIT)
412 # define C_TAGGED_POINTER_TYPE (0x0b00000000000000L | C_SPECIALBLOCK_BIT)
413 # define C_RATNUM_TYPE (0x0c00000000000000L)
414 # define C_LAMBDA_INFO_TYPE (0x0d00000000000000L | C_BYTEBLOCK_BIT)
415 # define C_CPLXNUM_TYPE (0x0e00000000000000L)
416 /* unused (0x0f00000000000000L ...) */
417 #else
418 # define C_INT_SIGN_BIT 0x80000000
419 # define C_INT_TOP_BIT 0x40000000
420 # define C_HEADER_BITS_MASK 0xff000000
421 # define C_HEADER_TYPE_BITS 0x0f000000
422 # define C_HEADER_SIZE_MASK 0x00ffffff
423 # define C_GC_FORWARDING_BIT 0x80000000
424 # define C_BYTEBLOCK_BIT 0x40000000
425 # define C_SPECIALBLOCK_BIT 0x20000000
426 # define C_8ALIGN_BIT 0x10000000
427
428 # define C_SYMBOL_TYPE (0x01000000)
429 # define C_STRING_TYPE (0x02000000 | C_BYTEBLOCK_BIT)
430 # define C_PAIR_TYPE (0x03000000)
431 # define C_CLOSURE_TYPE (0x04000000 | C_SPECIALBLOCK_BIT)
432 # ifdef C_DOUBLE_IS_32_BITS
433 # define C_FLONUM_TYPE (0x05000000 | C_BYTEBLOCK_BIT)
434 # else
435 # define C_FLONUM_TYPE (0x05000000 | C_BYTEBLOCK_BIT | C_8ALIGN_BIT)
436 # endif
437 # define C_BIGNUM_TYPE (0x06000000) /* Just the wrapper */
438 # define C_PORT_TYPE (0x07000000 | C_SPECIALBLOCK_BIT)
439 # define C_STRUCTURE_TYPE (0x08000000)
440 # define C_POINTER_TYPE (0x09000000 | C_SPECIALBLOCK_BIT)
441 # define C_LOCATIVE_TYPE (0x0a000000 | C_SPECIALBLOCK_BIT)
442 # define C_TAGGED_POINTER_TYPE (0x0b000000 | C_SPECIALBLOCK_BIT)
443 # define C_RATNUM_TYPE (0x0c000000)
444 # define C_LAMBDA_INFO_TYPE (0x0d000000 | C_BYTEBLOCK_BIT)
445 # define C_CPLXNUM_TYPE (0x0e000000)
446 /* unused (0x0f000000 ...) */
447 #endif
448 #define C_VECTOR_TYPE 0x00000000
449 #define C_BYTEVECTOR_TYPE (C_VECTOR_TYPE | C_BYTEBLOCK_BIT | C_8ALIGN_BIT)
450
451 #define C_SIZEOF_LIST(n) ((n) * 3 + 1)
452 #define C_SIZEOF_PAIR 3
453 #define C_SIZEOF_STRING(n) (C_bytestowords(n) + 2)
454 #define C_SIZEOF_SYMBOL 4
455 #define C_SIZEOF_INTERNED_SYMBOL(n) (C_SIZEOF_SYMBOL + C_SIZEOF_PAIR + C_SIZEOF_STRING(n))
456 #ifdef C_DOUBLE_IS_32_BITS
457 # define C_SIZEOF_FLONUM 2
458 #else
459 # define C_SIZEOF_FLONUM 4
460 #endif
461 #define C_SIZEOF_POINTER 2
462 #define C_SIZEOF_TAGGED_POINTER 3
463 #define C_SIZEOF_VECTOR(n) ((n) + 1)
464 #define C_SIZEOF_LOCATIVE 5
465 #define C_SIZEOF_PORT 16
466 #define C_SIZEOF_RATNUM 3
467 #define C_SIZEOF_CPLXNUM 3
468 #define C_SIZEOF_STRUCTURE(n) ((n)+1)
469 #define C_SIZEOF_CLOSURE(n) ((n)+1)
470 #define C_SIZEOF_BYTEVECTOR C_SIZEOF_STRING
471 #define C_SIZEOF_INTERNAL_BIGNUM_VECTOR(n) (C_SIZEOF_VECTOR((n)+1))
472 #define C_internal_bignum_vector(b) (C_block_item(b,0))
473
474 /* This is for convenience and allows flexibility in representation */
475 #define C_SIZEOF_FIX_BIGNUM C_SIZEOF_BIGNUM(1)
476 #define C_SIZEOF_BIGNUM_WRAPPER 2
477 #define C_SIZEOF_BIGNUM(n) (C_SIZEOF_INTERNAL_BIGNUM_VECTOR(n)+C_SIZEOF_BIGNUM_WRAPPER)
478
479 /* Fixed size types have pre-computed header tags */
480 #define C_PAIR_TAG (C_PAIR_TYPE | (C_SIZEOF_PAIR - 1))
481 #define C_WEAK_PAIR_TAG (C_PAIR_TAG | C_SPECIALBLOCK_BIT)
482 #define C_POINTER_TAG (C_POINTER_TYPE | (C_SIZEOF_POINTER - 1))
483 #define C_LOCATIVE_TAG (C_LOCATIVE_TYPE | (C_SIZEOF_LOCATIVE - 1))
484 #define C_TAGGED_POINTER_TAG (C_TAGGED_POINTER_TYPE | (C_SIZEOF_TAGGED_POINTER - 1))
485 #define C_SYMBOL_TAG (C_SYMBOL_TYPE | (C_SIZEOF_SYMBOL - 1))
486 #define C_FLONUM_TAG (C_FLONUM_TYPE | sizeof(double))
487 #define C_BIGNUM_TAG (C_BIGNUM_TYPE | 1)
488 #define C_RATNUM_TAG (C_RATNUM_TYPE | 2)
489 #define C_CPLXNUM_TAG (C_CPLXNUM_TYPE | 2)
490
491 /* Locative subtypes */
492 #define C_SLOT_LOCATIVE 0
493 #define C_CHAR_LOCATIVE 1
494 #define C_U8_LOCATIVE 2
495 #define C_S8_LOCATIVE 3
496 #define C_U16_LOCATIVE 4
497 #define C_S16_LOCATIVE 5
498 #define C_U32_LOCATIVE 6
499 #define C_S32_LOCATIVE 7
500 #define C_U64_LOCATIVE 8
501 #define C_S64_LOCATIVE 9
502 #define C_F32_LOCATIVE 10
503 #define C_F64_LOCATIVE 11
504
505 #if defined (__MINGW32__)
506 # define C_s64 __int64
507 # define C_u64 unsigned __int64
508 #else
509 # define C_s64 int64_t
510 # define C_u64 uint64_t
511 #endif
512
513 #ifdef C_SIXTY_FOUR
514 # ifdef C_LLP
515 # define C_word C_s64
516 # define C_hword long
517 # else
518 # define C_word long
519 # define C_hword int
520 # endif
521 # define C_u32 uint32_t
522 # define C_s32 int32_t
523 #else
524 # define C_word int
525 # define C_hword short
526 # define C_u32 unsigned int
527 # define C_s32 int
528 #endif
529
530 #define C_char char
531 #define C_uchar unsigned C_char
532 #define C_byte char
533 #define C_uword unsigned C_word
534 #define C_uhword unsigned C_hword
535 #define C_header C_uword
536
537 /* if all else fails, use these:
538 #define UINT64_MAX (18446744073709551615ULL)
539 #define INT64_MAX (9223372036854775807LL)
540 #define INT64_MIN (-INT64_MAX - 1)
541 #define UINT32_MAX (4294967295U)
542 #define INT32_MAX (2147483647)
543 #define INT32_MIN (-INT32_MAX - 1)
544 #define UINT16_MAX (65535U)
545 #define INT16_MAX (32767)
546 #define INT16_MIN (-INT16_MAX - 1)
547 #define UINT8_MAX (255)
548 #define INT8_MAX (127)
549 #define INT8_MIN (-INT8_MAX - 1)
550 */
551
552 #define C_U64_MAX UINT64_MAX
553 #define C_S64_MIN INT64_MIN
554 #define C_S64_MAX INT64_MAX
555
556 #if defined(C_LLP)
557 # define C_wabs llabs
558 # define C_long C_s64
559 # ifndef LONG_LONG_MAX
560 # define C_LONG_MAX LLONG_MAX
561 # define C_LONG_MIN LLONG_MIN
562 # else
563 # define C_LONG_MAX LONG_LONG_MAX
564 # define C_LONG_MIN LONG_LONG_MIN
565 # endif
566 #else
567 # define C_wabs labs
568 # define C_long long
569 # define C_LONG_MAX LONG_MAX
570 # define C_LONG_MIN LONG_MIN
571 #endif
572
573 #define C_ulong unsigned C_long
574
575 #ifdef __cplusplus
576 # define C_text(x) ((C_char *)(x))
577 #else
578 # define C_text(x) (x)
579 #endif
580
581 #define C_TIMER_INTERRUPT_NUMBER 255
582
583 #define C_BAD_ARGUMENT_COUNT_ERROR 1
584 #define C_BAD_MINIMUM_ARGUMENT_COUNT_ERROR 2
585 #define C_BAD_ARGUMENT_TYPE_ERROR 3
586 #define C_UNBOUND_VARIABLE_ERROR 4
587 #define C_BAD_ARGUMENT_TYPE_NO_KEYWORD_ERROR 5
588 #define C_OUT_OF_MEMORY_ERROR 6
589 #define C_DIVISION_BY_ZERO_ERROR 7
590 #define C_OUT_OF_RANGE_ERROR 8
591 #define C_NOT_A_CLOSURE_ERROR 9
592 #define C_CONTINUATION_CANT_RECEIVE_VALUES_ERROR 10
593 #define C_BAD_ARGUMENT_TYPE_CYCLIC_LIST_ERROR 11
594 #define C_TOO_DEEP_RECURSION_ERROR 12
595 #define C_CANT_REPRESENT_INEXACT_ERROR 13
596 #define C_NOT_A_PROPER_LIST_ERROR 14
597 #define C_BAD_ARGUMENT_TYPE_NO_FIXNUM_ERROR 15
598 #define C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR 16
599 #define C_BAD_ARGUMENT_TYPE_NO_STRING_ERROR 17
600 #define C_BAD_ARGUMENT_TYPE_NO_PAIR_ERROR 18
601 #define C_BAD_ARGUMENT_TYPE_NO_LIST_ERROR 19
602 #define C_BAD_ARGUMENT_TYPE_NO_CHAR_ERROR 20
603 #define C_BAD_ARGUMENT_TYPE_NO_VECTOR_ERROR 21
604 #define C_BAD_ARGUMENT_TYPE_NO_SYMBOL_ERROR 22
605 #define C_STACK_OVERFLOW_ERROR 23
606 #define C_BAD_ARGUMENT_TYPE_BAD_STRUCT_ERROR 24
607 #define C_BAD_ARGUMENT_TYPE_NO_BYTEVECTOR_ERROR 25
608 #define C_LOST_LOCATIVE_ERROR 26
609 #define C_BAD_ARGUMENT_TYPE_NO_BLOCK_ERROR 27
610 #define C_BAD_ARGUMENT_TYPE_NO_NUMBER_VECTOR_ERROR 28
611 #define C_BAD_ARGUMENT_TYPE_NO_INTEGER_ERROR 29
612 #define C_BAD_ARGUMENT_TYPE_NO_UINTEGER_ERROR 30
613 #define C_BAD_ARGUMENT_TYPE_NO_POINTER_ERROR 31
614 #define C_BAD_ARGUMENT_TYPE_NO_TAGGED_POINTER_ERROR 32
615 #define C_BAD_ARGUMENT_TYPE_NO_FLONUM_ERROR 33
616 #define C_BAD_ARGUMENT_TYPE_NO_CLOSURE_ERROR 34
617 #define C_BAD_ARGUMENT_TYPE_BAD_BASE_ERROR 35
618 #define C_CIRCULAR_DATA_ERROR 36
619 #define C_BAD_ARGUMENT_TYPE_NO_BOOLEAN_ERROR 37
620 #define C_BAD_ARGUMENT_TYPE_NO_LOCATIVE_ERROR 38
621 #define C_BAD_ARGUMENT_TYPE_NO_PORT_ERROR 39
622 #define C_BAD_ARGUMENT_TYPE_PORT_DIRECTION_ERROR 40
623 #define C_BAD_ARGUMENT_TYPE_PORT_NO_INPUT_ERROR 41
624 #define C_BAD_ARGUMENT_TYPE_PORT_NO_OUTPUT_ERROR 42
625 #define C_PORT_CLOSED_ERROR 43
626 #define C_ASCIIZ_REPRESENTATION_ERROR 44
627 #define C_MEMORY_VIOLATION_ERROR 45
628 #define C_FLOATING_POINT_EXCEPTION_ERROR 46
629 #define C_ILLEGAL_INSTRUCTION_ERROR 47
630 #define C_BUS_ERROR 48
631 #define C_BAD_ARGUMENT_TYPE_NO_EXACT_ERROR 49
632 #define C_BAD_ARGUMENT_TYPE_NO_INEXACT_ERROR 50
633 #define C_BAD_ARGUMENT_TYPE_NO_REAL_ERROR 51
634 #define C_BAD_ARGUMENT_TYPE_COMPLEX_NO_ORDERING_ERROR 52
635 #define C_BAD_ARGUMENT_TYPE_NO_EXACT_INTEGER_ERROR 53
636 #define C_BAD_ARGUMENT_TYPE_FOREIGN_LIMITATION 54
637 #define C_BAD_ARGUMENT_TYPE_COMPLEX_ABS 55
638 #define C_REST_ARG_OUT_OF_BOUNDS_ERROR 56
639
640 /* Platform information */
641 #if defined(C_BIG_ENDIAN)
642 # define C_MACHINE_BYTE_ORDER "big-endian"
643 #elif defined(C_LITTLE_ENDIAN)
644 # define C_MACHINE_BYTE_ORDER "little-endian"
645 #endif
646
647 #if defined(__alpha__)
648 # define C_MACHINE_TYPE "alpha"
649 #elif defined(__mips__)
650 # define C_MACHINE_TYPE "mips"
651 #elif defined(__hppa__)
652 # define C_MACHINE_TYPE "hppa"
653 #elif defined(__sparc_v9__) || defined(__sparcv9)
654 # define C_MACHINE_TYPE "ultrasparc"
655 #elif defined(__sparc__)
656 # define C_MACHINE_TYPE "sparc"
657 #elif defined(__powerpc64__) || defined(_ARCH_PPC64)
658 # define C_MACHINE_TYPE "ppc64"
659 #elif defined(__ppc__) || defined(__powerpc__) || defined(_ARCH_PPC)
660 # define C_MACHINE_TYPE "ppc"
661 #elif defined(_M_IX86) || defined(__i386__)
662 # define C_MACHINE_TYPE "x86"
663 #elif defined(__ia64__)
664 # define C_MACHINE_TYPE "ia64"
665 #elif defined(__x86_64__)
666 # define C_MACHINE_TYPE "x86-64"
667 #elif defined(__riscv)
668 # if defined(__LP64__) || defined(_LP64)
669 # define C_MACHINE_TYPE "riscv64"
670 # else
671 # define C_MACHINE_TYPE "riscv"
672 # endif
673 #elif defined(__arm64__) || defined(__aarch64__)
674 # define C_MACHINE_TYPE "arm64"
675 #elif defined(__arm__)
676 # define C_MACHINE_TYPE "arm"
677 #else
678 # define C_MACHINE_TYPE "unknown"
679 #endif
680
681 #if defined(__CYGWIN__) || defined(__MINGW32__) || defined(_WIN32) || defined(__WINNT__)
682 # define C_SOFTWARE_TYPE "windows"
683 #elif defined(__ANDROID__)
684 # define C_SOFTWARE_TYPE "android"
685 #elif defined(__unix__) || defined(C_XXXBSD) || defined(_AIX)
686 # define C_SOFTWARE_TYPE "unix"
687 #elif defined(ECOS)
688 # define C_SOFTWARE_TYPE "ecos"
689 #else
690 # define C_SOFTWARE_TYPE "unknown"
691 #endif
692
693 #if defined(__SUNPRO_C)
694 # define C_BUILD_PLATFORM "sun"
695 #elif defined(__clang__)
696 # define C_BUILD_PLATFORM "clang"
697 #elif defined(_AIX)
698 # define C_BUILD_PLATFORM "aix"
699 #elif defined(__GNUC__)
700 # define C_BUILD_PLATFORM "gnu"
701 #elif defined(__INTEL_COMPILER)
702 # define C_BUILD_PLATFORM "intel"
703 #else
704 # define C_BUILD_PLATFORM "unknown"
705 #endif
706
707 #if defined(__linux__)
708 # define C_SOFTWARE_VERSION "linux"
709 #elif defined(__FreeBSD__)
710 # define C_SOFTWARE_VERSION "freebsd"
711 #elif defined(__NetBSD__)
712 # define C_SOFTWARE_VERSION "netbsd"
713 #elif defined(__OpenBSD__)
714 # define C_SOFTWARE_VERSION "openbsd"
715 #elif defined(C_MACOSX)
716 # define C_SOFTWARE_VERSION "macosx"
717 #elif defined(__hpux__)
718 # define C_SOFTWARE_VERSION "hpux"
719 #elif defined(__DragonFly__)
720 # define C_SOFTWARE_VERSION "dragonfly"
721 #elif defined(__HAIKU__)
722 # define C_SOFTWARE_VERSION "haiku"
723 #elif defined(__sun)
724 # if defined(__SVR4)
725 # define C_SOFTWARE_VERSION "solaris"
726 # else
727 # define C_SOFTWARE_VERSION "sunos"
728 # endif
729 #elif defined(_AIX)
730 # define C_SOFTWARE_VERSION "aix"
731 #elif defined(__GNU__)
732 # define C_SOFTWARE_VERSION "hurd"
733 #elif defined(__CYGWIN__)
734 # define C_SOFTWARE_VERSION "cygwin"
735 #elif defined(__MINGW32__)
736 # define C_SOFTWARE_VERSION "mingw32"
737 #else
738 # define C_SOFTWARE_VERSION "unknown"
739 #endif
740
741 /* There is no PATH_MAX in The Hurd. */
742 #ifdef PATH_MAX
743 # define C_MAX_PATH PATH_MAX
744 #else
745 # define C_MAX_PATH 1024
746 #endif
747
748 #define C_RANDOM_STATE_SIZE (16 * sizeof(C_uword))
749
750 /* Types: */
751
752 typedef struct C_block_struct
753 {
754 C_header header;
755 C_word data[];
756 } C_SCHEME_BLOCK;
757
758 typedef struct C_symbol_table_struct
759 {
760 char *name;
761 unsigned int size;
762 unsigned int rand;
763 C_word *table;
764 struct C_symbol_table_struct *next;
765 } C_SYMBOL_TABLE;
766
767 typedef struct C_gc_root_struct
768 {
769 C_word value;
770 struct C_gc_root_struct *next, *prev;
771 int finalizable;
772 } C_GC_ROOT;
773
774 typedef struct C_ptable_entry_struct
775 {
776 C_char *id;
777 void *ptr;
778 } C_PTABLE_ENTRY;
779
780 typedef void (C_ccall *C_proc)(C_word, C_word *) C_noret;
781
782
783 /* Macros: */
784
785 #define C_cpsproc(name) C_ccall void name(C_word c, C_word *av) C_noret
786
787 #define CHICKEN_gc_root_ref(root) (((C_GC_ROOT *)(root))->value)
788 #define CHICKEN_gc_root_set(root, x) C_mutate(&((C_GC_ROOT *)(root))->value, (x))
789
790 #define CHICKEN_global_ref(root) C_u_i_car(((C_GC_ROOT *)(root))->value)
791 #define CHICKEN_global_set(root, x) C_mutate(&C_u_i_car(((C_GC_ROOT *)(root))->value), (x))
792
793 #define CHICKEN_default_toplevel ((void *)C_default_5fstub_toplevel)
794
795 #define C__STR1(x) #x
796 #define C__STR2(x) C__STR1(x)
797
798 #define C_align4(n) (((n) + 3) & ~3)
799 #define C_align8(n) (((n) + 7) & ~7)
800 #define C_align16(n) (((n) + 15) & ~15)
801
802 #define C_aligned8(n) ((((C_word)(n)) & 7) == 0)
803
804 #define C_buf_end(b) ((C_word *)((C_byte *)(b) + sizeof(b)))
805
806 /* This is word-size dependent: */
807 #ifdef C_SIXTY_FOUR
808 # define C_align(n) C_align8(n)
809 # define C_wordstobytes(n) ((C_uword)(n) << 3)
810 # define C_bytestowords(n) (((n) + 7) >> 3)
811 # define C_wordsperdouble(n) (n)
812 # define C_WORD_MIN LONG_MIN
813 # define C_WORD_MAX LONG_MAX
814 # define C_UWORD_MAX ULONG_MAX
815 #else
816 # define C_align(n) C_align4(n)
817 # define C_wordstobytes(n) ((C_uword)(n) << 2)
818 # define C_bytestowords(n) (((n) + 3) >> 2)
819 # define C_wordsperdouble(n) ((C_uword)(n) << 1)
820 # define C_WORD_MIN INT_MIN
821 # define C_WORD_MAX INT_MAX
822 # define C_UWORD_MAX UINT_MAX
823 #endif
824
825 /* Clang and G++ support statement expressions, but only in a limited way */
826 #if DEBUGBUILD && HAVE_STATEMENT_EXPRESSIONS && !defined(__clang__) && !defined(__cplusplus)
827 /* These are wrappers around the following idiom:
828 * assert(SOME_PRED(obj));
829 * do_something_with(obj);
830 * This works around the fact obj may be an expression with side-effects.
831 *
832 * To make this work with nested expansions, we need semantics like
833 * (let ((x 1)) (let ((x x)) x)) => 1, but in C, int x = x; results in
834 * undefined behaviour because x refers to itself. As a workaround,
835 * we keep around a reference to the previous level (one scope up).
836 * After initialisation, "previous" is redefined to mean "current".
837 */
838 # define C_VAL1(x) C__PREV_TMPST.n1
839 # define C_VAL2(x) C__PREV_TMPST.n2
840 # define C__CHECK_panic(a,s,f,l) \
841 ((a) ? (void)0 : \
842 C_panic_hook(C_text("Low-level type assertion " s " failed at " f ":" C__STR1(l))))
843 # define C__CHECK_core(v,a,s,x) \
844 ({ struct { \
845 typeof(v) n1; \
846 } C__TMPST = { .n1 = (v) }; \
847 typeof(C__TMPST) C__PREV_TMPST=C__TMPST; \
848 C__CHECK_panic(a,s,__FILE__,__LINE__); \
849 x; })
850 # define C__CHECK2_core(v1,v2,a,s,x) \
851 ({ struct { \
852 typeof(v1) n1; \
853 typeof(v2) n2; \
854 } C__TMPST = { .n1 = (v1), .n2 = (v2) }; \
855 typeof(C__TMPST) C__PREV_TMPST=C__TMPST; \
856 C__CHECK_panic(a,s,__FILE__,__LINE__); \
857 x; })
858 # define C_CHECK(v,a,x) C__CHECK_core(v,a,#a,x)
859 # define C_CHECK2(v1,v2,a,x) C__CHECK2_core(v1,v2,a,#a,x)
860 /*
861 * Convenience for using Scheme-predicates.
862 */
863 # define C_CHECKp(v,a,x) C__CHECK_core(v,C_truep(a),#a"=#t",x)
864 # define C_CHECK2p(v1,v2,a,x) C__CHECK2_core(v1,v2,C_truep(a),#a"=#t",x)
865 #else
866 # define C_VAL1(x) (x)
867 # define C_VAL2(x) (x)
868 # define C_CHECK(v,a,x) (x)
869 # define C_CHECK2(v1,v2,a,x) (x)
870 # define C_CHECKp(v,a,x) (x)
871 # define C_CHECK2p(v1,v2,a,x) (x)
872 #endif
873
874 #ifndef C_PROVIDE_LIBC_STUBS
875 # define C_FILEPTR FILE *
876
877 # define C_stdin stdin
878 # define C_stdout stdout
879 # define C_stderr stderr
880
881 # define C_memcpy memcpy
882 # define C_memcmp memcmp
883 # define C_strncpy strncpy
884 # define C_strcmp strcmp
885 # define C_strncmp strncmp
886 # define C_strlen strlen
887 # define C_memchr memchr
888 # define C_memset memset
889 # define C_memmove memmove
890 # define C_strncasecmp strncasecmp
891 # define C_malloc malloc
892 # define C_calloc calloc
893 # define C_free free
894 # define C_strchr strchr
895 # define C_realloc realloc
896 # define C_strdup strdup
897 # define C_strtol strtol
898 # define C_strtoll strtoll
899 # define C_strtod strtod
900 # define C_strtoul strtoul
901 # define C_fopen fopen
902 # define C_fclose fclose
903 # define C_strpbrk strpbrk
904 # define C_strcspn strcspn
905 # define C_snprintf snprintf
906 # define C_printf printf
907 # define C_fprintf fprintf
908 # define C_vfprintf vfprintf
909 # define C_fflush fflush
910 # define C_getchar getchar
911 # define C_exit exit
912 # define C__exit _exit
913 # define C_dlopen dlopen
914 # define C_dlclose dlclose
915 # define C_dlsym dlsym
916 # define C_fwrite fwrite
917 # define C_fread fread
918 # define C_fputs fputs
919 # define C_fputc fputc
920 # define C_putchar putchar
921 # if (defined getc_unlocked || _POSIX_C_SOURCE >= 199506L) && !defined(__MINGW32__)
922 # define C_getc getc_unlocked
923 # else
924 # define C_getc getc
925 # endif
926 # define C_fgetc fgetc
927 # define C_fgets fgets
928 # define C_ungetc ungetc
929 # define C_system system
930 # define C_isatty isatty
931 # define C_fileno fileno
932 # define C_select select
933 # if defined(HAVE_SIGACTION)
934 # define C_sigaction sigaction
935 # endif
936 # define C_signal signal
937 # define C_getrusage getrusage
938 # define C_tolower tolower
939 # define C_toupper toupper
940 # define C_gettimeofday gettimeofday
941 # define C_gmtime gmtime
942 # define C_localtime localtime
943 /*
944 * It is undefined whether regular setjmp/longjmp save/restore signal mask
945 * so try to use versions that we know won't try to save & restore.
946 */
947 # if defined(HAVE_SIGSETJMP)
948 # define C_sigsetjmp sigsetjmp
949 # define C_siglongjmp siglongjmp
950 # endif
951 # ifdef HAVE_SIGPROCMASK
952 # define C_sigprocmask sigprocmask
953 # endif
954 # define C_setjmp setjmp
955 # define C_longjmp longjmp
956 # define C_alloca alloca
957 # define C_strerror strerror
958 # define C_isalpha isalpha
959 # define C_isdigit isdigit
960 # define C_isspace isspace
961 # define C_islower islower
962 # define C_isupper isupper
963 # define C_sin sin
964 # define C_cos cos
965 # define C_tan tan
966 # define C_asin asin
967 # define C_acos acos
968 # define C_atan atan
969 # define C_atan2 atan2
970 # define C_log log
971 # define C_exp exp
972 # define C_pow pow
973 # define C_sqrt sqrt
974 # define C_ceil ceil
975 # define C_floor floor
976 # define C_round round
977 # define C_trunc trunc
978 # define C_fabs fabs
979 # define C_modf modf
980 # define C_readlink readlink
981 # define C_getcwd getcwd
982 # define C_access access
983 # define C_getpid getpid
984 # define C_getenv getenv
985 #else
986 /* provide this file and define C_PROVIDE_LIBC_STUBS if you want to use
987 your own libc-replacements or -wrappers */
988 # include "chicken-libc-stubs.h"
989 #endif
990
991 #ifdef C_LLP
992 # define C_strtow C_strtoll
993 #else
994 # define C_strtow C_strtol
995 #endif
996
997 #define C_return(x) return(x)
998 #define C_resize_stack(n) C_do_resize_stack(n)
999 #define C_memcpy_slots(t, f, n) C_memcpy((t), (f), (n) * sizeof(C_word))
1000 /* Without check: initialisation of a newly allocated header */
1001 #define C_block_header_init(x,h) (((C_SCHEME_BLOCK *)(x))->header = (h))
1002 /* These two must result in an lvalue, hence the (*foo(&bar)) faffery */
1003 #define C_block_header(x) (*C_CHECKp(x,C_blockp((C_word)C_VAL1(x)),&(((C_SCHEME_BLOCK *)(C_VAL1(x)))->header)))
1004 #define C_block_item(x,i) (*C_CHECK2(x,i,(C_header_size(C_VAL1(x))>(C_VAL2(i))),&(((C_SCHEME_BLOCK *)(C_VAL1(x)))->data [ C_VAL2(i) ])))
1005 #define C_set_block_item(x,i,y) (C_block_item(x, i) = (y))
1006 #define C_header_bits(bh) (C_block_header(bh) & C_HEADER_BITS_MASK)
1007 #define C_header_size(bh) (C_block_header(bh) & C_HEADER_SIZE_MASK)
1008 #define C_bignum_size(b) (C_bytestowords(C_header_size(C_internal_bignum_vector(b)))-1)
1009 #define C_make_header(type, size) ((C_header)(((type) & C_HEADER_BITS_MASK) | ((size) & C_HEADER_SIZE_MASK)))
1010 #define C_symbol_value(x) (C_block_item(x, 0))
1011 #define C_symbol_name(x) (C_block_item(x, 1))
1012 #define C_symbol_plist(x) (C_block_item(x, 2))
1013 #define C_save(x) (*(--C_temporary_stack) = (C_word)(x))
1014 #define C_rescue(x, i) (C_temporary_stack[ i ] = (x))
1015 #define C_restore (*(C_temporary_stack++))
1016 #define C_heaptop ((C_word **)(&C_fromspace_top))
1017 #define C_drop(n) (C_temporary_stack += (n))
1018 #define C_alloc(n) ((C_word *)C_alloca((n) * sizeof(C_word)))
1019 #if (defined (__llvm__) && defined (__GNUC__)) || defined (__TINYC__)
1020 # if defined (__i386__)
1021 # define C_stack_pointer ({C_word *sp; __asm__ __volatile__("movl %%esp,%0":"=r"(sp):);sp;})
1022 # elif defined (__x86_64__)
1023 # define C_stack_pointer ({C_word *sp; __asm__ __volatile__("movq %%rsp,%0":"=r"(sp):);sp;})
1024 # else
1025 /* Not alloca(0) because:
1026 * - LLVM allocates anyways
1027 * - TCC always returns NULL
1028 */
1029 # define C_stack_pointer ((C_word *)C_alloca(1))
1030 # endif
1031 #else
1032 # define C_stack_pointer ((C_word *)C_alloca(0))
1033 #endif
1034 #define C_stack_pointer_test ((C_word *)C_alloca(1))
1035 #define C_demand_2(n) (((C_word *)C_fromspace_top + (n)) < (C_word *)C_fromspace_limit)
1036 #define C_calculate_demand(n,c,m) ((n) + (((c) > (m)) ? 0 : (m)))
1037 #define C_fix(n) ((C_word)((C_uword)(n) << C_FIXNUM_SHIFT) | C_FIXNUM_BIT)
1038 #define C_unfix(x) C_CHECKp(x,C_fixnump(C_VAL1(x)),((C_VAL1(x)) >> C_FIXNUM_SHIFT))
1039 #define C_make_character(c) (((((C_uword)(c)) & C_CHAR_BIT_MASK) << C_CHAR_SHIFT) | C_CHARACTER_BITS)
1040 #define C_character_code(x) C_CHECKp(x,C_charp(C_VAL1(x)),((C_word)(C_VAL1(x)) >> C_CHAR_SHIFT) & C_CHAR_BIT_MASK)
1041 #define C_flonum_magnitude(x) (*C_CHECKp(x,C_flonump(C_VAL1(x)),(double *)C_data_pointer(C_VAL1(x))))
1042 /* XXX Sometimes this is (ab)used on bytevectors (ie, blob=? uses string_compare) */
1043 #define C_c_string(x) C_CHECK(x,(C_truep(C_stringp(C_VAL1(x))) || C_truep(C_bytevectorp(C_VAL1(x)))),(C_char *)C_data_pointer(C_VAL1(x)))
1044
1045 #define C_c_pointer(x) ((void *)(x))
1046 #define C_c_pointer_nn(x) ((void *)C_block_item(x, 0))
1047 #define C_truep(x) ((x) != C_SCHEME_FALSE)
1048 #define C_immediatep(x) ((x) & C_IMMEDIATE_MARK_BITS)
1049 #define C_mk_bool(x) ((x) ? C_SCHEME_TRUE : C_SCHEME_FALSE)
1050 #define C_mk_nbool(x) ((x) ? C_SCHEME_FALSE : C_SCHEME_TRUE)
1051 #define C_port_file(p) C_CHECKp(p,C_portp(C_VAL1(p)),(C_FILEPTR)C_block_item(C_VAL1(p), 0))
1052 #define C_port_fileno(p) C_fix(C_fileno(C_port_file(p)))
1053 #define C_data_pointer(b) C_CHECKp(b,C_blockp((C_word)C_VAL1(b)),(void *)(((C_SCHEME_BLOCK *)(C_VAL1(b)))->data))
1054 #define C_bignum_negativep(b) C_CHECKp(b,C_bignump(C_VAL1(b)),(C_block_item(C_internal_bignum_vector(C_VAL1(b)),0)!=0))
1055 #define C_bignum_digits(b) C_CHECKp(b,C_bignump(C_VAL1(b)),(((C_uword *)C_data_pointer(C_internal_bignum_vector(C_VAL1(b))))+1))
1056 #define C_fitsinbignumhalfdigitp(n)(C_BIGNUM_DIGIT_HI_HALF(n) == 0)
1057 #define C_bignum_negated_fitsinfixnump(b) (C_bignum_size(b) == 1 && (C_bignum_negativep(b) ? C_ufitsinfixnump(*C_bignum_digits(b)) : !(*C_bignum_digits(b) & C_INT_SIGN_BIT) && C_fitsinfixnump(-(C_word)*C_bignum_digits(b))))
1058 #define C_bignum_mutate_size(b, s) (C_block_header(C_internal_bignum_vector(b)) = (C_STRING_TYPE | C_wordstobytes((s)+1)))
1059 #define C_fitsinfixnump(n) (((n) & C_INT_SIGN_BIT) == (((C_uword)(n) & C_INT_TOP_BIT) << 1))
1060 #define C_ufitsinfixnump(n) (((n) & (C_INT_SIGN_BIT | (C_INT_SIGN_BIT >> 1))) == 0)
1061 #define C_and(x, y) (C_truep(x) ? (y) : C_SCHEME_FALSE)
1062 #define C_c_bytevector(x) ((unsigned char *)C_data_pointer(x))
1063 #define C_c_bytevector_or_null(x) ((unsigned char *)C_data_pointer_or_null(x))
1064 #define C_srfi_4_vector(x) C_data_pointer(C_block_item(x,1))
1065 #define C_c_u8vector(x) ((unsigned char *)C_srfi_4_vector(x))
1066 #define C_c_u8vector_or_null(x) ((unsigned char *)C_srfi_4_vector_or_null(x))
1067 #define C_c_s8vector(x) ((signed char *)C_srfi_4_vector(x))
1068 #define C_c_s8vector_or_null(x) ((signed char *)C_srfi_4_vector_or_null(x))
1069 #define C_c_u16vector(x) ((unsigned short *)C_srfi_4_vector(x))
1070 #define C_c_u16vector_or_null(x) ((unsigned short *)C_srfi_4_vector_or_null(x))
1071 #define C_c_s16vector(x) ((short *)C_srfi_4_vector(x))
1072 #define C_c_s16vector_or_null(x) ((short *)C_srfi_4_vector_or_null(x))
1073 #define C_c_u32vector(x) ((C_u32 *)C_srfi_4_vector(x))
1074 #define C_c_u32vector_or_null(x) ((C_u32 *)C_srfi_4_vector_or_null(x))
1075 #define C_c_s32vector(x) ((C_s32 *)C_srfi_4_vector(x))
1076 #define C_c_s32vector_or_null(x) ((C_s32 *)C_srfi_4_vector_or_null(x))
1077 #define C_c_u64vector(x) ((C_u64 *)C_srfi_4_vector(x))
1078 #define C_c_u64vector_or_null(x) ((C_u64 *)C_srfi_4_vector_or_null(x))
1079 #define C_c_s64vector(x) ((C_s64 *)C_srfi_4_vector(x))
1080 #define C_c_s64vector_or_null(x) ((C_s64 *)C_srfi_4_vector_or_null(x))
1081 #define C_c_f32vector(x) ((float *)C_srfi_4_vector(x))
1082 #define C_c_f32vector_or_null(x) ((float *)C_srfi_4_vector_or_null(x))
1083 #define C_c_f64vector(x) ((double *)C_srfi_4_vector(x))
1084 #define C_c_f64vector_or_null(x) ((double *)C_srfi_4_vector_or_null(x))
1085 #define C_c_pointer_vector(x) ((void **)C_data_pointer(C_block_item((x), 2)))
1086
1087 #define C_isnan(f) isnan(f)
1088 #define C_isinf(f) isinf(f)
1089 #define C_isfinite(f) isfinite(f)
1090
1091 #define C_stack_overflow_check C_stack_check1(C_stack_overflow(NULL))
1092
1093 /* TODO: The C_scratch_usage checks should probably be moved. Maybe
1094 * we should add a core#allocate_scratch_inline which will insert
1095 * C_demand/C_stack_probe-like checks to copy the result onto the
1096 * stack or reclaim, but in a clever way so it's only done at the
1097 * "end" of a C function.
1098 */
1099 #if C_STACK_GROWS_DOWNWARD
1100 # define C_demand(n) ((C_word)(C_stack_pointer - C_stack_limit) > ((n)+C_scratch_usage))
1101 # define C_stack_check1(err) if(!C_disable_overflow_check) { \
1102 do { C_byte *_sp = (C_byte*)(C_stack_pointer); \
1103 if(_sp < (C_byte *)C_stack_hard_limit && \
1104 ((C_byte *)C_stack_hard_limit - _sp) > C_STACK_RESERVE) \
1105 err; } \
1106 while(0);}
1107
1108 #else
1109 # define C_demand(n) ((C_word)(C_stack_limit - C_stack_pointer) > ((n)+C_scratch_usage))
1110 # define C_stack_check1(err) if(!C_disable_overflow_check) { \
1111 do { C_byte *_sp = (C_byte*)(C_stack_pointer); \
1112 if(_sp > (C_byte *)C_stack_hard_limit && \
1113 (_sp - (C_byte *)C_stack_hard_limit) > C_STACK_RESERVE) \
1114 err; } \
1115 while(0);}
1116
1117 #endif
1118
1119 #define C_zero_length_p(x) C_mk_bool(C_header_size(x) == 0)
1120 #define C_boundp(x) C_mk_bool(C_block_item(x, 0) != C_SCHEME_UNBOUND)
1121 #define C_unboundvaluep(x) C_mk_bool((x) == C_SCHEME_UNBOUND)
1122 #define C_blockp(x) C_mk_bool(!C_immediatep(x))
1123 #define C_forwardedp(x) C_mk_bool((C_block_header(x) & C_GC_FORWARDING_BIT) != 0)
1124 #define C_immp(x) C_mk_bool(C_immediatep(x))
1125 #define C_flonump(x) C_mk_bool(C_block_header(x) == C_FLONUM_TAG)
1126 #define C_bignump(x) C_mk_bool(C_block_header(x) == C_BIGNUM_TAG)
1127 #define C_stringp(x) C_mk_bool(C_header_bits(x) == C_STRING_TYPE)
1128 #define C_symbolp(x) C_mk_bool(C_block_header(x) == C_SYMBOL_TAG)
1129 #define C_pairp(x) C_mk_bool(C_block_header(x) == C_PAIR_TAG)
1130 #define C_closurep(x) C_mk_bool(C_header_bits(x) == C_CLOSURE_TYPE)
1131 #define C_vectorp(x) C_mk_bool(C_header_bits(x) == C_VECTOR_TYPE)
1132 #define C_bytevectorp(x) C_mk_bool(C_header_bits(x) == C_BYTEVECTOR_TYPE)
1133 #define C_portp(x) C_mk_bool(C_header_bits(x) == C_PORT_TYPE)
1134 #define C_structurep(x) C_mk_bool(C_header_bits(x) == C_STRUCTURE_TYPE)
1135 #define C_locativep(x) C_mk_bool(C_block_header(x) == C_LOCATIVE_TAG)
1136 #define C_charp(x) C_mk_bool(((x) & C_IMMEDIATE_TYPE_BITS) == C_CHARACTER_BITS)
1137 #define C_booleanp(x) C_mk_bool(((x) & C_IMMEDIATE_TYPE_BITS) == C_BOOLEAN_BITS)
1138 #define C_eofp(x) C_mk_bool((x) == C_SCHEME_END_OF_FILE)
1139 #define C_undefinedp(x) C_mk_bool((x) == C_SCHEME_UNDEFINED)
1140 #define C_fixnump(x) C_mk_bool((x) & C_FIXNUM_BIT)
1141 #define C_nfixnump(x) C_mk_nbool((x) & C_FIXNUM_BIT)
1142 #define C_pointerp(x) C_mk_bool(C_block_header(x) == C_POINTER_TAG)
1143 #define C_taggedpointerp(x) C_mk_bool(C_block_header(x) == C_TAGGED_POINTER_TAG)
1144 #define C_lambdainfop(x) C_mk_bool(C_header_bits(x) == C_LAMBDA_INFO_TYPE)
1145 #define C_anypointerp(x) C_mk_bool(C_block_header(x) == C_POINTER_TAG || C_block_header(x) == C_TAGGED_POINTER_TAG)
1146 #define C_specialp(x) C_mk_bool(C_header_bits(x) & C_SPECIALBLOCK_BIT)
1147 #define C_byteblockp(x) C_mk_bool(C_header_bits(x) & C_BYTEBLOCK_BIT)
1148 #define C_sametypep(x, y) C_mk_bool(C_header_bits(x) == C_header_bits(y))
1149 #define C_eqp(x, y) C_mk_bool((x) == (y))
1150 #define C_vemptyp(x) C_mk_bool(C_header_size(x) == 0)
1151 #define C_notvemptyp(x) C_mk_bool(C_header_size(x) > 0)
1152
1153 #define C_port_typep(x, n) C_mk_bool((C_block_item(x, 1) & n) == n)
1154 #define C_input_portp(x) C_and(C_portp(x), C_port_typep(x, 0x2))
1155 #define C_output_portp(x) C_and(C_portp(x), C_port_typep(x, 0x4))
1156
1157 #define C_port_openp(port, n) C_mk_bool((C_block_item(port, 8) & n) == n)
1158 #define C_input_port_openp(port) C_port_openp(port, 0x2)
1159 #define C_output_port_openp(port) C_port_openp(port, 0x4)
1160
1161 #define C_slot(x, i) C_block_item(x, C_unfix(i))
1162 #define C_subbyte(x, i) C_fix(((C_byte *)C_data_pointer(x))[ C_unfix(i) ] & 0xff)
1163 #define C_subchar(x, i) C_make_character(((C_uchar *)C_data_pointer(x))[ C_unfix(i) ])
1164 #define C_setbyte(x, i, n) (((C_byte *)C_data_pointer(x))[ C_unfix(i) ] = C_unfix(n), C_SCHEME_UNDEFINED)
1165 #define C_setsubchar(x, i, n) (((C_char *)C_data_pointer(x))[ C_unfix(i) ] = C_character_code(n), C_SCHEME_UNDEFINED)
1166 #define C_setsubbyte(x, i, n) (((C_char *)C_data_pointer(x))[ C_unfix(i) ] = C_unfix(n), C_SCHEME_UNDEFINED)
1167
1168 #define C_fixnum_times(n1, n2) (C_fix(C_unfix(n1) * C_unfix(n2)))
1169 #define C_u_fixnum_plus(n1, n2) (((n1) - C_FIXNUM_BIT) + (n2))
1170 #define C_fixnum_plus(n1, n2) (C_u_fixnum_plus(n1, n2) | C_FIXNUM_BIT)
1171 #define C_u_fixnum_difference(n1, n2) ((n1) - (n2) + C_FIXNUM_BIT)
1172 #define C_fixnum_difference(n1, n2) (C_u_fixnum_difference(n1, n2) | C_FIXNUM_BIT)
1173 #define C_u_fixnum_divide(n1, n2) (C_fix(C_unfix(n1) / C_unfix(n2)))
1174 #define C_u_fixnum_and(n1, n2) ((n1) & (n2))
1175 #define C_fixnum_and(n1, n2) (C_u_fixnum_and(n1, n2) | C_FIXNUM_BIT)
1176 #define C_u_fixnum_or(n1, n2) ((n1) | (n2))
1177 #define C_fixnum_or(n1, n2) C_u_fixnum_or(n1, n2)
1178 #define C_fixnum_xor(n1, n2) (((n1) ^ (n2)) | C_FIXNUM_BIT)
1179 #define C_fixnum_not(n) ((~(n)) | C_FIXNUM_BIT)
1180 #define C_fixnum_shift_left(n1, n2) (C_fix(((C_uword)C_unfix(n1) << (C_uword)C_unfix(n2))))
1181 #define C_fixnum_shift_right(n1, n2) (((n1) >> (C_uword)C_unfix(n2)) | C_FIXNUM_BIT)
1182 #define C_u_fixnum_negate(n) (-(n) + 2 * C_FIXNUM_BIT)
1183 #define C_fixnum_negate(n) (C_u_fixnum_negate(n) | C_FIXNUM_BIT)
1184 #define C_fixnum_greaterp(n1, n2) (C_mk_bool((C_word)(n1) > (C_word)(n2)))
1185 #define C_fixnum_lessp(n1, n2) (C_mk_bool((C_word)(n1) < (C_word)(n2)))
1186 #define C_fixnum_greater_or_equal_p(n1, n2) (C_mk_bool((C_word)(n1) >= (C_word)(n2)))
1187 #define C_fixnum_less_or_equal_p(n1, n2)(C_mk_bool((C_word)(n1) <= (C_word)(n2)))
1188 #define C_u_fixnum_increase(n) ((n) + (1 << C_FIXNUM_SHIFT))
1189 #define C_fixnum_increase(n) (C_u_fixnum_increase(n) | C_FIXNUM_BIT)
1190 #define C_u_fixnum_decrease(n) ((n) - (1 << C_FIXNUM_SHIFT))
1191 #define C_fixnum_decrease(n) (C_u_fixnum_decrease(n) | C_FIXNUM_BIT)
1192 /* XXX TODO: This should probably be renamed C_u_fixnum_abs or something */
1193 #define C_fixnum_abs(n) C_fix(abs(C_unfix(n)))
1194 #define C_a_i_fixnum_abs(ptr, n, x) (((x) & C_INT_SIGN_BIT) ? C_a_i_fixnum_negate((ptr), (n), (x)) : (x))
1195 #define C_i_fixnum_signum(x) ((x) == C_fix(0) ? (x) : (((x) & C_INT_SIGN_BIT) ? C_fix(-1) : C_fix(1)))
1196 #define C_i_fixnum_length(x) C_fix(C_ilen(((x) & C_INT_SIGN_BIT) ? ~C_unfix(x) : C_unfix(x)))
1197
1198 #define C_flonum_equalp(n1, n2) C_mk_bool(C_flonum_magnitude(n1) == C_flonum_magnitude(n2))
1199 #define C_flonum_greaterp(n1, n2) C_mk_bool(C_flonum_magnitude(n1) > C_flonum_magnitude(n2))
1200 #define C_flonum_lessp(n1, n2) C_mk_bool(C_flonum_magnitude(n1) < C_flonum_magnitude(n2))
1201 #define C_flonum_greater_or_equal_p(n1, n2) C_mk_bool(C_flonum_magnitude(n1) >= C_flonum_magnitude(n2))
1202 #define C_flonum_less_or_equal_p(n1, n2) C_mk_bool(C_flonum_magnitude(n1) <= C_flonum_magnitude(n2))
1203
1204 #define C_a_i_flonum_plus(ptr, c, n1, n2) C_flonum(ptr, C_flonum_magnitude(n1) + C_flonum_magnitude(n2))
1205 #define C_a_i_flonum_difference(ptr, c, n1, n2) C_flonum(ptr, C_flonum_magnitude(n1) - C_flonum_magnitude(n2))
1206 #define C_a_i_flonum_times(ptr, c, n1, n2) C_flonum(ptr, C_flonum_magnitude(n1) * C_flonum_magnitude(n2))
1207 #define C_a_i_flonum_quotient(ptr, c, n1, n2) C_flonum(ptr, C_flonum_magnitude(n1) / C_flonum_magnitude(n2))
1208 #define C_a_i_flonum_negate(ptr, c, n) C_flonum(ptr, -C_flonum_magnitude(n))
1209 #define C_a_u_i_flonum_signum(ptr, n, x) (C_flonum_magnitude(x) == 0.0 ? (x) : ((C_flonum_magnitude(x) < 0.0) ? C_flonum(ptr, -1.0) : C_flonum(ptr, 1.0)))
1210
1211 #define C_a_i_address_to_pointer(ptr, c, addr) C_mpointer(ptr, (void *)C_num_to_unsigned_int(addr))
1212 #define C_a_i_pointer_to_address(ptr, c, pptr) C_unsigned_int_to_num(ptr, (unsigned int)C_c_pointer_nn(pptr))
1213
1214 #define C_display_fixnum(p, n) (C_fprintf(C_port_file(p), C_text("%d"), C_unfix(n)), C_SCHEME_UNDEFINED)
1215 #define C_display_char(p, c) (C_fputc(C_character_code(c), C_port_file(p)), C_SCHEME_UNDEFINED)
1216 #define C_display_string(p, s) (C_fwrite(C_data_pointer(s), sizeof(C_char), C_header_size(s), \
1217 C_port_file(p)), C_SCHEME_UNDEFINED)
1218 #define C_flush_output(port) (C_fflush(C_port_file(port)), C_SCHEME_UNDEFINED)
1219
1220 #define C_fix_to_char(x) (C_make_character(C_unfix(x)))
1221 #define C_char_to_fix(x) (C_fix(C_character_code(x)))
1222 #define C_u_i_char_equalp(x, y) C_mk_bool(C_character_code(x) == C_character_code(y))
1223 #define C_u_i_char_greaterp(x, y) C_mk_bool(C_character_code(x) > C_character_code(y))
1224 #define C_u_i_char_lessp(x, y) C_mk_bool(C_character_code(x) < C_character_code(y))
1225 #define C_u_i_char_greater_or_equal_p(x, y) C_mk_bool(C_character_code(x) >= C_character_code(y))
1226 #define C_u_i_char_less_or_equal_p(x, y) C_mk_bool(C_character_code(x) <= C_character_code(y))
1227 #define C_substring_copy(s1, s2, start1, end1, start2) \
1228 (C_memmove((C_char *)C_data_pointer(s2) + C_unfix(start2), \
1229 (C_char *)C_data_pointer(s1) + C_unfix(start1), \
1230 C_unfix(end1) - C_unfix(start1) ), C_SCHEME_UNDEFINED)
1231 #define C_substring_compare(s1, s2, start1, start2, len) \
1232 C_mk_bool(C_memcmp((C_char *)C_data_pointer(s1) + C_unfix(start1), \
1233 (C_char *)C_data_pointer(s2) + C_unfix(start2), \
1234 C_unfix(len) ) == 0)
1235 #define C_substring_compare_case_insensitive(s1, s2, start1, start2, len) \
1236 C_mk_bool(C_memcasecmp((C_char *)C_data_pointer(s1) + C_unfix(start1), \
1237 (C_char *)C_data_pointer(s2) + C_unfix(start2), \
1238 C_unfix(len) ) == 0)
1239 /* this does not use C_mutate: */
1240 #define C_subvector_copy(v1, v2, start1, end1, start2) \
1241 (C_memcpy_slots((C_char *)C_data_pointer(v2) + C_unfix(start2), \
1242 (C_char *)C_data_pointer(v1) + C_unfix(start1), \
1243 C_unfix(end1) - C_unfix(start1) ), C_SCHEME_UNDEFINED)
1244 #define C_words(n) C_fix(C_bytestowords(C_unfix(n)))
1245 #define C_bytes(n) C_fix(C_wordstobytes(C_unfix(n)))
1246 #define C_rand(n) C_fix((C_word)(((double)rand())/(RAND_MAX + 1.0) * C_unfix(n)))
1247 #define C_block_size(x) C_fix(C_header_size(x))
1248 #define C_u_i_bignum_size(b) C_fix(C_bignum_size(b))
1249 #define C_a_u_i_big_to_flo(p, n, b) C_flonum(p, C_bignum_to_double(b))
1250 #define C_u_i_ratnum_num(r) C_block_item((r), 0)
1251 #define C_u_i_ratnum_denom(r) C_block_item((r), 1)
1252 #define C_u_i_cplxnum_real(c) C_block_item((c), 0)
1253 #define C_u_i_cplxnum_imag(c) C_block_item((c), 1)
1254 #define C_pointer_address(x) ((C_byte *)C_block_item((x), 0))
1255 #define C_block_address(ptr, n, x) C_a_unsigned_int_to_num(ptr, n, x)
1256 #define C_offset_pointer(x, y) (C_pointer_address(x) + (y))
1257 #define C_do_apply(c, av) ((C_proc)(void *)C_block_item((av)[0], 0))((c), (av))
1258 #define C_kontinue(k, r) do { C_word avk[ 2 ]; avk[ 0 ] = (k); avk[ 1 ] = (r); ((C_proc)(void *)C_block_item((k),0))(2, avk); } while(0)
1259 #define C_get_rest_arg(c, n, av, ka, cl)((n) >= (c) ? (C_rest_arg_out_of_bounds_error_2(C_fix(c), C_fix(n), C_fix(ka), (cl)), C_SCHEME_UNDEFINED) : (av)[(n)])
1260 #define C_rest_arg_out_of_bounds_error_value(c, n, ka) (C_rest_arg_out_of_bounds_error((c),(n),(ka)), C_SCHEME_UNDEFINED)
1261 #define C_rest_nullp(c, n) (C_mk_bool((n) >= (c)))
1262 #define C_fetch_byte(x, p) (((unsigned C_byte *)C_data_pointer(x))[ p ])
1263 #define C_poke_integer(x, i, n) (C_set_block_item(x, C_unfix(i), C_num_to_int(n)), C_SCHEME_UNDEFINED)
1264 #define C_pointer_to_block(p, x) (C_set_block_item(p, 0, (C_word)C_data_pointer(x)), C_SCHEME_UNDEFINED)
1265 #define C_null_pointerp(x) C_mk_bool((void *)C_block_item(x, 0) == NULL)
1266 #define C_update_pointer(p, ptr) (C_set_block_item(ptr, 0, C_num_to_unsigned_int(p)), C_SCHEME_UNDEFINED)
1267 #define C_copy_pointer(from, to) (C_set_block_item(to, 0, C_block_item(from, 0)), C_SCHEME_UNDEFINED)
1268 #define C_pointer_to_object(ptr) C_block_item(ptr, 0)
1269
1270 #ifdef C_SIXTY_FOUR
1271 # define C_poke_integer_32(x, i, n) (((C_s32 *)C_data_pointer(x))[ C_unfix(i) ] = C_unfix(n), C_SCHEME_UNDEFINED)
1272 #else
1273 # define C_poke_integer_32 C_poke_integer
1274 #endif
1275
1276 #define C_copy_memory(to, from, n) (C_memcpy(C_data_pointer(to), C_data_pointer(from), C_unfix(n)), C_SCHEME_UNDEFINED)
1277 #define C_copy_ptr_memory(to, from, n, toff, foff) \
1278 (C_memmove(C_pointer_address(to) + C_unfix(toff), C_pointer_address(from) + C_unfix(foff), \
1279 C_unfix(n)), C_SCHEME_UNDEFINED)
1280 #define C_set_memory(to, c, n) (C_memset(C_data_pointer(to), C_character_code(c), C_unfix(n)), C_SCHEME_UNDEFINED)
1281 #define C_string_compare(to, from, n) C_fix(C_memcmp(C_c_string(to), C_c_string(from), C_unfix(n)))
1282 #define C_string_compare_case_insensitive(from, to, n) \
1283 C_fix(C_memcasecmp(C_c_string(from), C_c_string(to), C_unfix(n)))
1284 #define C_poke_double(b, i, n) (((double *)C_data_pointer(b))[ C_unfix(i) ] = C_c_double(n), C_SCHEME_UNDEFINED)
1285 #define C_poke_c_string(b, i, from, s) (C_strlcpy((char *)C_block_item(b, C_unfix(i)), C_data_pointer(from), s), C_SCHEME_UNDEFINED)
1286 #define C_peek_fixnum(b, i) C_fix(C_block_item(b, C_unfix(i)))
1287 #define C_peek_byte(ptr, i) C_fix(((unsigned char *)C_u_i_car(ptr))[ C_unfix(i) ])
1288 #define C_dupstr(s) C_strdup(C_data_pointer(s))
1289 #define C_poke_pointer(b, i, x) (C_set_block_item(b, C_unfix(i), (C_word)C_data_pointer(x)), C_SCHEME_UNDEFINED)
1290 #define C_poke_pointer_or_null(b, i, x) (C_set_block_item(b, C_unfix(i), (C_word)C_data_pointer_or_null(x)), C_SCHEME_UNDEFINED)
1291 #define C_qfree(ptr) (C_free(C_c_pointer_nn(ptr)), C_SCHEME_UNDEFINED)
1292
1293 #define C_tty_portp(p) C_mk_bool(isatty(fileno(C_port_file(p))))
1294
1295 #define C_emit_eval_trace_info(x, y, z) C_emit_trace_info2(C_text("<eval>"), x, y, z)
1296 #define C_emit_syntax_trace_info(x, y, z) C_emit_trace_info2(C_text("<syntax>"), x, y, z)
1297
1298 /* These expect C_VECTOR_TYPE to be 0: */
1299 #define C_vector_to_structure(v) (C_block_header(v) |= C_STRUCTURE_TYPE, C_SCHEME_UNDEFINED)
1300 #define C_vector_to_closure(v) (C_block_header(v) |= C_CLOSURE_TYPE, C_SCHEME_UNDEFINED)
1301 #define C_string_to_bytevector(s) (C_block_header(s) = C_header_size(s) | C_BYTEVECTOR_TYPE, C_SCHEME_UNDEFINED)
1302 #define C_string_to_lambdainfo(s) (C_block_header(s) = C_header_size(s) | C_LAMBDA_INFO_TYPE, C_SCHEME_UNDEFINED)
1303
1304 #ifdef C_TIMER_INTERRUPTS
1305 # define C_check_for_interrupt if(--C_timer_interrupt_counter <= 0) C_raise_interrupt(C_TIMER_INTERRUPT_NUMBER)
1306 #else
1307 # define C_check_for_interrupt
1308 #endif
1309
1310 #define C_set_initial_timer_interrupt_period(n) \
1311 (C_initial_timer_interrupt_period = C_unfix(n), C_SCHEME_UNDEFINED)
1312
1313
1314 #ifdef HAVE_STATEMENT_EXPRESSIONS
1315 # define C_a_i(a, n) ({C_word *tmp = *a; *a += (n); tmp;})
1316 # define C_a_i_cons(a, n, car, cdr) ({C_word tmp = (C_word)(*a); (*a)[0] = C_PAIR_TYPE | 2; *a += C_SIZEOF_PAIR; \
1317 C_set_block_item(tmp, 0, car); C_set_block_item(tmp, 1, cdr); tmp;})
1318 #else
1319 # define C_a_i_cons(a, n, car, cdr) C_a_pair(a, car, cdr)
1320 #endif /* HAVE_STATEMENT_EXPRESSIONS */
1321
1322 #define C_a_i_flonum(ptr, c, n) C_flonum(ptr, n)
1323 #define C_a_i_ratnum(ptr, c, n, d) C_ratnum(ptr, n, d)
1324 #define C_a_i_cplxnum(ptr, c, r, i) C_cplxnum(ptr, r, i)
1325 #define C_a_i_data_mpointer(ptr, n, x) C_mpointer(ptr, C_data_pointer(x))
1326 #define C_a_i_fix_to_flo(p, n, f) C_flonum(p, C_unfix(f))
1327 #define C_cast_to_flonum(n) ((double)(n))
1328 #define C_a_i_mpointer(ptr, n, x) C_mpointer(ptr, (x))
1329 #define C_a_u_i_pointer_inc(ptr, n, p, i) C_mpointer(ptr, (C_char *)(p) + C_unfix(i))
1330 #define C_pointer_eqp(x, y) C_mk_bool(C_c_pointer_nn(x) == C_c_pointer_nn(y))
1331 #define C_a_int_to_num(ptr, n, i) C_int_to_num(ptr, i)
1332 #define C_a_unsigned_int_to_num(ptr, n, i) C_unsigned_int_to_num(ptr, i)
1333 #define C_a_i_vector C_vector
1334 #define C_list C_a_i_list
1335 #define C_i_setslot(x, i, y) (C_mutate(&C_block_item(x, C_unfix(i)), y), C_SCHEME_UNDEFINED)
1336 #define C_i_set_i_slot(x, i, y) (C_set_block_item(x, C_unfix(i), y), C_SCHEME_UNDEFINED)
1337 #define C_u_i_set_car(p, x) (C_mutate(&C_u_i_car(p), x), C_SCHEME_UNDEFINED)
1338 #define C_u_i_set_cdr(p, x) (C_mutate(&C_u_i_cdr(p), x), C_SCHEME_UNDEFINED)
1339 #define C_a_i_putprop(p, c, x, y, z) C_putprop(p, x, y, z)
1340
1341 #define C_i_not(x) (C_truep(x) ? C_SCHEME_FALSE : C_SCHEME_TRUE)
1342 #define C_i_equalp(x, y) C_mk_bool(C_equalp((x), (y)))
1343 #define C_i_fixnumevenp(x) C_mk_nbool((x) & 0x00000002)
1344 #define C_i_fixnumoddp(x) C_mk_bool((x) & 0x00000002)
1345 #define C_i_fixnum_negativep(x) C_mk_bool((x) & C_INT_SIGN_BIT)
1346 #define C_i_fixnum_positivep(x) C_mk_bool(!((x) & C_INT_SIGN_BIT) && (x) != C_fix(0))
1347 #define C_i_nullp(x) C_mk_bool((x) == C_SCHEME_END_OF_LIST)
1348 #define C_i_structurep(x, s) C_mk_bool(!C_immediatep(x) && C_header_bits(x) == C_STRUCTURE_TYPE && C_block_item(x, 0) == (s))
1349
1350 #define C_u_i_char_alphabeticp(x) C_mk_bool(C_character_code(x) < 0x100 && C_isalpha(C_character_code(x)))
1351 #define C_u_i_char_numericp(x) C_mk_bool(C_character_code(x) < 0x100 && C_isdigit(C_character_code(x)))
1352 #define C_u_i_char_whitespacep(x) C_mk_bool(C_character_code(x) < 0x100 && C_isspace(C_character_code(x)))
1353 #define C_u_i_char_upper_casep(x) C_mk_bool(C_character_code(x) < 0x100 && C_isupper(C_character_code(x)))
1354 #define C_u_i_char_lower_casep(x) C_mk_bool(C_character_code(x) < 0x100 && C_islower(C_character_code(x)))
1355
1356 #define C_u_i_char_upcase(x) (C_character_code(x) < 0x100 ? C_make_character(C_toupper(C_character_code(x))) : (x))
1357 #define C_u_i_char_downcase(x) (C_character_code(x) < 0x100 ? C_make_character(C_tolower(C_character_code(x))) : (x))
1358
1359 #define C_i_list_ref(lst, i) C_i_car(C_i_list_tail(lst, i))
1360 #define C_u_i_list_ref(lst, i) C_u_i_car(C_i_list_tail(lst, i))
1361
1362 #define C_u_i_car(x) (*C_CHECKp(x,C_pairp(C_VAL1(x)),&C_block_item(C_VAL1(x), 0)))
1363 #define C_u_i_cdr(x) (*C_CHECKp(x,C_pairp(C_VAL1(x)),&C_block_item(C_VAL1(x), 1)))
1364 #define C_u_i_caar(x) C_u_i_car( C_u_i_car( x ) )
1365 #define C_u_i_cadr(x) C_u_i_car( C_u_i_cdr( x ) )
1366 #define C_u_i_cdar(x) C_u_i_cdr( C_u_i_car( x ) )
1367 #define C_u_i_cddr(x) C_u_i_cdr( C_u_i_cdr( x ) )
1368 #define C_u_i_caaar(x) C_u_i_car( C_u_i_caar( x ) )
1369 #define C_u_i_caadr(x) C_u_i_car( C_u_i_cadr( x ) )
1370 #define C_u_i_cadar(x) C_u_i_car( C_u_i_cdar( x ) )
1371 #define C_u_i_caddr(x) C_u_i_car( C_u_i_cddr( x ) )
1372 #define C_u_i_cdaar(x) C_u_i_cdr( C_u_i_caar( x ) )
1373 #define C_u_i_cdadr(x) C_u_i_cdr( C_u_i_cadr( x ) )
1374 #define C_u_i_cddar(x) C_u_i_cdr( C_u_i_cdar( x ) )
1375 #define C_u_i_cdddr(x) C_u_i_cdr( C_u_i_cddr( x ) )
1376 #define C_u_i_caaaar(x) C_u_i_car( C_u_i_caaar( x ) )
1377 #define C_u_i_caaadr(x) C_u_i_car( C_u_i_caadr( x ) )
1378 #define C_u_i_caadar(x) C_u_i_car( C_u_i_cadar( x ) )
1379 #define C_u_i_caaddr(x) C_u_i_car( C_u_i_caddr( x ) )
1380 #define C_u_i_cadaar(x) C_u_i_car( C_u_i_cdaar( x ) )
1381 #define C_u_i_cadadr(x) C_u_i_car( C_u_i_cdadr( x ) )
1382 #define C_u_i_caddar(x) C_u_i_car( C_u_i_cddar( x ) )
1383 #define C_u_i_cadddr(x) C_u_i_car( C_u_i_cdddr( x ) )
1384 #define C_u_i_cdaaar(x) C_u_i_cdr( C_u_i_caaar( x ) )
1385 #define C_u_i_cdaadr(x) C_u_i_cdr( C_u_i_caadr( x ) )
1386 #define C_u_i_cdadar(x) C_u_i_cdr( C_u_i_cadar( x ) )
1387 #define C_u_i_cdaddr(x) C_u_i_cdr( C_u_i_caddr( x ) )
1388 #define C_u_i_cddaar(x) C_u_i_cdr( C_u_i_cdaar( x ) )
1389 #define C_u_i_cddadr(x) C_u_i_cdr( C_u_i_cdadr( x ) )
1390 #define C_u_i_cdddar(x) C_u_i_cdr( C_u_i_cddar( x ) )
1391 #define C_u_i_cddddr(x) C_u_i_cdr( C_u_i_cdddr( x ) )
1392
1393 #ifdef HAVE_STATEMENT_EXPRESSIONS
1394 # define C_i_not_pair_p(x) ({C_word tmp = (x); C_mk_bool(C_immediatep(tmp) || C_block_header(tmp) != C_PAIR_TAG);})
1395 #else
1396 # define C_i_not_pair_p C_i_not_pair_p_2
1397 #endif
1398
1399 #define C_i_check_closure(x) C_i_check_closure_2(x, C_SCHEME_FALSE)
1400 #define C_i_check_exact(x) C_i_check_exact_2(x, C_SCHEME_FALSE) /* DEPRECATED */
1401 #define C_i_check_fixnum(x) C_i_check_fixnum_2(x, C_SCHEME_FALSE)
1402 #define C_i_check_inexact(x) C_i_check_inexact_2(x, C_SCHEME_FALSE)
1403 #define C_i_check_number(x) C_i_check_number_2(x, C_SCHEME_FALSE)
1404 #define C_i_check_string(x) C_i_check_string_2(x, C_SCHEME_FALSE)
1405 #define C_i_check_bytevector(x) C_i_check_bytevector_2(x, C_SCHEME_FALSE)
1406 #define C_i_check_keyword(x) C_i_check_keyword_2(x, C_SCHEME_FALSE)
1407 #define C_i_check_symbol(x) C_i_check_symbol_2(x, C_SCHEME_FALSE)
1408 #define C_i_check_list(x) C_i_check_list_2(x, C_SCHEME_FALSE)
1409 #define C_i_check_pair(x) C_i_check_pair_2(x, C_SCHEME_FALSE)
1410 #define C_i_check_locative(x) C_i_check_locative_2(x, C_SCHEME_FALSE)
1411 #define C_i_check_boolean(x) C_i_check_boolean_2(x, C_SCHEME_FALSE)
1412 #define C_i_check_vector(x) C_i_check_vector_2(x, C_SCHEME_FALSE)
1413 #define C_i_check_structure(x, st) C_i_check_structure_2(x, (st), C_SCHEME_FALSE)
1414 #define C_i_check_char(x) C_i_check_char_2(x, C_SCHEME_FALSE)
1415 #define C_i_check_port(x, in, op) C_i_check_port_2(x, in, op, C_SCHEME_FALSE)
1416
1417 #define C_u_i_8vector_length(x) C_fix(C_header_size(C_block_item(x, 1)))
1418 #define C_u_i_16vector_length(x) C_fix(C_header_size(C_block_item(x, 1)) >> 1)
1419 #define C_u_i_32vector_length(x) C_fix(C_header_size(C_block_item(x, 1)) >> 2)
1420 #define C_u_i_64vector_length(x) C_fix(C_header_size(C_block_item(x, 1)) >> 3)
1421 #define C_u_i_u8vector_length C_u_i_8vector_length
1422 #define C_u_i_s8vector_length C_u_i_8vector_length
1423 #define C_u_i_u16vector_length C_u_i_16vector_length
1424 #define C_u_i_s16vector_length C_u_i_16vector_length
1425 #define C_u_i_u32vector_length C_u_i_32vector_length
1426 #define C_u_i_s32vector_length C_u_i_32vector_length
1427 #define C_u_i_u64vector_length C_u_i_64vector_length
1428 #define C_u_i_s64vector_length C_u_i_64vector_length
1429 #define C_u_i_f32vector_length C_u_i_32vector_length
1430 #define C_u_i_f64vector_length C_u_i_64vector_length
1431
1432 #define C_u_i_u8vector_ref(x, i) C_fix(((unsigned char *)C_data_pointer(C_block_item((x), 1)))[ C_unfix(i) ])
1433 #define C_u_i_s8vector_ref(x, i) C_fix(((signed char *)C_data_pointer(C_block_item((x), 1)))[ C_unfix(i) ])
1434 #define C_u_i_u16vector_ref(x, i) C_fix(((unsigned short *)C_data_pointer(C_block_item((x), 1)))[ C_unfix(i) ])
1435 #define C_u_i_s16vector_ref(x, i) C_fix(((short *)C_data_pointer(C_block_item((x), 1)))[ C_unfix(i) ])
1436
1437 /* these assume fixnum mode */
1438 #define C_u_i_u32vector_ref(x, i) C_fix(((C_u32 *)C_data_pointer(C_block_item((x), 1)))[ C_unfix(i) ])
1439 #define C_u_i_s32vector_ref(x, i) C_fix(((C_s32 *)C_data_pointer(C_block_item((x), 1)))[ C_unfix(i) ])
1440
1441 #define C_a_u_i_u32vector_ref(ptr, c, x, i) C_unsigned_int_to_num(ptr, ((C_u32 *)C_data_pointer(C_block_item((x), 1)))[ C_unfix(i) ])
1442 #define C_a_u_i_s32vector_ref(ptr, c, x, i) C_int_to_num(ptr, ((C_s32 *)C_data_pointer(C_block_item((x), 1)))[ C_unfix(i) ])
1443
1444 #define C_a_u_i_u64vector_ref(ptr, c, x, i) C_uint64_to_num(ptr, ((C_u64 *)C_data_pointer(C_block_item((x), 1)))[ C_unfix(i) ])
1445 #define C_a_u_i_s64vector_ref(ptr, c, x, i) C_int64_to_num(ptr, ((C_s64 *)C_data_pointer(C_block_item((x), 1)))[ C_unfix(i) ])
1446
1447 #define C_u_i_u8vector_set(x, i, v) ((((unsigned char *)C_data_pointer(C_block_item((x), 1)))[ C_unfix(i) ] = C_unfix(v)), C_SCHEME_UNDEFINED)
1448 #define C_u_i_s8vector_set(x, i, v) ((((signed char *)C_data_pointer(C_block_item((x), 1)))[ C_unfix(i) ] = C_unfix(v)), C_SCHEME_UNDEFINED)
1449 #define C_u_i_u16vector_set(x, i, v) ((((unsigned short *)C_data_pointer(C_block_item((x), 1)))[ C_unfix(i) ] = C_unfix(v)), C_SCHEME_UNDEFINED)
1450 #define C_u_i_s16vector_set(x, i, v) ((((short *)C_data_pointer(C_block_item((x), 1)))[ C_unfix(i) ] = C_unfix(v)), C_SCHEME_UNDEFINED)
1451 #define C_u_i_u32vector_set(x, i, v) ((((C_u32 *)C_data_pointer(C_block_item((x), 1)))[ C_unfix(i) ] = C_num_to_unsigned_int(v)), C_SCHEME_UNDEFINED)
1452 #define C_u_i_s32vector_set(x, i, v) ((((C_s32 *)C_data_pointer(C_block_item((x), 1)))[ C_unfix(i) ] = C_num_to_int(v)), C_SCHEME_UNDEFINED)
1453 #define C_u_i_u64vector_set(x, i, v) ((((C_u64 *)C_data_pointer(C_block_item((x), 1)))[ C_unfix(i) ] = C_num_to_uint64(v)), C_SCHEME_UNDEFINED)
1454 #define C_u_i_s64vector_set(x, i, v) ((((C_s64 *)C_data_pointer(C_block_item((x), 1)))[ C_unfix(i) ] = C_num_to_int64(v)), C_SCHEME_UNDEFINED)
1455
1456 /* DEPRECATED */
1457 #define C_u_i_bit_to_bool(x, i) C_mk_bool((C_unfix(x) & (1 << C_unfix(i))) != 0)
1458
1459 #define C_u_i_pointer_u8_ref(ptr) C_fix(*((unsigned char *)C_block_item(ptr, 0)))
1460 #define C_u_i_pointer_s8_ref(ptr) C_fix(*((signed char *)C_block_item(ptr, 0)))
1461 #define C_u_i_pointer_u16_ref(ptr) C_fix(*((unsigned short *)C_block_item(ptr, 0)))
1462 #define C_u_i_pointer_s16_ref(ptr) C_fix(*((short *)C_block_item(ptr, 0)))
1463 #define C_a_u_i_pointer_u32_ref(ap, n, ptr) \
1464 C_unsigned_int_to_num(ap, *((C_u32 *)C_block_item(ptr, 0)))
1465 #define C_a_u_i_pointer_s32_ref(ap, n, ptr) \
1466 C_int_to_num(ap, *((C_s32 *)C_block_item(ptr, 0)))
1467 #define C_a_u_i_pointer_u64_ref(ap, n, ptr) \
1468 C_uint64_to_num(ap, *((C_u64 *)C_block_item(ptr, 0)))
1469 #define C_a_u_i_pointer_s64_ref(ap, n, ptr) \
1470 C_int64_to_num(ap, *((C_s64 *)C_block_item(ptr, 0)))
1471 #define C_a_u_i_pointer_f32_ref(ap, n, ptr) C_flonum(ap, *((float *)C_block_item(ptr, 0)))
1472 #define C_a_u_i_pointer_f64_ref(ap, n, ptr) C_flonum(ap, *((double *)C_block_item(ptr, 0)))
1473 #define C_u_i_pointer_u8_set(ptr, x) \
1474 (*((unsigned char *)C_block_item(ptr, 0)) = C_unfix(x), C_SCHEME_UNDEFINED)
1475 #define C_u_i_pointer_s8_set(ptr, x) \
1476 (*((signed char *)C_block_item(ptr, 0)) = C_unfix(x), C_SCHEME_UNDEFINED)
1477 #define C_u_i_pointer_u16_set(ptr, x) \
1478 (*((unsigned short *)C_block_item(ptr, 0)) = C_unfix(x), C_SCHEME_UNDEFINED)
1479 #define C_u_i_pointer_s16_set(ptr, x) \
1480 (*((short *)C_block_item(ptr, 0)) = C_unfix(x), C_SCHEME_UNDEFINED)
1481 #define C_u_i_pointer_u32_set(ptr, x) \
1482 (*((C_u32 *)C_block_item(ptr, 0)) = C_num_to_unsigned_int(x), C_SCHEME_UNDEFINED)
1483 #define C_u_i_pointer_s32_set(ptr, x) \
1484 (*((C_s32 *)C_block_item(ptr, 0)) = C_num_to_int(x), C_SCHEME_UNDEFINED)
1485 #define C_u_i_pointer_u64_set(ptr, x) \
1486 (*((C_u64 *)C_block_item(ptr, 0)) = C_num_to_uint64(x), C_SCHEME_UNDEFINED)
1487 #define C_u_i_pointer_s64_set(ptr, x) \
1488 (*((C_s64 *)C_block_item(ptr, 0)) = C_num_to_int64(x), C_SCHEME_UNDEFINED)
1489 #define C_u_i_pointer_f32_set(ptr, x) \
1490 (*((float *)C_block_item(ptr, 0)) = C_flonum_magnitude(x), C_SCHEME_UNDEFINED)
1491 #define C_u_i_pointer_f64_set(ptr, x) \
1492 (*((double *)C_block_item(ptr, 0)) = C_flonum_magnitude(x), C_SCHEME_UNDEFINED)
1493
1494 #ifdef C_BIG_ENDIAN
1495 # ifdef C_SIXTY_FOUR
1496 # define C_lihdr(x, y, z) ((C_LAMBDA_INFO_TYPE >> 56) & 0xff), \
1497 0, 0, 0, 0, (x), (y), ((C_char)(z))
1498 # else
1499 # define C_lihdr(x, y, z) ((C_LAMBDA_INFO_TYPE >> 24) & 0xff), \
1500 (x), (y), ((C_char)(z))
1501 # endif
1502 #else
1503 # ifdef C_SIXTY_FOUR
1504 # define C_lihdr(x, y, z) ((C_char)(z)), (y), (x), 0, 0, 0, 0, \
1505 ((C_LAMBDA_INFO_TYPE >> 56) & 0xff)
1506 # else
1507 # define C_lihdr(x, y, z) ((C_char)(z)), (y), (x), \
1508 ((C_LAMBDA_INFO_TYPE >> 24) & 0xff)
1509 # endif
1510 #endif
1511
1512 #define C_ub_i_flonum_plus(x, y) ((x) + (y))
1513 #define C_ub_i_flonum_difference(x, y) ((x) - (y))
1514 #define C_ub_i_flonum_times(x, y) ((x) * (y))
1515 #define C_ub_i_flonum_quotient(x, y) ((x) / (y))
1516
1517 #define C_ub_i_flonum_equalp(n1, n2) C_mk_bool((n1) == (n2))
1518 #define C_ub_i_flonum_greaterp(n1, n2) C_mk_bool((n1) > (n2))
1519 #define C_ub_i_flonum_lessp(n1, n2) C_mk_bool((n1) < (n2))
1520 #define C_ub_i_flonum_greater_or_equal_p(n1, n2) C_mk_bool((n1) >= (n2))
1521 #define C_ub_i_flonum_less_or_equal_p(n1, n2) C_mk_bool((n1) <= (n2))
1522
1523 #define C_ub_i_flonum_nanp(x) C_mk_bool(C_isnan(x))
1524 #define C_ub_i_flonum_infinitep(x) C_mk_bool(C_isinf(x))
1525 #define C_ub_i_flonum_finitep(x) C_mk_bool(C_isfinite(x))
1526
1527 #define C_ub_i_pointer_inc(p, n) ((void *)((unsigned char *)(p) + (n)))
1528 #define C_ub_i_pointer_eqp(p1, p2) C_mk_bool((p1) == (p2))
1529 #define C_ub_i_null_pointerp(p) C_mk_bool((p) == NULL)
1530
1531 #define C_ub_i_pointer_u8_ref(p) (*((unsigned char *)(p)))
1532 #define C_ub_i_pointer_s8_ref(p) (*((signed char *)(p)))
1533 #define C_ub_i_pointer_u16_ref(p) (*((unsigned short *)(p)))
1534 #define C_ub_i_pointer_s16_ref(p) (*((short *)(p)))
1535 #define C_ub_i_pointer_u32_ref(p) (*((C_u32 *)(p)))
1536 #define C_ub_i_pointer_s32_ref(p) (*((C_s32 *)(p)))
1537 #define C_ub_i_pointer_u64_ref(p) (*((C_u64 *)(p)))
1538 #define C_ub_i_pointer_s64_ref(p) (*((C_s64 *)(p)))
1539 #define C_ub_i_pointer_f32_ref(p) (*((float *)(p)))
1540 #define C_ub_i_pointer_f64_ref(p) (*((double *)(p)))
1541 #define C_ub_i_pointer_u8_set(p, n) (*((unsigned char *)(p)) = (n))
1542 #define C_ub_i_pointer_s8_set(p, n) (*((signed char *)(p)) = (n))
1543 #define C_ub_i_pointer_u16_set(p, n) (*((unsigned short *)(p)) = (n))
1544 #define C_ub_i_pointer_s16_set(p, n) (*((short *)(p)) = (n))
1545 #define C_ub_i_pointer_u32_set(p, n) (*((C_u32 *)(p)) = (n))
1546 #define C_ub_i_pointer_s32_set(p, n) (*((C_s32 *)(p)) = (n))
1547 #define C_ub_i_pointer_u64_set(p, n) (*((C_u64 *)(p)) = (n))
1548 #define C_ub_i_pointer_s64_set(p, n) (*((C_s64 *)(p)) = (n))
1549 #define C_ub_i_pointer_f32_set(p, n) (*((float *)(p)) = (n))
1550 #define C_ub_i_pointer_f64_set(p, n) (*((double *)(p)) = (n))
1551
1552 #ifdef C_PRIVATE_REPOSITORY
1553 # define C_private_repository() C_use_private_repository(C_executable_dirname())
1554 #else
1555 # define C_private_repository()
1556 #endif
1557
1558 #ifdef C_GUI
1559 # define C_set_gui_mode C_gui_mode = 1
1560 #else
1561 # define C_set_gui_mode
1562 #endif
1563
1564 /**
1565 * SEARCH_EXE_PATH is defined on platforms on which we must search for
1566 * the current executable. Because this search is sensitive to things
1567 * like CWD, PATH, and so on, it's done once at startup and saved in
1568 * `C_main_exe`.
1569 *
1570 * On platforms where it's not defined, there's a simple way to
1571 * retrieve a path to the current executable (such as reading
1572 * "/proc/<pid>/exe" or some similar trick).
1573 */
1574 #ifdef SEARCH_EXE_PATH
1575 # define C_set_main_exe(fname) C_main_exe = C_resolve_executable_pathname(fname)
1576 #else
1577 # define C_set_main_exe(fname)
1578 #endif
1579
1580 #if !defined(C_EMBEDDED) && !defined(C_SHARED)
1581 # if defined(C_GUI) && defined(_WIN32)
1582 # define C_main_entry_point \
1583 int WINAPI WinMain(HINSTANCE me, HINSTANCE you, LPSTR cmdline, int show) \
1584 { \
1585 C_gui_mode = 1; \
1586 C_set_main_exe(argv[0]); \
1587 C_private_repository(); \
1588 return CHICKEN_main(0, NULL, (void *)C_toplevel); \
1589 }
1590 # else
1591 # define C_main_entry_point \
1592 int main(int argc, char *argv[]) \
1593 { \
1594 C_set_gui_mode; \
1595 C_set_main_exe(argv[0]); \
1596 C_private_repository(); \
1597 return CHICKEN_main(argc, argv, (void*)C_toplevel); \
1598 }
1599 # endif
1600 #else
1601 # define C_main_entry_point
1602 #endif
1603
1604 #define C_alloc_flonum C_word *___tmpflonum = C_alloc(WORDS_PER_FLONUM)
1605 #define C_kontinue_flonum(k, n) C_kontinue((k), C_flonum(&___tmpflonum, (n)))
1606
1607 #define C_a_i_flonum_truncate(ptr, n, x) C_flonum(ptr, C_trunc(C_flonum_magnitude(x)))
1608 #define C_a_i_flonum_ceiling(ptr, n, x) C_flonum(ptr, C_ceil(C_flonum_magnitude(x)))
1609 #define C_a_i_flonum_floor(ptr, n, x) C_flonum(ptr, C_floor(C_flonum_magnitude(x)))
1610 #define C_a_i_flonum_round(ptr, n, x) C_flonum(ptr, C_round(C_flonum_magnitude(x)))
1611
1612 #define C_a_u_i_f32vector_ref(ptr, n, b, i) C_flonum(ptr, ((float *)C_data_pointer(C_block_item((b), 1)))[ C_unfix(i) ])
1613 #define C_a_u_i_f64vector_ref(ptr, n, b, i) C_flonum(ptr, ((double *)C_data_pointer(C_block_item((b), 1)))[ C_unfix(i) ])
1614 #define C_u_i_f32vector_set(v, i, x) ((((float *)C_data_pointer(C_block_item((v), 1)))[ C_unfix(i) ] = C_flonum_magnitude(x)), C_SCHEME_UNDEFINED)
1615 #define C_u_i_f64vector_set(v, i, x) ((((double *)C_data_pointer(C_block_item((v), 1)))[ C_unfix(i) ] = C_flonum_magnitude(x)), C_SCHEME_UNDEFINED)
1616
1617 #define C_ub_i_f32vector_ref(b, i) (((float *)C_data_pointer(C_block_item((b), 1)))[ C_unfix(i) ])
1618 #define C_ub_i_f64vector_ref(b, i) (((double *)C_data_pointer(C_block_item((b), 1)))[ C_unfix(i) ])
1619 #define C_ub_i_f32vector_set(v, i, x) ((((float *)C_data_pointer(C_block_item((v), 1)))[ C_unfix(i) ] = (x)), 0)
1620 #define C_ub_i_f64vector_set(v, i, x) ((((double *)C_data_pointer(C_block_item((v), 1)))[ C_unfix(i) ] = (x)), 0)
1621
1622 #define C_a_i_flonum_sin(ptr, c, x) C_flonum(ptr, C_sin(C_flonum_magnitude(x)))
1623 #define C_a_i_flonum_cos(ptr, c, x) C_flonum(ptr, C_cos(C_flonum_magnitude(x)))
1624 #define C_a_i_flonum_tan(ptr, c, x) C_flonum(ptr, C_tan(C_flonum_magnitude(x)))
1625 #define C_a_i_flonum_asin(ptr, c, x) C_flonum(ptr, C_asin(C_flonum_magnitude(x)))
1626 #define C_a_i_flonum_acos(ptr, c, x) C_flonum(ptr, C_acos(C_flonum_magnitude(x)))
1627 #define C_a_i_flonum_atan(ptr, c, x) C_flonum(ptr, C_atan(C_flonum_magnitude(x)))
1628 #define C_a_i_flonum_atan2(ptr, c, x, y) C_flonum(ptr, C_atan2(C_flonum_magnitude(x), C_flonum_magnitude(y)))
1629 #define C_a_i_flonum_exp(ptr, c, x) C_flonum(ptr, C_exp(C_flonum_magnitude(x)))
1630 #define C_a_i_flonum_expt(ptr, c, x, y) C_flonum(ptr, C_pow(C_flonum_magnitude(x), C_flonum_magnitude(y)))
1631 #define C_a_i_flonum_log(ptr, c, x) C_flonum(ptr, C_log(C_flonum_magnitude(x)))
1632 #define C_a_i_flonum_sqrt(ptr, c, x) C_flonum(ptr, C_sqrt(C_flonum_magnitude(x)))
1633 #define C_a_i_flonum_abs(ptr, c, x) C_flonum(ptr, C_fabs(C_flonum_magnitude(x)))
1634 #define C_u_i_flonum_nanp(x) C_mk_bool(C_isnan(C_flonum_magnitude(x)))
1635 #define C_u_i_flonum_infinitep(x) C_mk_bool(C_isinf(C_flonum_magnitude(x)))
1636 #define C_u_i_flonum_finitep(x) C_mk_bool(C_isfinite(C_flonum_magnitude(x)))
1637
1638 /* DEPRECATED */
1639 #define C_a_i_current_milliseconds(ptr, c, dummy) C_uint64_to_num(ptr, C_milliseconds())
1640 #define C_a_i_current_process_milliseconds(ptr, c, dummy) C_uint64_to_num(ptr, C_current_process_milliseconds())
1641
1642 #define C_i_noop1(dummy) ((dummy), C_SCHEME_UNDEFINED)
1643 #define C_i_noop2(dummy1, dummy2) ((dummy1), (dummy2), C_SCHEME_UNDEFINED)
1644 #define C_i_noop3(dummy1, dummy2, dummy3) ((dummy1), (dummy2), (dummy3), C_SCHEME_UNDEFINED)
1645 #define C_i_true1(dummy) ((dummy), C_SCHEME_TRUE)
1646 #define C_i_true2(dummy1, dummy2) ((dummy1), (dummy2), C_SCHEME_TRUE)
1647 #define C_i_true3(dummy1, dummy2, dummy3) ((dummy1), (dummy2), (dummy3), C_SCHEME_TRUE)
1648
1649 /* debug client interface */
1650
1651 typedef struct C_DEBUG_INFO {
1652 int event;
1653 int enabled;
1654 C_char *loc;
1655 C_char *val;
1656 } C_DEBUG_INFO;
1657
1658 #define C_DEBUG_CALL 1
1659 #define C_DEBUG_GLOBAL_ASSIGN 2
1660 #define C_DEBUG_GC 3
1661 #define C_DEBUG_ENTRY 4
1662 #define C_DEBUG_SIGNAL 5
1663 #define C_DEBUG_CONNECT 6
1664 #define C_DEBUG_LISTEN 7
1665 #define C_DEBUG_INTERRUPTED 8
1666
1667 #define C_debugger(cell, c, av) (C_debugger_hook != NULL ? C_debugger_hook(cell, c, av, C_text(__FILE__ ":" C__STR2(__LINE__))) : C_SCHEME_UNDEFINED)
1668
1669 /* Variables: */
1670
1671 C_varextern C_TLS time_t C_startup_time_seconds;
1672 C_varextern C_TLS C_word
1673 *C_temporary_stack,
1674 *C_temporary_stack_bottom,
1675 *C_temporary_stack_limit,
1676 *C_stack_limit,
1677 *C_stack_hard_limit,
1678 *C_scratchspace_start,
1679 *C_scratchspace_top,
1680 *C_scratchspace_limit,
1681 C_scratch_usage;
1682 C_varextern C_TLS C_long
1683 C_timer_interrupt_counter,
1684 C_initial_timer_interrupt_period;
1685 C_varextern C_TLS C_byte
1686 *C_fromspace_top,
1687 *C_fromspace_limit;
1688 #ifdef HAVE_SIGSETJMP
1689 C_varextern C_TLS sigjmp_buf C_restart;
1690 #else
1691 C_varextern C_TLS jmp_buf C_restart;
1692 #endif
1693 C_varextern C_TLS void *C_restart_address;
1694 C_varextern C_TLS int C_entry_point_status;
1695 C_varextern C_TLS int C_gui_mode;
1696 C_varextern C_TLS int C_enable_repl;
1697
1698 C_varextern C_TLS void *C_restart_trampoline;
1699 C_varextern C_TLS void (*C_pre_gc_hook)(int mode);
1700 C_varextern C_TLS void (*C_post_gc_hook)(int mode, C_long ms);
1701 C_varextern C_TLS void (*C_panic_hook)(C_char *msg);
1702 C_varextern C_TLS C_word (*C_debugger_hook)(C_DEBUG_INFO *cell, C_word c, C_word *av, char *cloc);
1703
1704 C_varextern C_TLS int
1705 C_abort_on_thread_exceptions,
1706 C_interrupts_enabled,
1707 C_disable_overflow_check,
1708 C_heap_size_is_fixed,
1709 C_max_pending_finalizers,
1710 C_trace_buffer_size,
1711 C_debugging,
1712 C_main_argc;
1713 C_varextern C_TLS C_uword
1714 C_heap_growth,
1715 C_heap_shrinkage;
1716 C_varextern C_TLS char
1717 **C_main_argv,
1718 #ifdef SEARCH_EXE_PATH
1719 *C_main_exe,
1720 #endif
1721 *C_dlerror;
1722 C_varextern C_TLS C_uword C_maximal_heap_size;
1723 C_varextern C_TLS int (*C_gc_mutation_hook)(C_word *slot, C_word val);
1724 C_varextern C_TLS void (*C_gc_trace_hook)(C_word *var, int mode);
1725 C_varextern C_TLS C_word (*C_get_unbound_variable_value_hook)(C_word sym);
1726
1727
1728 /* Prototypes: */
1729
1730 C_BEGIN_C_DECLS
1731
1732 C_fctexport void C_register_debug_info(C_DEBUG_INFO *);
1733 C_fctexport int CHICKEN_main(int argc, char *argv[], void *toplevel);
1734 C_fctexport int CHICKEN_initialize(int heap, int stack, int symbols, void *toplevel);
1735 C_fctexport C_word CHICKEN_run(void *toplevel);
1736 C_fctexport C_word CHICKEN_continue(C_word k);
1737 C_fctexport void *CHICKEN_new_gc_root();
1738 C_fctexport void *CHICKEN_new_finalizable_gc_root();
1739 C_fctexport void *CHICKEN_new_gc_root_2(int finalizable);
1740 C_fctexport void CHICKEN_delete_gc_root(void *root);
1741 C_fctexport void *CHICKEN_global_lookup(char *name);
1742 C_fctexport int CHICKEN_is_running();
1743 C_fctexport void CHICKEN_interrupt();
1744
1745 C_fctexport void C_check_nursery_minimum(C_word size);
1746 C_fctexport int C_fcall C_save_callback_continuation(C_word **ptr, C_word k);
1747 C_fctexport C_word C_fcall C_restore_callback_continuation(void);
1748 C_fctexport C_word C_fcall C_restore_callback_continuation2(int level);
1749 C_fctexport C_word C_fcall C_callback(C_word closure, int argc);
1750 C_fctexport C_word C_fcall C_callback_wrapper(void *proc, int argc);
1751 C_fctexport void C_fcall C_callback_adjust_stack(C_word *base, int size);
1752 C_fctexport void CHICKEN_parse_command_line(int argc, char *argv[], C_word *heap, C_word *stack, C_word *symbols);
1753 C_fctexport void C_fcall C_toplevel_entry(C_char *name) C_regparm;
1754 C_fctexport C_word C_fcall C_a_i_provide(C_word **a, int c, C_word id) C_regparm;
1755 C_fctexport C_word C_fcall C_i_providedp(C_word id) C_regparm;
1756 C_fctexport C_word C_fcall C_enable_interrupts(void) C_regparm;
1757 C_fctexport C_word C_fcall C_disable_interrupts(void) C_regparm;
1758 C_fctexport void C_set_or_change_heap_size(C_word heap, int reintern);
1759 C_fctexport void C_do_resize_stack(C_word stack);
1760 C_fctexport C_word C_resize_pending_finalizers(C_word size);
1761 C_fctexport void C_initialize_lf(C_word *lf, int count);
1762 C_fctexport void *C_register_lf(C_word *lf, int count);
1763 C_fctexport void *C_register_lf2(C_word *lf, int count, C_PTABLE_ENTRY *ptable);
1764 C_fctexport void C_unregister_lf(void *handle);
1765 C_fctexport C_char *C_dump_trace(int start);
1766 C_fctexport void C_fcall C_clear_trace_buffer(void) C_regparm;
1767 C_fctexport C_word C_resize_trace_buffer(C_word size);
1768 C_fctexport C_word C_fetch_trace(C_word start, C_word buffer);
1769 C_fctexport C_word C_fcall C_string(C_word **ptr, int len, C_char *str) C_regparm;
1770 C_fctexport C_word C_fcall C_static_string(C_word **ptr, int len, C_char *str) C_regparm;
1771 C_fctexport C_word C_fcall C_static_bignum(C_word **ptr, int len, C_char *str) C_regparm;
1772 C_fctexport C_word C_fcall C_static_bytevector(C_word **ptr, int len, C_char *str) C_regparm;
1773 C_fctexport C_word C_fcall C_static_lambda_info(C_word **ptr, int len, C_char *str) C_regparm;
1774 C_fctexport C_word C_fcall C_bytevector(C_word **ptr, int len, C_char *str) C_regparm;
1775 C_fctexport C_word C_fcall C_pbytevector(int len, C_char *str) C_regparm;
1776 C_fctexport C_word C_fcall C_string_aligned8(C_word **ptr, int len, C_char *str) C_regparm;
1777 C_fctexport C_word C_fcall C_string2(C_word **ptr, C_char *str) C_regparm;
1778 C_fctexport C_word C_fcall C_string2_safe(C_word **ptr, int max, C_char *str) C_regparm;
1779 C_fctexport C_word C_fcall C_intern(C_word **ptr, int len, C_char *str) C_regparm;
1780 C_fctexport C_word C_fcall C_intern_kw(C_word **ptr, int len, C_char *str) C_regparm;
1781 C_fctexport C_word C_fcall C_intern_in(C_word **ptr, int len, C_char *str, C_SYMBOL_TABLE *stable) C_regparm;
1782 C_fctexport C_word C_fcall C_h_intern(C_word *slot, int len, C_char *str) C_regparm;
1783 C_fctexport C_word C_fcall C_h_intern_kw(C_word *slot, int len, C_char *str) C_regparm;
1784 C_fctexport C_word C_fcall C_h_intern_in(C_word *slot, int len, C_char *str, C_SYMBOL_TABLE *stable) C_regparm;
1785 C_fctexport C_word C_fcall C_intern2(C_word **ptr, C_char *str) C_regparm;
1786 C_fctexport C_word C_fcall C_intern3(C_word **ptr, C_char *str, C_word value) C_regparm;
1787 C_fctexport C_word C_fcall C_build_rest(C_word **ptr, C_word c, C_word n, C_word *av) C_regparm;
1788 C_fctexport void C_bad_memory(void) C_noret;
1789 C_fctexport void C_bad_memory_2(void) C_noret;
1790 C_fctexport void C_bad_argc(int c, int n) C_noret;
1791 C_fctexport void C_bad_min_argc(int c, int n) C_noret;
1792 C_fctexport void C_bad_argc_2(int c, int n, C_word closure) C_noret;
1793 C_fctexport void C_bad_min_argc_2(int c, int n, C_word closure) C_noret;
1794 C_fctexport void C_stack_overflow(C_char *loc) C_noret;
1795 C_fctexport void C_unbound_error(C_word sym) C_noret;
1796 C_fctexport void C_no_closure_error(C_word x) C_noret;
1797 C_fctexport void C_div_by_zero_error(char *loc) C_noret;
1798 C_fctexport void C_not_an_integer_error(char *loc, C_word x) C_noret;
1799 C_fctexport void C_not_an_uinteger_error(char *loc, C_word x) C_noret;
1800 C_fctexport void C_rest_arg_out_of_bounds_error(C_word c, C_word n, C_word ka) C_noret;
1801 C_fctexport void C_rest_arg_out_of_bounds_error_2(C_word c, C_word n, C_word ka, C_word closure) C_noret;
1802 C_fctexport C_word C_closure(C_word **ptr, int cells, C_word proc, ...);
1803 C_fctexport C_word C_fcall C_pair(C_word **ptr, C_word car, C_word cdr) C_regparm;
1804 C_fctexport C_word C_fcall C_number(C_word **ptr, double n) C_regparm;
1805 C_fctexport C_word C_fcall C_mpointer(C_word **ptr, void *mp) C_regparm;
1806 C_fctexport C_word C_fcall C_mpointer_or_false(C_word **ptr, void *mp) C_regparm;
1807 C_fctexport C_word C_fcall C_taggedmpointer(C_word **ptr, C_word tag, void *mp) C_regparm;
1808 C_fctexport C_word C_fcall C_taggedmpointer_or_false(C_word **ptr, C_word tag, void *mp) C_regparm;
1809 C_fctexport C_word C_vector(C_word **ptr, int n, ...);
1810 C_fctexport C_word C_structure(C_word **ptr, int n, ...);
1811 C_fctexport C_word C_fcall C_mutate_slot(C_word *slot, C_word val) C_regparm;
1812 C_fctexport C_word C_fcall C_scratch_alloc(C_uword size) C_regparm;
1813 C_fctexport C_word C_fcall C_migrate_buffer_object(C_word **ptr, C_word *start, C_word *end, C_word obj) C_regparm;
1814 C_fctexport void C_fcall C_reclaim(void *trampoline, C_word c) C_regparm C_noret;
1815 C_fctexport void C_save_and_reclaim(void *trampoline, int n, C_word *av) C_noret;
1816 C_fctexport void C_save_and_reclaim_args(void *trampoline, int n, ...) C_noret;
1817 C_fctexport void C_fcall C_rereclaim2(C_uword size, int relative_resize) C_regparm;
1818 C_fctexport void C_unbound_variable(C_word sym);
1819 C_fctexport C_word C_fcall C_retrieve2(C_word val, char *name) C_regparm;
1820 C_fctexport void *C_fcall C_retrieve2_symbol_proc(C_word val, char *name) C_regparm;
1821 C_fctexport int C_in_stackp(C_word x) C_regparm;
1822 C_fctexport int C_fcall C_in_heapp(C_word x) C_regparm;
1823 C_fctexport int C_fcall C_in_fromspacep(C_word x) C_regparm;
1824 C_fctexport int C_fcall C_in_scratchspacep(C_word x) C_regparm;
1825 C_fctexport void C_fcall C_trace(C_char *name) C_regparm;
1826 C_fctexport C_word C_fcall C_emit_trace_info2(char *raw, C_word x, C_word y, C_word t) C_regparm;
1827 C_fctexport C_word C_fcall C_u_i_string_hash(C_word str, C_word rnd) C_regparm;
1828 C_fctexport C_word C_fcall C_u_i_string_ci_hash(C_word str, C_word rnd) C_regparm;
1829 C_fctexport C_word C_halt(C_word msg);
1830 C_fctexport C_word C_message(C_word msg);
1831 C_fctexport C_word C_fcall C_equalp(C_word x, C_word y) C_regparm;
1832 C_fctexport C_word C_fcall C_set_gc_report(C_word flag) C_regparm;
1833 C_fctexport C_word C_fcall C_start_timer(void) C_regparm;
1834 C_fctexport C_word C_exit_runtime(C_word code) C_noret;
1835 C_fctexport C_word C_fcall C_set_print_precision(C_word n) C_regparm;
1836 C_fctexport C_word C_fcall C_get_print_precision(void) C_regparm;
1837 C_fctexport C_word C_fcall C_read_char(C_word port) C_regparm;
1838 C_fctexport C_word C_fcall C_peek_char(C_word port) C_regparm;
1839 C_fctexport C_word C_fcall C_execute_shell_command(C_word string) C_regparm;
1840 C_fctexport int C_fcall C_check_fd_ready(int fd) C_regparm;
1841 C_fctexport C_word C_fcall C_char_ready_p(C_word port) C_regparm;
1842 C_fctexport void C_fcall C_raise_interrupt(int reason) C_regparm;
1843 C_fctexport C_word C_fcall C_establish_signal_handler(C_word signum, C_word reason) C_regparm;
1844 C_fctexport C_word C_fcall C_copy_block(C_word from, C_word to) C_regparm;
1845 C_fctexport C_word C_fcall C_evict_block(C_word from, C_word ptr) C_regparm;
1846 C_fctexport void C_fcall C_gc_protect(C_word **addr, int n) C_regparm;
1847 C_fctexport void C_fcall C_gc_unprotect(int n) C_regparm;
1848 C_fctexport C_SYMBOL_TABLE *C_new_symbol_table(char *name, unsigned int size) C_regparm;
1849 C_fctexport C_SYMBOL_TABLE *C_find_symbol_table(char *name) C_regparm;
1850 C_fctexport C_word C_find_symbol(C_word str, C_SYMBOL_TABLE *stable) C_regparm;
1851 C_fctexport C_word C_find_keyword(C_word str, C_SYMBOL_TABLE *stable) C_regparm;
1852 C_fctexport C_word C_fcall C_lookup_symbol(C_word sym) C_regparm;
1853 C_fctexport void C_do_register_finalizer(C_word x, C_word proc);
1854 C_fctexport int C_do_unregister_finalizer(C_word x);
1855 C_fctexport C_word C_dbg_hook(C_word x);
1856 C_fctexport void C_use_private_repository(C_char *path);
1857 C_fctexport C_char *C_private_repository_path();
1858 C_fctexport C_char *C_executable_dirname();
1859 C_fctexport C_char *C_executable_pathname();
1860 C_fctexport C_char *C_resolve_executable_pathname(C_char *fname);
1861
1862 C_fctimport C_cpsproc(C_toplevel) C_noret;
1863 C_fctimport C_cpsproc(C_invalid_procedure) C_noret;
1864 C_fctexport C_cpsproc(C_stop_timer) C_noret;
1865 C_fctexport C_cpsproc(C_signum) C_noret;
1866 C_fctexport C_cpsproc(C_apply) C_noret;
1867 C_fctexport C_cpsproc(C_call_cc) C_noret;
1868 C_fctexport C_cpsproc(C_continuation_graft) C_noret;
1869 C_fctexport C_cpsproc(C_values) C_noret;
1870 C_fctexport C_cpsproc(C_apply_values) C_noret;
1871 C_fctexport C_cpsproc(C_call_with_values) C_noret;
1872 C_fctexport C_cpsproc(C_u_call_with_values) C_noret;
1873 C_fctexport C_cpsproc(C_times) C_noret;
1874 C_fctexport C_cpsproc(C_plus) C_noret;
1875 C_fctexport C_cpsproc(C_minus) C_noret;
1876 C_fctexport C_cpsproc(C_quotient_and_remainder) C_noret;
1877 C_fctexport C_cpsproc(C_u_integer_quotient_and_remainder) C_noret;
1878 C_fctexport C_cpsproc(C_bitwise_and) C_noret;
1879 C_fctexport C_cpsproc(C_bitwise_ior) C_noret;
1880 C_fctexport C_cpsproc(C_bitwise_xor) C_noret;
1881
1882 C_fctexport C_cpsproc(C_nequalp) C_noret;
1883 C_fctexport C_cpsproc(C_greaterp) C_noret;
1884 C_fctexport C_cpsproc(C_lessp) C_noret;
1885 C_fctexport C_cpsproc(C_greater_or_equal_p) C_noret;
1886 C_fctexport C_cpsproc(C_less_or_equal_p) C_noret;
1887 C_fctexport C_cpsproc(C_gc) C_noret;
1888 C_fctexport C_cpsproc(C_open_file_port) C_noret;
1889 C_fctexport C_cpsproc(C_allocate_vector) C_noret;
1890 C_fctexport C_cpsproc(C_string_to_symbol) C_noret;
1891 C_fctexport C_cpsproc(C_string_to_keyword) C_noret;
1892 C_fctexport C_cpsproc(C_build_symbol) C_noret;
1893 C_fctexport C_cpsproc(C_number_to_string) C_noret;
1894 C_fctexport C_cpsproc(C_fixnum_to_string) C_noret;
1895 C_fctexport C_cpsproc(C_flonum_to_string) C_noret;
1896 C_fctexport C_cpsproc(C_integer_to_string) C_noret;
1897 C_fctexport C_cpsproc(C_make_structure) C_noret;
1898 C_fctexport C_cpsproc(C_make_symbol) C_noret;
1899 C_fctexport C_cpsproc(C_make_pointer) C_noret;
1900 C_fctexport C_cpsproc(C_make_tagged_pointer) C_noret;
1901 C_fctexport C_cpsproc(C_ensure_heap_reserve) C_noret;
1902 C_fctexport C_cpsproc(C_return_to_host) C_noret;
1903 C_fctexport C_cpsproc(C_get_symbol_table_info) C_noret;
1904 C_fctexport C_cpsproc(C_get_memory_info) C_noret;
1905 C_fctexport C_cpsproc(C_context_switch) C_noret;
1906 C_fctexport C_cpsproc(C_peek_signed_integer) C_noret;
1907 C_fctexport C_cpsproc(C_peek_unsigned_integer) C_noret;
1908 C_fctexport C_cpsproc(C_peek_int64) C_noret;
1909 C_fctexport C_cpsproc(C_peek_uint64) C_noret;
1910 C_fctexport C_cpsproc(C_decode_seconds) C_noret;
1911 C_fctexport C_cpsproc(C_software_type) C_noret;
1912 C_fctexport C_cpsproc(C_machine_type) C_noret;
1913 C_fctexport C_cpsproc(C_machine_byte_order) C_noret;
1914 C_fctexport C_cpsproc(C_software_version) C_noret;
1915 C_fctexport C_cpsproc(C_build_platform) C_noret;
1916 C_fctexport C_cpsproc(C_register_finalizer) C_noret;
1917 C_fctexport C_cpsproc(C_set_dlopen_flags) C_noret;
1918 C_fctexport C_cpsproc(C_dload) C_noret;
1919 C_fctexport C_cpsproc(C_become) C_noret;
1920 C_fctexport C_cpsproc(C_call_with_cthulhu) C_noret;
1921 C_fctexport C_cpsproc(C_copy_closure) C_noret;
1922 C_fctexport C_cpsproc(C_dump_heap_state) C_noret;
1923 C_fctexport C_cpsproc(C_filter_heap_objects) C_noret;
1924
1925 C_fctexport time_t C_fcall C_seconds(C_long *ms) C_regparm;
1926 C_fctexport C_word C_fcall C_bignum_simplify(C_word big) C_regparm;
1927 C_fctexport C_word C_fcall C_allocate_scratch_bignum(C_word **ptr, C_word size, C_word negp, C_word initp) C_regparm;
1928 C_fctexport C_word C_fcall C_bignum_rewrap(C_word **p, C_word big) C_regparm;
1929 C_fctexport C_word C_i_dump_statistical_profile();
1930 C_fctexport C_word C_a_i_list(C_word **a, int c, ...);
1931 C_fctexport C_word C_a_i_string(C_word **a, int c, ...);
1932 C_fctexport C_word C_a_i_record(C_word **a, int c, ...);
1933 C_fctexport C_word C_a_i_port(C_word **a, int c);
1934 C_fctexport C_word C_fcall C_a_i_bytevector(C_word **a, int c, C_word x) C_regparm;
1935 C_fctexport C_word C_fcall C_i_listp(C_word x) C_regparm;
1936 C_fctexport C_word C_fcall C_i_u8vectorp(C_word x) C_regparm;
1937 C_fctexport C_word C_fcall C_i_s8vectorp(C_word x) C_regparm;
1938 C_fctexport C_word C_fcall C_i_u16vectorp(C_word x) C_regparm;
1939 C_fctexport C_word C_fcall C_i_s16vectorp(C_word x) C_regparm;
1940 C_fctexport C_word C_fcall C_i_u32vectorp(C_word x) C_regparm;
1941 C_fctexport C_word C_fcall C_i_s32vectorp(C_word x) C_regparm;
1942 C_fctexport C_word C_fcall C_i_u64vectorp(C_word x) C_regparm;
1943 C_fctexport C_word C_fcall C_i_s64vectorp(C_word x) C_regparm;
1944 C_fctexport C_word C_fcall C_i_f32vectorp(C_word x) C_regparm;
1945 C_fctexport C_word C_fcall C_i_f64vectorp(C_word x) C_regparm;
1946 C_fctexport C_word C_fcall C_i_string_equal_p(C_word x, C_word y) C_regparm;
1947 C_fctexport C_word C_fcall C_i_string_ci_equal_p(C_word x, C_word y) C_regparm;
1948 C_fctexport C_word C_fcall C_i_set_car(C_word p, C_word x) C_regparm;
1949 C_fctexport C_word C_fcall C_i_set_cdr(C_word p, C_word x) C_regparm;
1950 C_fctexport C_word C_fcall C_i_vector_set(C_word v, C_word i, C_word x) C_regparm;
1951 C_fctexport C_word C_fcall C_i_u8vector_set(C_word v, C_word i, C_word x) C_regparm;
1952 C_fctexport C_word C_fcall C_i_s8vector_set(C_word v, C_word i, C_word x) C_regparm;
1953 C_fctexport C_word C_fcall C_i_u16vector_set(C_word v, C_word i, C_word x) C_regparm;
1954 C_fctexport C_word C_fcall C_i_s16vector_set(C_word v, C_word i, C_word x) C_regparm;
1955 C_fctexport C_word C_fcall C_i_u32vector_set(C_word v, C_word i, C_word x) C_regparm;
1956 C_fctexport C_word C_fcall C_i_s32vector_set(C_word v, C_word i, C_word x) C_regparm;
1957 C_fctexport C_word C_fcall C_i_u64vector_set(C_word v, C_word i, C_word x) C_regparm;
1958 C_fctexport C_word C_fcall C_i_s64vector_set(C_word v, C_word i, C_word x) C_regparm;
1959 C_fctexport C_word C_fcall C_i_f32vector_set(C_word v, C_word i, C_word x) C_regparm;
1960 C_fctexport C_word C_fcall C_i_f64vector_set(C_word v, C_word i, C_word x) C_regparm;
1961 C_fctexport C_word C_fcall C_i_exactp(C_word x) C_regparm;
1962 C_fctexport C_word C_fcall C_i_inexactp(C_word x) C_regparm;
1963 C_fctexport C_word C_fcall C_i_nanp(C_word x) C_regparm;
1964 C_fctexport C_word C_fcall C_i_finitep(C_word x) C_regparm;
1965 C_fctexport C_word C_fcall C_i_infinitep(C_word x) C_regparm;
1966 C_fctexport C_word C_fcall C_i_zerop(C_word x) C_regparm;
1967 C_fctexport C_word C_fcall C_u_i_zerop(C_word x) C_regparm; /* DEPRECATED */
1968 C_fctexport C_word C_fcall C_i_positivep(C_word x) C_regparm;
1969 C_fctexport C_word C_fcall C_i_integer_positivep(C_word x) C_regparm;
1970 C_fctexport C_word C_fcall C_i_negativep(C_word x) C_regparm;
1971 C_fctexport C_word C_fcall C_i_integer_negativep(C_word x) C_regparm;
1972 C_fctexport C_word C_fcall C_i_car(C_word x) C_regparm;
1973 C_fctexport C_word C_fcall C_i_cdr(C_word x) C_regparm;
1974 C_fctexport C_word C_fcall C_i_caar(C_word x) C_regparm;
1975 C_fctexport C_word C_fcall C_i_cadr(C_word x) C_regparm;
1976 C_fctexport C_word C_fcall C_i_cdar(C_word x) C_regparm;
1977 C_fctexport C_word C_fcall C_i_cddr(C_word x) C_regparm;
1978 C_fctexport C_word C_fcall C_i_caddr(C_word x) C_regparm;
1979 C_fctexport C_word C_fcall C_i_cdddr(C_word x) C_regparm;
1980 C_fctexport C_word C_fcall C_i_cadddr(C_word x) C_regparm;
1981 C_fctexport C_word C_fcall C_i_cddddr(C_word x) C_regparm;
1982 C_fctexport C_word C_fcall C_i_list_tail(C_word lst, C_word i) C_regparm;
1983 C_fctexport C_word C_fcall C_i_evenp(C_word x) C_regparm;
1984 C_fctexport C_word C_fcall C_i_integer_evenp(C_word x) C_regparm;
1985 C_fctexport C_word C_fcall C_i_oddp(C_word x) C_regparm;
1986 C_fctexport C_word C_fcall C_i_integer_oddp(C_word x) C_regparm;
1987 C_fctexport C_word C_fcall C_i_vector_ref(C_word v, C_word i) C_regparm;
1988 C_fctexport C_word C_fcall C_i_u8vector_ref(C_word v, C_word i) C_regparm;
1989 C_fctexport C_word C_fcall C_i_s8vector_ref(C_word v, C_word i) C_regparm;
1990 C_fctexport C_word C_fcall C_i_u16vector_ref(C_word v, C_word i) C_regparm;
1991 C_fctexport C_word C_fcall C_i_s16vector_ref(C_word v, C_word i) C_regparm;
1992 C_fctexport C_word C_fcall C_a_i_u32vector_ref(C_word **ptr, C_word c, C_word v, C_word i) C_regparm;
1993 C_fctexport C_word C_fcall C_a_i_s32vector_ref(C_word **ptr, C_word c, C_word v, C_word i) C_regparm;
1994 C_fctexport C_word C_fcall C_a_i_u64vector_ref(C_word **ptr, C_word c, C_word v, C_word i) C_regparm;
1995 C_fctexport C_word C_fcall C_a_i_s64vector_ref(C_word **ptr, C_word c, C_word v, C_word i) C_regparm;
1996 C_fctexport C_word C_fcall C_a_i_f32vector_ref(C_word **ptr, C_word c, C_word v, C_word i) C_regparm;
1997 C_fctexport C_word C_fcall C_a_i_f64vector_ref(C_word **ptr, C_word c, C_word v, C_word i) C_regparm;
1998 C_fctexport C_word C_fcall C_i_block_ref(C_word x, C_word i) C_regparm;
1999 C_fctexport C_word C_fcall C_i_string_set(C_word s, C_word i, C_word c) C_regparm;
2000 C_fctexport C_word C_fcall C_i_string_ref(C_word s, C_word i) C_regparm;
2001 C_fctexport C_word C_fcall C_i_vector_length(C_word v) C_regparm;
2002 C_fctexport C_word C_fcall C_i_u8vector_length(C_word v) C_regparm;
2003 C_fctexport C_word C_fcall C_i_s8vector_length(C_word v) C_regparm;
2004 C_fctexport C_word C_fcall C_i_u16vector_length(C_word v) C_regparm;
2005 C_fctexport C_word C_fcall C_i_s16vector_length(C_word v) C_regparm;
2006 C_fctexport C_word C_fcall C_i_u32vector_length(C_word v) C_regparm;
2007 C_fctexport C_word C_fcall C_i_s32vector_length(C_word v) C_regparm;
2008 C_fctexport C_word C_fcall C_i_u64vector_length(C_word v) C_regparm;
2009 C_fctexport C_word C_fcall C_i_s64vector_length(C_word v) C_regparm;
2010 C_fctexport C_word C_fcall C_i_f32vector_length(C_word v) C_regparm;
2011 C_fctexport C_word C_fcall C_i_f64vector_length(C_word v) C_regparm;
2012 C_fctexport C_word C_fcall C_i_string_length(C_word s) C_regparm;
2013 C_fctexport C_word C_fcall C_i_assq(C_word x, C_word lst) C_regparm;
2014 C_fctexport C_word C_fcall C_i_assv(C_word x, C_word lst) C_regparm;
2015 C_fctexport C_word C_fcall C_i_assoc(C_word x, C_word lst) C_regparm;
2016 C_fctexport C_word C_fcall C_i_memq(C_word x, C_word lst) C_regparm;
2017 C_fctexport C_word C_fcall C_u_i_memq(C_word x, C_word lst) C_regparm;
2018 C_fctexport C_word C_fcall C_i_memv(C_word x, C_word lst) C_regparm;
2019 C_fctexport C_word C_fcall C_i_member(C_word x, C_word lst) C_regparm;
2020 C_fctexport C_word C_fcall C_i_length(C_word lst) C_regparm;
2021 C_fctexport C_word C_fcall C_u_i_length(C_word lst) C_regparm;
2022 C_fctexport C_word C_fcall C_i_check_closure_2(C_word x, C_word loc) C_regparm;
2023 C_fctexport C_word C_fcall C_i_check_fixnum_2(C_word x, C_word loc) C_regparm;
2024 C_fctexport C_word C_fcall C_i_check_exact_2(C_word x, C_word loc) C_regparm; /* DEPRECATED */
2025 C_fctexport C_word C_fcall C_i_check_inexact_2(C_word x, C_word loc) C_regparm;
2026 C_fctexport C_word C_fcall C_i_check_number_2(C_word x, C_word loc) C_regparm;
2027 C_fctexport C_word C_fcall C_i_check_string_2(C_word x, C_word loc) C_regparm;
2028 C_fctexport C_word C_fcall C_i_check_bytevector_2(C_word x, C_word loc) C_regparm;
2029 C_fctexport C_word C_fcall C_i_check_symbol_2(C_word x, C_word loc) C_regparm;
2030 C_fctexport C_word C_fcall C_i_check_keyword_2(C_word x, C_word loc) C_regparm;
2031 C_fctexport C_word C_fcall C_i_check_list_2(C_word x, C_word loc) C_regparm;
2032 C_fctexport C_word C_fcall C_i_check_pair_2(C_word x, C_word loc) C_regparm;
2033 C_fctexport C_word C_fcall C_i_check_boolean_2(C_word x, C_word loc) C_regparm;
2034 C_fctexport C_word C_fcall C_i_check_locative_2(C_word x, C_word loc) C_regparm;
2035 C_fctexport C_word C_fcall C_i_check_vector_2(C_word x, C_word loc) C_regparm;
2036 C_fctexport C_word C_fcall C_i_check_structure_2(C_word x, C_word st, C_word loc) C_regparm;
2037 C_fctexport C_word C_fcall C_i_check_char_2(C_word x, C_word loc) C_regparm;
2038 C_fctexport C_word C_fcall C_i_check_port_2(C_word x, C_word in, C_word op, C_word loc) C_regparm;
2039 C_fctexport C_word C_fcall C_i_bignum_cmp(C_word x, C_word y) C_regparm;
2040 C_fctexport C_word C_fcall C_i_nequalp(C_word x, C_word y) C_regparm;
2041 C_fctexport C_word C_fcall C_i_integer_equalp(C_word x, C_word y) C_regparm;
2042 C_fctexport C_word C_fcall C_i_greaterp(C_word x, C_word y) C_regparm;
2043 C_fctexport C_word C_fcall C_i_integer_greaterp(C_word x, C_word y) C_regparm;
2044 C_fctexport C_word C_fcall C_i_lessp(C_word x, C_word y) C_regparm;
2045 C_fctexport C_word C_fcall C_i_integer_lessp(C_word x, C_word y) C_regparm;
2046 C_fctexport C_word C_fcall C_i_greater_or_equalp(C_word x, C_word y) C_regparm;
2047 C_fctexport C_word C_fcall C_i_integer_greater_or_equalp(C_word x, C_word y) C_regparm;
2048 C_fctexport C_word C_fcall C_i_less_or_equalp(C_word x, C_word y) C_regparm;
2049 C_fctexport C_word C_fcall C_i_integer_less_or_equalp(C_word x, C_word y) C_regparm;
2050 C_fctexport C_word C_fcall C_i_not_pair_p_2(C_word x) C_regparm;
2051 C_fctexport C_word C_fcall C_i_null_list_p(C_word x) C_regparm;
2052 C_fctexport C_word C_fcall C_i_string_null_p(C_word x) C_regparm;
2053 C_fctexport C_word C_fcall C_i_null_pointerp(C_word x) C_regparm;
2054 C_fctexport C_word C_fcall C_i_char_equalp(C_word x, C_word y) C_regparm;
2055 C_fctexport C_word C_fcall C_i_char_greaterp(C_word x, C_word y) C_regparm;
2056 C_fctexport C_word C_fcall C_i_char_lessp(C_word x, C_word y) C_regparm;
2057 C_fctexport C_word C_fcall C_i_char_greater_or_equal_p(C_word x, C_word y) C_regparm;
2058 C_fctexport C_word C_fcall C_i_char_less_or_equal_p(C_word x, C_word y) C_regparm;
2059 C_fctexport C_word C_fcall C_a_i_locative_ref(C_word **a, int c, C_word loc) C_regparm;
2060 C_fctexport C_word C_fcall C_i_locative_set(C_word loc, C_word x) C_regparm;
2061 C_fctexport C_word C_fcall C_i_locative_to_object(C_word loc) C_regparm;
2062 C_fctexport C_word C_fcall C_a_i_make_locative(C_word **a, int c, C_word type, C_word object, C_word index, C_word weak) C_regparm;
2063 C_fctexport C_word C_fcall C_i_bit_to_bool(C_word n, C_word i) C_regparm; /* DEPRECATED */
2064 C_fctexport C_word C_fcall C_i_integer_length(C_word x) C_regparm;
2065 C_fctexport C_word C_fcall C_a_i_exp(C_word **a, int c, C_word n) C_regparm;
2066 C_fctexport C_word C_fcall C_a_i_log(C_word **a, int c, C_word n) C_regparm;
2067 C_fctexport C_word C_fcall C_a_i_sin(C_word **a, int c, C_word n) C_regparm;
2068 C_fctexport C_word C_fcall C_a_i_cos(C_word **a, int c, C_word n) C_regparm;
2069 C_fctexport C_word C_fcall C_a_i_tan(C_word **a, int c, C_word n) C_regparm;
2070 C_fctexport C_word C_fcall C_a_i_asin(C_word **a, int c, C_word n) C_regparm;
2071 C_fctexport C_word C_fcall C_a_i_acos(C_word **a, int c, C_word n) C_regparm;
2072 C_fctexport C_word C_fcall C_a_i_atan(C_word **a, int c, C_word n) C_regparm;
2073 C_fctexport C_word C_fcall C_a_i_atan2(C_word **a, int c, C_word n1, C_word n2) C_regparm;
2074 C_fctexport C_word C_fcall C_a_i_sqrt(C_word **a, int c, C_word n) C_regparm;
2075 C_fctexport C_word C_fcall C_i_o_fixnum_plus(C_word x, C_word y) C_regparm;
2076 C_fctexport C_word C_fcall C_i_o_fixnum_difference(C_word x, C_word y) C_regparm;
2077 C_fctexport C_word C_fcall C_i_o_fixnum_times(C_word x, C_word y) C_regparm;
2078 C_fctexport C_word C_fcall C_i_o_fixnum_quotient(C_word x, C_word y) C_regparm;
2079 C_fctexport C_word C_fcall C_i_o_fixnum_and(C_word x, C_word y) C_regparm;
2080 C_fctexport C_word C_fcall C_i_o_fixnum_ior(C_word x, C_word y) C_regparm;
2081 C_fctexport C_word C_fcall C_i_o_fixnum_xor(C_word x, C_word y) C_regparm;
2082 C_fctexport C_word C_fcall C_a_i_flonum_round_proper(C_word **a, int c, C_word n) C_regparm;
2083 C_fctexport C_word C_fcall C_a_i_flonum_gcd(C_word **p, C_word n, C_word x, C_word y) C_regparm;
2084
2085 C_fctexport C_word C_fcall C_i_getprop(C_word sym, C_word prop, C_word def) C_regparm;
2086 C_fctexport C_word C_fcall C_putprop(C_word **a, C_word sym, C_word prop, C_word val) C_regparm;
2087 C_fctexport C_word C_fcall C_i_persist_symbol(C_word sym) C_regparm;
2088 C_fctexport C_word C_fcall C_i_unpersist_symbol(C_word sym) C_regparm;
2089 C_fctexport C_word C_fcall C_i_get_keyword(C_word key, C_word args, C_word def) C_regparm;
2090 C_fctexport C_word C_fcall C_i_process_sleep(C_word n) C_regparm;
2091 C_fctexport C_u64 C_fcall C_milliseconds(void) C_regparm; /* DEPRECATED */
2092 C_fctexport C_u64 C_fcall C_current_process_milliseconds(void) C_regparm;
2093 C_fctexport C_u64 C_fcall C_cpu_milliseconds(void) C_regparm;
2094 C_fctexport double C_fcall C_bignum_to_double(C_word bignum) C_regparm;
2095 C_fctexport C_word C_fcall C_i_debug_modep(void) C_regparm;
2096 C_fctexport C_word C_fcall C_i_dump_heap_on_exitp(void) C_regparm;
2097 C_fctexport C_word C_fcall C_i_accumulated_gc_time(void) C_regparm;
2098 C_fctexport C_word C_fcall C_i_allocated_finalizer_count(void) C_regparm;
2099 C_fctexport C_word C_fcall C_i_live_finalizer_count(void) C_regparm;
2100 C_fctexport C_word C_fcall C_i_profilingp(void) C_regparm;
2101 C_fctexport C_word C_fcall C_i_tty_forcedp(void) C_regparm;
2102
2103
2104 C_fctexport C_word C_fcall C_a_i_cpu_time(C_word **a, int c, C_word buf) C_regparm;
2105 C_fctexport C_word C_fcall C_a_i_exact_to_inexact(C_word **a, int c, C_word n) C_regparm;
2106 C_fctexport C_word C_fcall C_i_file_exists_p(C_word name, C_word file, C_word dir) C_regparm;
2107
2108 C_fctexport C_word C_fcall C_s_a_i_abs(C_word **ptr, C_word n, C_word x) C_regparm;
2109 C_fctexport C_word C_fcall C_s_a_i_negate(C_word **ptr, C_word n, C_word x) C_regparm;
2110 C_fctexport C_word C_fcall C_s_a_i_minus(C_word **ptr, C_word n, C_word x, C_word y) C_regparm;
2111 C_fctexport C_word C_fcall C_s_a_u_i_integer_negate(C_word **ptr, C_word n, C_word x) C_regparm;
2112 C_fctexport C_word C_fcall C_s_a_u_i_integer_minus(C_word **ptr, C_word n, C_word x, C_word y) C_regparm;
2113 C_fctexport C_word C_fcall C_s_a_i_plus(C_word **ptr, C_word n, C_word x, C_word y) C_regparm;
2114 C_fctexport C_word C_fcall C_s_a_u_i_integer_plus(C_word **ptr, C_word n, C_word x, C_word y) C_regparm;
2115 C_fctexport C_word C_fcall C_s_a_i_times(C_word **ptr, C_word n, C_word x, C_word y) C_regparm;
2116 C_fctexport C_word C_fcall C_s_a_u_i_integer_times(C_word **ptr, C_word n, C_word x, C_word y) C_regparm;
2117 C_fctexport C_word C_fcall C_s_a_i_arithmetic_shift(C_word **ptr, C_word n, C_word x, C_word y) C_regparm;
2118 C_fctexport C_word C_fcall C_s_a_u_i_integer_gcd(C_word **ptr, C_word n, C_word x, C_word y) C_regparm;
2119 C_fctexport C_word C_fcall C_s_a_i_quotient(C_word **ptr, C_word n, C_word x, C_word y) C_regparm;
2120 C_fctexport C_word C_fcall C_s_a_u_i_integer_quotient(C_word **ptr, C_word n, C_word x, C_word y) C_regparm;
2121 C_fctexport C_word C_fcall C_s_a_i_remainder(C_word **ptr, C_word n, C_word x, C_word y) C_regparm;
2122 C_fctexport C_word C_fcall C_s_a_u_i_integer_remainder(C_word **ptr, C_word n, C_word x, C_word y) C_regparm;
2123 C_fctexport C_word C_fcall C_s_a_i_modulo(C_word **ptr, C_word n, C_word x, C_word y) C_regparm;
2124 C_fctexport C_word C_fcall C_s_a_u_i_integer_modulo(C_word **ptr, C_word n, C_word x, C_word y) C_regparm;
2125 C_fctexport C_word C_fcall C_s_a_i_bitwise_and(C_word **ptr, C_word n, C_word x, C_word y) C_regparm;
2126 C_fctexport C_word C_fcall C_s_a_i_bitwise_ior(C_word **ptr, C_word n, C_word x, C_word y) C_regparm;
2127 C_fctexport C_word C_fcall C_s_a_i_bitwise_xor(C_word **ptr, C_word n, C_word x, C_word y) C_regparm;
2128 C_fctexport C_word C_fcall C_s_a_i_bitwise_not(C_word **ptr, C_word n, C_word x) C_regparm;
2129 C_fctexport C_word C_fcall C_s_a_i_digits_to_integer(C_word **ptr, C_word n, C_word str, C_word start, C_word end, C_word radix, C_word negp) C_regparm;
2130 C_fctexport C_word C_fcall C_s_a_u_i_flo_to_int(C_word **ptr, C_word n, C_word x) C_regparm;
2131
2132
2133 C_fctexport C_word C_fcall C_i_foreign_char_argumentp(C_word x) C_regparm;
2134 C_fctexport C_word C_fcall C_i_foreign_fixnum_argumentp(C_word x) C_regparm;
2135 C_fctexport C_word C_fcall C_i_foreign_flonum_argumentp(C_word x) C_regparm;
2136 C_fctexport C_word C_fcall C_i_foreign_block_argumentp(C_word x) C_regparm;
2137 C_fctexport C_word C_fcall C_i_foreign_struct_wrapper_argumentp(C_word t, C_word x) C_regparm;
2138 C_fctexport C_word C_fcall C_i_foreign_string_argumentp(C_word x) C_regparm;
2139 C_fctexport C_word C_fcall C_i_foreign_symbol_argumentp(C_word x) C_regparm;
2140 C_fctexport C_word C_fcall C_i_foreign_tagged_pointer_argumentp(C_word x, C_word t) C_regparm;
2141 C_fctexport C_word C_fcall C_i_foreign_pointer_argumentp(C_word x) C_regparm;
2142 C_fctexport C_word C_fcall C_i_foreign_scheme_or_c_pointer_argumentp(C_word x) C_regparm;
2143 C_fctexport C_word C_fcall C_i_foreign_ranged_integer_argumentp(C_word x, C_word bits) C_regparm;
2144 C_fctexport C_word C_fcall C_i_foreign_unsigned_ranged_integer_argumentp(C_word x, C_word bits) C_regparm;
2145
2146 C_fctexport C_char *C_lookup_procedure_id(void *ptr);
2147 C_fctexport void *C_lookup_procedure_ptr(C_char *id);
2148
2149 C_fctexport C_word C_random_fixnum(C_word n) C_regparm;
2150 C_fctexport C_word C_fcall C_s_a_u_i_random_int(C_word **ptr, C_word n, C_word rn) C_regparm;
2151 C_fctexport C_word C_fcall C_a_i_random_real(C_word **ptr, C_word n) C_regparm;
2152 C_fctexport C_word C_random_bytes(C_word buf, C_word size);
2153 C_fctexport C_word C_set_random_seed(C_word buf, C_word n);
2154
2155 #ifdef C_SIXTY_FOUR
2156 C_fctexport C_cpsproc(C_peek_signed_integer_32);
2157 C_fctexport C_cpsproc(C_peek_unsigned_integer_32);
2158 #else
2159 # define C_peek_signed_integer_32 C_peek_signed_integer
2160 # define C_peek_unsigned_integer_32 C_peek_unsigned_integer
2161 #endif
2162
2163 C_fctexport C_word C_fcall C_decode_literal(C_word **ptr, C_char *str) C_regparm;
2164 C_fctexport C_word C_fcall C_i_pending_interrupt(C_word dummy) C_regparm;
2165
2166 C_fctexport void *C_get_statistics(void);
2167
2168 /* defined in eval.scm: */
2169 C_fctexport void CHICKEN_get_error_message(char *buf,int bufsize);
2170 C_fctexport int CHICKEN_load(char * filename);
2171 C_fctexport int CHICKEN_read(char * str,C_word *result);
2172 C_fctexport int CHICKEN_apply_to_string(C_word func,C_word args,char *buf,int bufsize);
2173 C_fctexport int CHICKEN_apply(C_word func,C_word args,C_word *result);
2174 C_fctexport int CHICKEN_eval_string_to_string(char *str,char *buf,int bufsize);
2175 C_fctexport int CHICKEN_eval_to_string(C_word exp,char *buf,int bufsize);
2176 C_fctexport int CHICKEN_eval_string(char * str,C_word *result);
2177 C_fctexport int CHICKEN_eval(C_word exp,C_word *result);
2178 C_fctexport int CHICKEN_yield();
2179
2180 C_fctexport C_cpsproc(C_default_5fstub_toplevel);
2181
2182
2183 /* Inline functions: */
2184
2185 #ifndef HAVE_STATEMENT_EXPRESSIONS
2186
C_a_i(C_word ** a,int n)2187 inline static C_word *C_a_i(C_word **a, int n)
2188 {
2189 C_word *p = *a;
2190
2191 *a += n;
2192 return p;
2193 }
2194
2195 #endif
2196
2197 inline static C_word
C_mutate(C_word * slot,C_word val)2198 C_mutate(C_word *slot, C_word val)
2199 {
2200 if(!C_immediatep(val)) return C_mutate_slot(slot, val);
2201 else return *slot = val;
2202 }
2203
C_permanentp(C_word x)2204 inline static C_word C_permanentp(C_word x)
2205 {
2206 return C_mk_bool(!C_immediatep(x) &&
2207 !C_in_stackp(x) &&
2208 !C_in_heapp(x) &&
2209 !C_in_scratchspacep(x));
2210 }
2211
C_u_i_namespaced_symbolp(C_word x)2212 inline static C_word C_u_i_namespaced_symbolp(C_word x)
2213 {
2214 C_word s = C_symbol_name(x);
2215 return C_mk_bool(C_memchr(C_data_pointer(s), '#', C_header_size(s)));
2216 }
2217
C_flonum(C_word ** ptr,double n)2218 inline static C_word C_flonum(C_word **ptr, double n)
2219 {
2220 C_word
2221 *p = *ptr,
2222 *p0;
2223
2224 #ifndef C_SIXTY_FOUR
2225 #ifndef C_DOUBLE_IS_32_BITS
2226 /* Align double on 8-byte boundary: */
2227 if(C_aligned8(p)) ++p;
2228 #endif
2229 #endif
2230
2231 p0 = p;
2232 *(p++) = C_FLONUM_TAG;
2233 *((double *)p) = n;
2234 *ptr = p + sizeof(double) / sizeof(C_word);
2235 return (C_word)p0;
2236 }
2237
2238
C_u_i_zerop2(C_word x)2239 inline static C_word C_fcall C_u_i_zerop2(C_word x)
2240 {
2241 return C_mk_bool(x == C_fix(0) ||
2242 (!C_immediatep(x) &&
2243 C_block_header(x) == C_FLONUM_TAG &&
2244 C_flonum_magnitude(x) == 0.0));
2245 }
2246
2247
C_string_to_pbytevector(C_word s)2248 inline static C_word C_string_to_pbytevector(C_word s)
2249 {
2250 return C_pbytevector(C_header_size(s), (C_char *)C_data_pointer(s));
2251 }
2252
2253
C_a_i_record1(C_word ** ptr,int n,C_word x1)2254 inline static C_word C_a_i_record1(C_word **ptr, int n, C_word x1)
2255 {
2256 C_word *p = *ptr, *p0 = p;
2257
2258 *(p++) = C_STRUCTURE_TYPE | 1;
2259 *(p++) = x1;
2260 *ptr = p;
2261 return (C_word)p0;
2262 }
2263
2264
C_a_i_record2(C_word ** ptr,int n,C_word x1,C_word x2)2265 inline static C_word C_a_i_record2(C_word **ptr, int n, C_word x1, C_word x2)
2266 {
2267 C_word *p = *ptr, *p0 = p;
2268
2269 *(p++) = C_STRUCTURE_TYPE | 2;
2270 *(p++) = x1;
2271 *(p++) = x2;
2272 *ptr = p;
2273 return (C_word)p0;
2274 }
2275
2276
C_a_i_record3(C_word ** ptr,int n,C_word x1,C_word x2,C_word x3)2277 inline static C_word C_a_i_record3(C_word **ptr, int n, C_word x1, C_word x2, C_word x3)
2278 {
2279 C_word *p = *ptr, *p0 = p;
2280
2281 *(p++) = C_STRUCTURE_TYPE | 3;
2282 *(p++) = x1;
2283 *(p++) = x2;
2284 *(p++) = x3;
2285 *ptr = p;
2286 return (C_word)p0;
2287 }
2288
2289
C_a_i_record4(C_word ** ptr,int n,C_word x1,C_word x2,C_word x3,C_word x4)2290 inline static C_word C_a_i_record4(C_word **ptr, int n, C_word x1, C_word x2, C_word x3, C_word x4)
2291 {
2292 C_word *p = *ptr, *p0 = p;
2293
2294 *(p++) = C_STRUCTURE_TYPE | 4;
2295 *(p++) = x1;
2296 *(p++) = x2;
2297 *(p++) = x3;
2298 *(p++) = x4;
2299 *ptr = p;
2300 return (C_word)p0;
2301 }
2302
2303
C_a_i_record5(C_word ** ptr,int n,C_word x1,C_word x2,C_word x3,C_word x4,C_word x5)2304 inline static C_word C_a_i_record5(C_word **ptr, int n, C_word x1, C_word x2, C_word x3, C_word x4,
2305 C_word x5)
2306 {
2307 C_word *p = *ptr, *p0 = p;
2308
2309 *(p++) = C_STRUCTURE_TYPE | 5;
2310 *(p++) = x1;
2311 *(p++) = x2;
2312 *(p++) = x3;
2313 *(p++) = x4;
2314 *(p++) = x5;
2315 *ptr = p;
2316 return (C_word)p0;
2317 }
2318
2319
C_a_i_record6(C_word ** ptr,int n,C_word x1,C_word x2,C_word x3,C_word x4,C_word x5,C_word x6)2320 inline static C_word C_a_i_record6(C_word **ptr, int n, C_word x1, C_word x2, C_word x3, C_word x4,
2321 C_word x5, C_word x6)
2322 {
2323 C_word *p = *ptr, *p0 = p;
2324
2325 *(p++) = C_STRUCTURE_TYPE | 6;
2326 *(p++) = x1;
2327 *(p++) = x2;
2328 *(p++) = x3;
2329 *(p++) = x4;
2330 *(p++) = x5;
2331 *(p++) = x6;
2332 *ptr = p;
2333 return (C_word)p0;
2334 }
2335
2336
C_a_i_record7(C_word ** ptr,int n,C_word x1,C_word x2,C_word x3,C_word x4,C_word x5,C_word x6,C_word x7)2337 inline static C_word C_a_i_record7(C_word **ptr, int n, C_word x1, C_word x2, C_word x3, C_word x4,
2338 C_word x5, C_word x6, C_word x7)
2339 {
2340 C_word *p = *ptr, *p0 = p;
2341
2342 *(p++) = C_STRUCTURE_TYPE | 7;
2343 *(p++) = x1;
2344 *(p++) = x2;
2345 *(p++) = x3;
2346 *(p++) = x4;
2347 *(p++) = x5;
2348 *(p++) = x6;
2349 *(p++) = x7;
2350 *ptr = p;
2351 return (C_word)p0;
2352 }
2353
2354
C_a_i_record8(C_word ** ptr,int n,C_word x1,C_word x2,C_word x3,C_word x4,C_word x5,C_word x6,C_word x7,C_word x8)2355 inline static C_word C_a_i_record8(C_word **ptr, int n, C_word x1, C_word x2, C_word x3, C_word x4,
2356 C_word x5, C_word x6, C_word x7, C_word x8)
2357 {
2358 C_word *p = *ptr, *p0 = p;
2359
2360 *(p++) = C_STRUCTURE_TYPE | 8;
2361 *(p++) = x1;
2362 *(p++) = x2;
2363 *(p++) = x3;
2364 *(p++) = x4;
2365 *(p++) = x5;
2366 *(p++) = x6;
2367 *(p++) = x7;
2368 *(p++) = x8;
2369 *ptr = p;
2370 return (C_word)p0;
2371 }
2372
C_cplxnum(C_word ** ptr,C_word r,C_word i)2373 inline static C_word C_cplxnum(C_word **ptr, C_word r, C_word i)
2374 {
2375 C_word *p = *ptr, *p0 = p;
2376
2377 *(p++) = C_CPLXNUM_TAG;
2378 *(p++) = r;
2379 *(p++) = i;
2380 *ptr = p;
2381 return (C_word)p0;
2382 }
2383
C_ratnum(C_word ** ptr,C_word n,C_word d)2384 inline static C_word C_ratnum(C_word **ptr, C_word n, C_word d)
2385 {
2386 C_word *p = *ptr, *p0 = p;
2387
2388 *(p++) = C_RATNUM_TAG;
2389 *(p++) = n;
2390 *(p++) = d;
2391 *ptr = p;
2392 return (C_word)p0;
2393 }
2394
C_a_i_bignum_wrapper(C_word ** ptr,C_word vec)2395 inline static C_word C_a_i_bignum_wrapper(C_word **ptr, C_word vec)
2396 {
2397 C_word *p = *ptr, *p0 = p;
2398
2399 *(p++) = C_BIGNUM_TAG;
2400 *(p++) = vec;
2401 *ptr = p;
2402 return (C_word)p0;
2403 }
2404
2405 /* Silly (this is not normalized) but in some cases needed internally */
C_bignum0(C_word ** ptr)2406 inline static C_word C_bignum0(C_word **ptr)
2407 {
2408 C_word *p = *ptr, p0 = (C_word)p;
2409
2410 *(p++) = C_STRING_TYPE | C_wordstobytes(1);
2411 *(p++) = 0; /* zero is always positive */
2412 *ptr = p;
2413
2414 return C_a_i_bignum_wrapper(ptr, p0);
2415 }
2416
C_bignum1(C_word ** ptr,int negp,C_uword d1)2417 inline static C_word C_bignum1(C_word **ptr, int negp, C_uword d1)
2418 {
2419 C_word *p = *ptr, p0 = (C_word)p;
2420
2421 *(p++) = C_STRING_TYPE | C_wordstobytes(2);
2422 *(p++) = negp;
2423 *(p++) = d1;
2424 *ptr = p;
2425
2426 return C_a_i_bignum_wrapper(ptr, p0);
2427 }
2428
2429 /* Here d1, d2, ... are low to high (ie, little endian)! */
C_bignum2(C_word ** ptr,int negp,C_uword d1,C_uword d2)2430 inline static C_word C_bignum2(C_word **ptr, int negp, C_uword d1, C_uword d2)
2431 {
2432 C_word *p = *ptr, p0 = (C_word)p;
2433
2434 *(p++) = C_STRING_TYPE | C_wordstobytes(3);
2435 *(p++) = negp;
2436 *(p++) = d1;
2437 *(p++) = d2;
2438 *ptr = p;
2439
2440 return C_a_i_bignum_wrapper(ptr, p0);
2441 }
2442
C_i_bignump(C_word x)2443 inline static C_word C_i_bignump(C_word x)
2444 {
2445 return C_mk_bool(!C_immediatep(x) && C_block_header(x) == C_BIGNUM_TAG);
2446 }
2447
2448
C_c_double(C_word x)2449 inline static double C_c_double(C_word x)
2450 {
2451 if(x & C_FIXNUM_BIT) return (double)C_unfix(x);
2452 else return C_flonum_magnitude(x);
2453 }
2454
C_a_u_i_int_to_flo(C_word ** ptr,int n,C_word x)2455 inline static C_word C_a_u_i_int_to_flo(C_word **ptr, int n, C_word x)
2456 {
2457 if(x & C_FIXNUM_BIT) return C_a_i_fix_to_flo(ptr, n, x);
2458 else return C_a_u_i_big_to_flo(ptr, n, x);
2459 }
2460
C_num_to_int(C_word x)2461 inline static C_word C_num_to_int(C_word x)
2462 {
2463 if(x & C_FIXNUM_BIT) {
2464 return C_unfix(x);
2465 } else {
2466 #if DEBUGBUILD /* removes a warning with clang */
2467 C_CHECKp(x,C_bignump(C_VAL1(x)),0);
2468 #endif
2469 if (C_bignum_negativep(x)) return -(C_word)C_bignum_digits(x)[0];
2470 else return (C_word)C_bignum_digits(x)[0]; /* should never be larger */
2471 }
2472 }
2473
2474
C_num_to_int64(C_word x)2475 inline static C_s64 C_num_to_int64(C_word x)
2476 {
2477 if(x & C_FIXNUM_BIT) {
2478 return (C_s64)C_unfix(x);
2479 } else {
2480 C_s64 num = C_bignum_digits(x)[0];
2481 #ifndef C_SIXTY_FOUR
2482 if (C_bignum_size(x) > 1) num |= (C_s64)(((C_u64)C_bignum_digits(x)[1]) << 32);
2483 #endif
2484 if (C_bignum_negativep(x)) return -num;
2485 else return num;
2486 }
2487 }
2488
2489
C_num_to_uint64(C_word x)2490 inline static C_u64 C_num_to_uint64(C_word x)
2491 {
2492 if(x & C_FIXNUM_BIT) {
2493 return (C_u64)C_unfix(x);
2494 } else {
2495 C_s64 num = C_bignum_digits(x)[0];
2496 #ifndef C_SIXTY_FOUR
2497 if (C_bignum_size(x) > 1) num |= ((C_u64)C_bignum_digits(x)[1]) << 32;
2498 #endif
2499 return num;
2500 }
2501 }
2502
2503
C_num_to_unsigned_int(C_word x)2504 inline static C_uword C_num_to_unsigned_int(C_word x)
2505 {
2506 if(x & C_FIXNUM_BIT) {
2507 return (C_uword)C_unfix(x);
2508 } else {
2509 return C_bignum_digits(x)[0]; /* should never be larger */
2510 }
2511 }
2512
2513
C_int_to_num(C_word ** ptr,C_word n)2514 inline static C_word C_int_to_num(C_word **ptr, C_word n)
2515 {
2516 if(C_fitsinfixnump(n)) return C_fix(n);
2517 else return C_bignum1(ptr, n < 0, C_wabs(n));
2518 }
2519
2520
C_unsigned_int_to_num(C_word ** ptr,C_uword n)2521 inline static C_word C_unsigned_int_to_num(C_word **ptr, C_uword n)
2522 {
2523 if(C_ufitsinfixnump(n)) return C_fix(n);
2524 else return C_bignum1(ptr, 0, n);
2525 }
2526
C_int64_to_num(C_word ** ptr,C_s64 n)2527 inline static C_word C_int64_to_num(C_word **ptr, C_s64 n)
2528 {
2529 #ifdef C_SIXTY_FOUR
2530 if(C_fitsinfixnump(n)) {
2531 return C_fix(n);
2532 } else {
2533 C_u64 un = n < 0 ? -n : n;
2534 return C_bignum1(ptr, n < 0, un);
2535 }
2536 #else
2537 C_u64 un = n < 0 ? -n : n;
2538 C_word res = C_bignum2(ptr, n < 0, (C_uword)un, (C_uword)(un >> 32));
2539 return C_bignum_simplify(res);
2540 #endif
2541 }
2542
C_uint64_to_num(C_word ** ptr,C_u64 n)2543 inline static C_word C_uint64_to_num(C_word **ptr, C_u64 n)
2544 {
2545 if(C_ufitsinfixnump(n)) {
2546 return C_fix(n);
2547 } else {
2548 #ifdef C_SIXTY_FOUR
2549 return C_bignum1(ptr, 0, n);
2550 #else
2551 C_word res = C_bignum2(ptr, 0, (C_uword)n, (C_uword)(n >> 32));
2552 return C_bignum_simplify(res);
2553 #endif
2554 }
2555 }
2556
C_long_to_num(C_word ** ptr,C_long n)2557 inline static C_word C_long_to_num(C_word **ptr, C_long n)
2558 {
2559 if(C_fitsinfixnump(n)) {
2560 return C_fix(n);
2561 } else {
2562 return C_bignum1(ptr, n < 0, C_wabs(n));
2563 }
2564 }
2565
C_unsigned_long_to_num(C_word ** ptr,C_ulong n)2566 inline static C_word C_unsigned_long_to_num(C_word **ptr, C_ulong n)
2567 {
2568 if(C_ufitsinfixnump(n)) {
2569 return C_fix(n);
2570 } else {
2571 return C_bignum1(ptr, 0, n);
2572 }
2573 }
2574
2575
C_string_or_null(C_word x)2576 inline static char *C_string_or_null(C_word x)
2577 {
2578 return C_truep(x) ? C_c_string(x) : NULL;
2579 }
2580
2581
C_data_pointer_or_null(C_word x)2582 inline static void *C_data_pointer_or_null(C_word x)
2583 {
2584 return C_truep(x) ? C_data_pointer(x) : NULL;
2585 }
2586
2587
C_srfi_4_vector_or_null(C_word x)2588 inline static void *C_srfi_4_vector_or_null(C_word x)
2589 {
2590 return C_truep(x) ? C_srfi_4_vector(x) : NULL;
2591 }
2592
2593
C_c_pointer_vector_or_null(C_word x)2594 inline static void *C_c_pointer_vector_or_null(C_word x)
2595 {
2596 return C_truep(x) ? C_data_pointer(C_block_item(x, 2)) : NULL;
2597 }
2598
2599
C_c_pointer_or_null(C_word x)2600 inline static void *C_c_pointer_or_null(C_word x)
2601 {
2602 return C_truep(x) ? (void *)C_block_item(x, 0) : NULL;
2603 }
2604
2605
C_scheme_or_c_pointer(C_word x)2606 inline static void *C_scheme_or_c_pointer(C_word x)
2607 {
2608 return C_anypointerp(x) ? (void *)C_block_item(x, 0) : C_data_pointer(x);
2609 }
2610
2611
C_num_to_long(C_word x)2612 inline static C_long C_num_to_long(C_word x)
2613 {
2614 if(x & C_FIXNUM_BIT) {
2615 return (C_long)C_unfix(x);
2616 } else {
2617 if (C_bignum_negativep(x)) return -(C_long)C_bignum_digits(x)[0];
2618 else return (C_long)C_bignum_digits(x)[0];
2619 }
2620 }
2621
2622
C_num_to_unsigned_long(C_word x)2623 inline static C_ulong C_num_to_unsigned_long(C_word x)
2624 {
2625 if(x & C_FIXNUM_BIT) {
2626 return (C_ulong)C_unfix(x);
2627 } else {
2628 return (C_ulong)C_bignum_digits(x)[0];
2629 }
2630 }
2631
2632
C_u_i_string_equal_p(C_word x,C_word y)2633 inline static C_word C_u_i_string_equal_p(C_word x, C_word y)
2634 {
2635 C_uword n = C_header_size(x);
2636 return C_mk_bool(n == C_header_size(y)
2637 && !C_memcmp((char *)C_data_pointer(x), (char *)C_data_pointer(y), n));
2638 }
2639
2640 /* Like memcmp but case insensitive (to strncasecmp as memcmp is to strncmp) */
C_memcasecmp(const char * x,const char * y,unsigned int len)2641 inline static int C_memcasecmp(const char *x, const char *y, unsigned int len)
2642 {
2643 const unsigned char *ux = (const unsigned char *)x;
2644 const unsigned char *uy = (const unsigned char *)y;
2645
2646 while (len--) {
2647 if (tolower(*ux++) != tolower(*uy++))
2648 return (tolower(*--ux) - tolower(*--uy));
2649 }
2650 return 0;
2651 }
2652
C_ub_i_flonum_eqvp(double x,double y)2653 inline static C_word C_ub_i_flonum_eqvp(double x, double y)
2654 {
2655 /* This can distinguish between -0.0 and +0.0 */
2656 return x == y && signbit(x) == signbit(y);
2657 }
2658
basic_eqvp(C_word x,C_word y)2659 inline static C_word basic_eqvp(C_word x, C_word y)
2660 {
2661 return (x == y ||
2662
2663 (!C_immediatep(x) && !C_immediatep(y) &&
2664 C_block_header(x) == C_block_header(y) &&
2665
2666 ((C_block_header(x) == C_FLONUM_TAG &&
2667 C_ub_i_flonum_eqvp(C_flonum_magnitude(x),
2668 C_flonum_magnitude(y))) ||
2669
2670 (C_block_header(x) == C_BIGNUM_TAG &&
2671 C_block_header(y) == C_BIGNUM_TAG &&
2672 C_i_bignum_cmp(x, y) == C_fix(0)))));
2673 }
2674
C_i_eqvp(C_word x,C_word y)2675 inline static C_word C_i_eqvp(C_word x, C_word y)
2676 {
2677 return C_mk_bool(basic_eqvp(x, y) ||
2678 (!C_immediatep(x) && !C_immediatep(y) &&
2679 C_block_header(x) == C_block_header(y) &&
2680 (C_block_header(x) == C_RATNUM_TAG ||
2681 C_block_header(x) == C_CPLXNUM_TAG) &&
2682 basic_eqvp(C_block_item(x, 0), C_block_item(y, 0)) &&
2683 basic_eqvp(C_block_item(x, 1), C_block_item(y, 1))));
2684 }
2685
C_i_symbolp(C_word x)2686 inline static C_word C_i_symbolp(C_word x)
2687 {
2688 return C_mk_bool(!C_immediatep(x) &&
2689 C_block_header(x) == C_SYMBOL_TAG &&
2690 C_symbol_plist(x) != C_SCHEME_FALSE);
2691 }
2692
C_i_keywordp(C_word x)2693 inline static C_word C_i_keywordp(C_word x)
2694 {
2695 return C_mk_bool(!C_immediatep(x) &&
2696 C_block_header(x) == C_SYMBOL_TAG &&
2697 C_symbol_plist(x) == C_SCHEME_FALSE);
2698 }
2699
C_persistable_symbol(C_word x)2700 inline static int C_persistable_symbol(C_word x)
2701 {
2702 /* Symbol is bound, or has a non-empty plist (but is not a keyword) */
2703 return ((C_truep(C_boundp(x)) ||
2704 C_symbol_plist(x) != C_SCHEME_END_OF_LIST) &&
2705 C_symbol_plist(x) != C_SCHEME_FALSE);
2706 }
2707
C_i_pairp(C_word x)2708 inline static C_word C_i_pairp(C_word x)
2709 {
2710 return C_mk_bool(!C_immediatep(x) && C_block_header(x) == C_PAIR_TAG);
2711 }
2712
2713
C_i_stringp(C_word x)2714 inline static C_word C_i_stringp(C_word x)
2715 {
2716 return C_mk_bool(!C_immediatep(x) && C_header_bits(x) == C_STRING_TYPE);
2717 }
2718
2719
C_i_locativep(C_word x)2720 inline static C_word C_i_locativep(C_word x)
2721 {
2722 return C_mk_bool(!C_immediatep(x) && C_block_header(x) == C_LOCATIVE_TAG);
2723 }
2724
2725
C_i_vectorp(C_word x)2726 inline static C_word C_i_vectorp(C_word x)
2727 {
2728 return C_mk_bool(!C_immediatep(x) && C_header_bits(x) == C_VECTOR_TYPE);
2729 }
2730
C_i_srfi_4_vectorp(C_word x)2731 inline static C_word C_i_srfi_4_vectorp(C_word x)
2732 {
2733 return C_mk_bool(!C_immediatep(x) &&
2734 C_header_bits(x) == C_STRUCTURE_TYPE &&
2735 (C_truep(C_i_u8vectorp(x)) ||
2736 C_truep(C_i_s8vectorp(x)) ||
2737 C_truep(C_i_u16vectorp(x)) ||
2738 C_truep(C_i_s16vectorp(x)) ||
2739 C_truep(C_i_u32vectorp(x)) ||
2740 C_truep(C_i_s32vectorp(x)) ||
2741 C_truep(C_i_u64vectorp(x)) ||
2742 C_truep(C_i_s64vectorp(x)) ||
2743 C_truep(C_i_f32vectorp(x)) ||
2744 C_truep(C_i_f64vectorp(x))));
2745 }
2746
C_i_portp(C_word x)2747 inline static C_word C_i_portp(C_word x)
2748 {
2749 return C_mk_bool(!C_immediatep(x) && C_header_bits(x) == C_PORT_TYPE);
2750 }
2751
2752
C_i_closurep(C_word x)2753 inline static C_word C_i_closurep(C_word x)
2754 {
2755 return C_mk_bool(!C_immediatep(x) && C_header_bits(x) == C_CLOSURE_TYPE);
2756 }
2757
C_i_numberp(C_word x)2758 inline static C_word C_i_numberp(C_word x)
2759 {
2760 return C_mk_bool((x & C_FIXNUM_BIT) ||
2761 (!C_immediatep(x) &&
2762 (C_block_header(x) == C_FLONUM_TAG ||
2763 C_block_header(x) == C_BIGNUM_TAG ||
2764 C_block_header(x) == C_RATNUM_TAG ||
2765 C_block_header(x) == C_CPLXNUM_TAG)));
2766 }
2767
2768 /* All numbers are real, except for cplxnums */
C_i_realp(C_word x)2769 inline static C_word C_i_realp(C_word x)
2770 {
2771 return C_mk_bool((x & C_FIXNUM_BIT) ||
2772 (!C_immediatep(x) &&
2773 (C_block_header(x) == C_FLONUM_TAG ||
2774 C_block_header(x) == C_BIGNUM_TAG ||
2775 C_block_header(x) == C_RATNUM_TAG)));
2776 }
2777
2778 /* All finite real numbers are rational */
C_i_rationalp(C_word x)2779 inline static C_word C_i_rationalp(C_word x)
2780 {
2781 if(x & C_FIXNUM_BIT) {
2782 return C_SCHEME_TRUE;
2783 } else if (C_immediatep(x)) {
2784 return C_SCHEME_FALSE;
2785 } else if(C_block_header(x) == C_FLONUM_TAG) {
2786 double n = C_flonum_magnitude(x);
2787 return C_mk_bool(!C_isinf(n) && !C_isnan(n));
2788 } else {
2789 return C_mk_bool(C_block_header(x) == C_BIGNUM_TAG ||
2790 C_block_header(x) == C_RATNUM_TAG);
2791 }
2792 }
2793
2794
C_u_i_fpintegerp(C_word x)2795 inline static C_word C_u_i_fpintegerp(C_word x)
2796 {
2797 double dummy, val;
2798
2799 val = C_flonum_magnitude(x);
2800
2801 if(C_isnan(val) || C_isinf(val)) return C_SCHEME_FALSE;
2802
2803 return C_mk_bool(C_modf(val, &dummy) == 0.0);
2804 }
2805
2806
C_ub_i_fpintegerp(double x)2807 inline static int C_ub_i_fpintegerp(double x)
2808 {
2809 double dummy;
2810
2811 return C_modf(x, &dummy) == 0.0;
2812 }
2813
C_i_exact_integerp(C_word x)2814 inline static C_word C_i_exact_integerp(C_word x)
2815 {
2816 return C_mk_bool((x) & C_FIXNUM_BIT || C_truep(C_i_bignump(x)));
2817 }
2818
C_u_i_exactp(C_word x)2819 inline static C_word C_u_i_exactp(C_word x)
2820 {
2821 if (C_truep(C_i_exact_integerp(x))) {
2822 return C_SCHEME_TRUE;
2823 } else if (C_block_header(x) == C_FLONUM_TAG) {
2824 return C_SCHEME_FALSE;
2825 } else if (C_block_header(x) == C_RATNUM_TAG) {
2826 return C_SCHEME_TRUE;
2827 } else if (C_block_header(x) == C_CPLXNUM_TAG) {
2828 x = C_u_i_cplxnum_real(x);
2829 /* r and i are always the same exactness, and we assume they
2830 * always store a number.
2831 */
2832 return C_mk_bool(C_immediatep(x) || (C_block_header(x) != C_FLONUM_TAG));
2833 } else {
2834 return C_SCHEME_FALSE;
2835 }
2836 }
2837
C_u_i_inexactp(C_word x)2838 inline static C_word C_u_i_inexactp(C_word x)
2839 {
2840 if (C_immediatep(x)) {
2841 return C_SCHEME_FALSE;
2842 } else if (C_block_header(x) == C_FLONUM_TAG) {
2843 return C_SCHEME_TRUE;
2844 } else if (C_block_header(x) == C_CPLXNUM_TAG) {
2845 x = C_u_i_cplxnum_real(x); /* r and i are always the same exactness */
2846 return C_mk_bool(!C_immediatep(x) && (C_block_header(x) == C_FLONUM_TAG));
2847 } else {
2848 return C_SCHEME_FALSE;
2849 }
2850 }
2851
C_i_integerp(C_word x)2852 inline static C_word C_i_integerp(C_word x)
2853 {
2854 double dummy, val;
2855
2856 if (x & C_FIXNUM_BIT || C_truep(C_i_bignump(x)))
2857 return C_SCHEME_TRUE;
2858 if (C_immediatep(x) || C_block_header(x) != C_FLONUM_TAG)
2859 return C_SCHEME_FALSE;
2860
2861 val = C_flonum_magnitude(x);
2862 if(C_isnan(val) || C_isinf(val)) return C_SCHEME_FALSE;
2863
2864 return C_mk_bool(C_modf(val, &dummy) == 0.0);
2865 }
2866
2867
C_i_flonump(C_word x)2868 inline static C_word C_i_flonump(C_word x)
2869 {
2870 return C_mk_bool(!C_immediatep(x) && C_block_header(x) == C_FLONUM_TAG);
2871 }
2872
C_i_cplxnump(C_word x)2873 inline static C_word C_i_cplxnump(C_word x)
2874 {
2875 return C_mk_bool(!C_immediatep(x) && C_block_header(x) == C_CPLXNUM_TAG);
2876 }
2877
C_i_ratnump(C_word x)2878 inline static C_word C_i_ratnump(C_word x)
2879 {
2880 return C_mk_bool(!C_immediatep(x) && C_block_header(x) == C_RATNUM_TAG);
2881 }
2882
2883 /* TODO: Is this correctly named? Shouldn't it accept an argcount? */
C_a_u_i_fix_to_big(C_word ** ptr,C_word x)2884 inline static C_word C_a_u_i_fix_to_big(C_word **ptr, C_word x)
2885 {
2886 x = C_unfix(x);
2887 if (x < 0)
2888 return C_bignum1(ptr, 1, -x);
2889 else if (x == 0)
2890 return C_bignum0(ptr);
2891 else
2892 return C_bignum1(ptr, 0, x);
2893 }
2894
C_i_fixnum_min(C_word x,C_word y)2895 inline static C_word C_i_fixnum_min(C_word x, C_word y)
2896 {
2897 return ((C_word)x < (C_word)y) ? x : y;
2898 }
2899
2900
C_i_fixnum_max(C_word x,C_word y)2901 inline static C_word C_i_fixnum_max(C_word x, C_word y)
2902 {
2903 return ((C_word)x > (C_word)y) ? x : y;
2904 }
2905
C_i_fixnum_gcd(C_word x,C_word y)2906 inline static C_word C_i_fixnum_gcd(C_word x, C_word y)
2907 {
2908 x = (x & C_INT_SIGN_BIT) ? -C_unfix(x) : C_unfix(x);
2909 y = (y & C_INT_SIGN_BIT) ? -C_unfix(y) : C_unfix(y);
2910
2911 while(y != 0) {
2912 C_word r = x % y;
2913 x = y;
2914 y = r;
2915 }
2916 return C_fix(x);
2917 }
2918
C_fixnum_divide(C_word x,C_word y)2919 inline static C_word C_fixnum_divide(C_word x, C_word y)
2920 {
2921 if(y == C_fix(0)) C_div_by_zero_error(C_text("fx/"));
2922 return C_u_fixnum_divide(x, y);
2923 }
2924
2925
C_u_fixnum_modulo(C_word x,C_word y)2926 inline static C_word C_u_fixnum_modulo(C_word x, C_word y)
2927 {
2928 y = C_unfix(y);
2929 x = C_unfix(x) % y;
2930 if ((y < 0 && x > 0) || (y > 0 && x < 0)) x += y;
2931 return C_fix(x);
2932 }
2933
2934
C_fixnum_modulo(C_word x,C_word y)2935 inline static C_word C_fixnum_modulo(C_word x, C_word y)
2936 {
2937 if(y == C_fix(0)) {
2938 C_div_by_zero_error(C_text("fxmod"));
2939 } else {
2940 return C_u_fixnum_modulo(x,y);
2941 }
2942 }
2943
2944 /* XXX: Naming convention is inconsistent! There's C_fixnum_divide()
2945 * but also C_a_i_flonum_quotient_checked()
2946 */
2947 inline static C_word
C_a_i_fixnum_quotient_checked(C_word ** ptr,int c,C_word x,C_word y)2948 C_a_i_fixnum_quotient_checked(C_word **ptr, int c, C_word x, C_word y)
2949 {
2950 if (y == C_fix(0)) {
2951 C_div_by_zero_error(C_text("fx/"));
2952 } else if (x == C_fix(C_MOST_NEGATIVE_FIXNUM) && y == C_fix(-1)) {
2953 return C_bignum1(ptr, 0, -C_MOST_NEGATIVE_FIXNUM); /* Special case */
2954 } else {
2955 return C_u_fixnum_divide(x, y); /* Inconsistent, too: missing _i_ */
2956 }
2957 }
2958
C_i_fixnum_remainder_checked(C_word x,C_word y)2959 inline static C_word C_i_fixnum_remainder_checked(C_word x, C_word y)
2960 {
2961 if (y == C_fix(0)) {
2962 C_div_by_zero_error(C_text("fxrem"));
2963 } else {
2964 x = C_unfix(x);
2965 y = C_unfix(y);
2966 return C_fix(x - ((x / y) * y));
2967 }
2968 }
2969
C_i_fixnum_arithmetic_shift(C_word n,C_word c)2970 inline static C_word C_i_fixnum_arithmetic_shift(C_word n, C_word c)
2971 {
2972 if(C_unfix(c) < 0) return C_fixnum_shift_right(n, C_u_fixnum_negate(c));
2973 else return C_fixnum_shift_left(n, c);
2974 }
2975
C_a_i_fixnum_negate(C_word ** ptr,C_word n,C_word x)2976 inline static C_word C_a_i_fixnum_negate(C_word **ptr, C_word n, C_word x)
2977 {
2978 /* Exceptional situation: this will cause an overflow to itself */
2979 if (x == C_fix(C_MOST_NEGATIVE_FIXNUM)) /* C_fitsinfixnump(x) */
2980 return C_bignum1(ptr, 0, -C_MOST_NEGATIVE_FIXNUM);
2981 else
2982 return C_fix(-C_unfix(x));
2983 }
2984
C_s_a_u_i_integer_abs(C_word ** ptr,C_word n,C_word x)2985 inline static C_word C_s_a_u_i_integer_abs(C_word **ptr, C_word n, C_word x)
2986 {
2987 if (x & C_FIXNUM_BIT) {
2988 return C_a_i_fixnum_abs(ptr, 1, x);
2989 } else if (C_bignum_negativep(x)) {
2990 return C_s_a_u_i_integer_negate(ptr, n, x);
2991 } else {
2992 return x;
2993 }
2994 }
2995
2996 /* DEPRECATED */
C_i_fixnum_bit_to_bool(C_word n,C_word i)2997 inline static C_word C_i_fixnum_bit_to_bool(C_word n, C_word i)
2998 {
2999 if (i & C_INT_SIGN_BIT) {
3000 C_not_an_uinteger_error(C_text("bit->boolean"), i);
3001 } else {
3002 i = C_unfix(i);
3003 if (i >= C_WORD_SIZE) return C_mk_bool(n & C_INT_SIGN_BIT);
3004 else return C_mk_bool((C_unfix(n) & (C_word)((C_uword)1 << i)) != 0);
3005 }
3006 }
3007
C_a_i_fixnum_difference(C_word ** ptr,C_word n,C_word x,C_word y)3008 inline static C_word C_a_i_fixnum_difference(C_word **ptr, C_word n, C_word x, C_word y)
3009 {
3010 C_word z = C_unfix(x) - C_unfix(y);
3011
3012 if(!C_fitsinfixnump(z)) {
3013 return C_bignum1(ptr, z < 0, C_wabs(z));
3014 } else {
3015 return C_fix(z);
3016 }
3017 }
3018
C_a_i_fixnum_plus(C_word ** ptr,C_word n,C_word x,C_word y)3019 inline static C_word C_a_i_fixnum_plus(C_word **ptr, C_word n, C_word x, C_word y)
3020 {
3021 C_word z = C_unfix(x) + C_unfix(y);
3022
3023 if(!C_fitsinfixnump(z)) {
3024 return C_bignum1(ptr, z < 0, C_wabs(z));
3025 } else {
3026 return C_fix(z);
3027 }
3028 }
3029
C_a_i_fixnum_times(C_word ** ptr,C_word n,C_word x,C_word y)3030 inline static C_word C_a_i_fixnum_times(C_word **ptr, C_word n, C_word x, C_word y)
3031 {
3032 C_uword negp, xhi, xlo, yhi, ylo, p, rhi, rlo;
3033
3034 negp = ((x & C_INT_SIGN_BIT) ? !(y & C_INT_SIGN_BIT) : (y & C_INT_SIGN_BIT));
3035 x = (x & C_INT_SIGN_BIT) ? -C_unfix(x) : C_unfix(x);
3036 y = (y & C_INT_SIGN_BIT) ? -C_unfix(y) : C_unfix(y);
3037
3038 xhi = C_BIGNUM_DIGIT_HI_HALF(x); xlo = C_BIGNUM_DIGIT_LO_HALF(x);
3039 yhi = C_BIGNUM_DIGIT_HI_HALF(y); ylo = C_BIGNUM_DIGIT_LO_HALF(y);
3040
3041 /* This is simply bignum_digits_multiply unrolled for 2x2 halfdigits */
3042 p = xlo * ylo;
3043 rlo = C_BIGNUM_DIGIT_LO_HALF(p);
3044
3045 p = xhi * ylo + C_BIGNUM_DIGIT_HI_HALF(p);
3046 rhi = C_BIGNUM_DIGIT_HI_HALF(p);
3047
3048 p = xlo * yhi + C_BIGNUM_DIGIT_LO_HALF(p);
3049 rlo = C_BIGNUM_DIGIT_COMBINE(C_BIGNUM_DIGIT_LO_HALF(p), rlo);
3050
3051 rhi = xhi * yhi + C_BIGNUM_DIGIT_HI_HALF(p) + rhi;
3052
3053 if (rhi) {
3054 return C_bignum2(ptr, negp != 0, rlo, rhi);
3055 } else if (negp ?
3056 ((rlo & C_INT_SIGN_BIT) || !C_fitsinfixnump(-(C_word)rlo)) :
3057 !C_ufitsinfixnump(rlo)) {
3058 return C_bignum1(ptr, negp != 0, rlo);
3059 } else {
3060 return C_fix(negp ? -rlo : rlo);
3061 }
3062 }
3063
C_i_flonum_min(C_word x,C_word y)3064 inline static C_word C_i_flonum_min(C_word x, C_word y)
3065 {
3066 double
3067 xf = C_flonum_magnitude(x),
3068 yf = C_flonum_magnitude(y);
3069
3070 return xf < yf ? x : y;
3071 }
3072
3073
C_i_flonum_max(C_word x,C_word y)3074 inline static C_word C_i_flonum_max(C_word x, C_word y)
3075 {
3076 double
3077 xf = C_flonum_magnitude(x),
3078 yf = C_flonum_magnitude(y);
3079
3080 return xf > yf ? x : y;
3081 }
3082
C_u_i_integer_signum(C_word x)3083 inline static C_word C_u_i_integer_signum(C_word x)
3084 {
3085 if (x & C_FIXNUM_BIT) return C_i_fixnum_signum(x);
3086 else return (C_bignum_negativep(x) ? C_fix(-1) : C_fix(1));
3087 }
3088
3089 inline static C_word
C_a_i_flonum_quotient_checked(C_word ** ptr,int c,C_word n1,C_word n2)3090 C_a_i_flonum_quotient_checked(C_word **ptr, int c, C_word n1, C_word n2)
3091 {
3092 double n3 = C_flonum_magnitude(n2);
3093
3094 if(n3 == 0.0) C_div_by_zero_error(C_text("fp/?"));
3095 return C_flonum(ptr, C_flonum_magnitude(n1) / n3);
3096 }
3097
3098
3099 inline static double
C_ub_i_flonum_quotient_checked(double n1,double n2)3100 C_ub_i_flonum_quotient_checked(double n1, double n2)
3101 {
3102 if(n2 == 0.0) C_div_by_zero_error(C_text("fp/?"));
3103 return n1 / n2;
3104 }
3105
3106 /* More weirdness: the other flonum_quotient macros and inline functions
3107 * do not compute the quotient but the "plain" division!
3108 */
3109 inline static C_word
C_a_i_flonum_actual_quotient_checked(C_word ** ptr,int c,C_word x,C_word y)3110 C_a_i_flonum_actual_quotient_checked(C_word **ptr, int c, C_word x, C_word y)
3111 {
3112 double dy = C_flonum_magnitude(y), r;
3113
3114 if(dy == 0.0) {
3115 C_div_by_zero_error(C_text("quotient"));
3116 } else if (!C_truep(C_u_i_fpintegerp(x))) {
3117 C_not_an_integer_error(C_text("quotient"), x);
3118 } else if (!C_truep(C_u_i_fpintegerp(y))) {
3119 C_not_an_integer_error(C_text("quotient"), y);
3120 } else {
3121 modf(C_flonum_magnitude(x) / dy, &r);
3122 return C_flonum(ptr, r);
3123 }
3124 }
3125
3126 inline static C_word
C_a_i_flonum_remainder_checked(C_word ** ptr,int c,C_word x,C_word y)3127 C_a_i_flonum_remainder_checked(C_word **ptr, int c, C_word x, C_word y)
3128 {
3129 double dx = C_flonum_magnitude(x),
3130 dy = C_flonum_magnitude(y), r;
3131
3132 if(dy == 0.0) {
3133 C_div_by_zero_error(C_text("remainder"));
3134 } else if (!C_truep(C_u_i_fpintegerp(x))) {
3135 C_not_an_integer_error(C_text("remainder"), x);
3136 } else if (!C_truep(C_u_i_fpintegerp(y))) {
3137 C_not_an_integer_error(C_text("remainder"), y);
3138 } else {
3139 modf(dx / dy, &r);
3140 return C_flonum(ptr, dx - r * dy);
3141 }
3142 }
3143
3144 inline static C_word
C_a_i_flonum_modulo_checked(C_word ** ptr,int c,C_word x,C_word y)3145 C_a_i_flonum_modulo_checked(C_word **ptr, int c, C_word x, C_word y)
3146 {
3147 double dx = C_flonum_magnitude(x),
3148 dy = C_flonum_magnitude(y), r;
3149
3150 if(dy == 0.0) {
3151 C_div_by_zero_error(C_text("modulo"));
3152 } else if (!C_truep(C_u_i_fpintegerp(x))) {
3153 C_not_an_integer_error(C_text("modulo"), x);
3154 } else if (!C_truep(C_u_i_fpintegerp(y))) {
3155 C_not_an_integer_error(C_text("modulo"), y);
3156 } else {
3157 modf(dx / dy, &r);
3158 r = dx - r * dy;
3159 if ((dy < 0 && r > 0) || (dy > 0 && r < 0)) r += y;
3160 return C_flonum(ptr, r);
3161 }
3162 }
3163
C_i_safe_pointerp(C_word x)3164 inline static C_word C_i_safe_pointerp(C_word x)
3165 {
3166 if(C_immediatep(x)) return C_SCHEME_FALSE;
3167
3168 switch(C_block_header(x)) {
3169 case C_POINTER_TAG:
3170 case C_TAGGED_POINTER_TAG:
3171 return C_SCHEME_TRUE;
3172 }
3173
3174 return C_SCHEME_FALSE;
3175 }
3176
3177
C_u_i_assq(C_word x,C_word lst)3178 inline static C_word C_u_i_assq(C_word x, C_word lst)
3179 {
3180 C_word a;
3181
3182 while(!C_immediatep(lst)) {
3183 a = C_u_i_car(lst);
3184
3185 if(C_u_i_car(a) == x) return a;
3186 else lst = C_u_i_cdr(lst);
3187 }
3188
3189 return C_SCHEME_FALSE;
3190 }
3191
3192
3193 inline static C_word
C_fast_retrieve(C_word sym)3194 C_fast_retrieve(C_word sym)
3195 {
3196 C_word val = C_block_item(sym, 0);
3197
3198 if(val == C_SCHEME_UNBOUND)
3199 C_unbound_variable(sym);
3200
3201 return val;
3202 }
3203
3204 inline static void *
C_fast_retrieve_proc(C_word closure)3205 C_fast_retrieve_proc(C_word closure)
3206 {
3207 if(C_immediatep(closure) || C_header_bits(closure) != C_CLOSURE_TYPE)
3208 return (void *)C_invalid_procedure;
3209 else
3210 return (void *)C_block_item(closure, 0);
3211 }
3212
3213
3214 inline static void *
C_fast_retrieve_symbol_proc(C_word sym)3215 C_fast_retrieve_symbol_proc(C_word sym)
3216 {
3217 return C_fast_retrieve_proc(C_fast_retrieve(sym));
3218 }
3219
3220
C_a_i_vector1(C_word ** ptr,int n,C_word x1)3221 inline static C_word C_a_i_vector1(C_word **ptr, int n, C_word x1)
3222 {
3223 C_word *p = *ptr, *p0 = p;
3224
3225 *(p++) = C_VECTOR_TYPE | 1;
3226 *(p++) = x1;
3227 *ptr = p;
3228 return (C_word)p0;
3229 }
3230
3231
C_a_i_vector2(C_word ** ptr,int n,C_word x1,C_word x2)3232 inline static C_word C_a_i_vector2(C_word **ptr, int n, C_word x1, C_word x2)
3233 {
3234 C_word *p = *ptr, *p0 = p;
3235
3236 *(p++) = C_VECTOR_TYPE | 2;
3237 *(p++) = x1;
3238 *(p++) = x2;
3239 *ptr = p;
3240 return (C_word)p0;
3241 }
3242
3243
C_a_i_vector3(C_word ** ptr,int n,C_word x1,C_word x2,C_word x3)3244 inline static C_word C_a_i_vector3(C_word **ptr, int n, C_word x1, C_word x2, C_word x3)
3245 {
3246 C_word *p = *ptr, *p0 = p;
3247
3248 *(p++) = C_VECTOR_TYPE | 3;
3249 *(p++) = x1;
3250 *(p++) = x2;
3251 *(p++) = x3;
3252 *ptr = p;
3253 return (C_word)p0;
3254 }
3255
3256
C_a_i_vector4(C_word ** ptr,int n,C_word x1,C_word x2,C_word x3,C_word x4)3257 inline static C_word C_a_i_vector4(C_word **ptr, int n, C_word x1, C_word x2, C_word x3, C_word x4)
3258 {
3259 C_word *p = *ptr, *p0 = p;
3260
3261 *(p++) = C_VECTOR_TYPE | 4;
3262 *(p++) = x1;
3263 *(p++) = x2;
3264 *(p++) = x3;
3265 *(p++) = x4;
3266 *ptr = p;
3267 return (C_word)p0;
3268 }
3269
3270
C_a_i_vector5(C_word ** ptr,int n,C_word x1,C_word x2,C_word x3,C_word x4,C_word x5)3271 inline static C_word C_a_i_vector5(C_word **ptr, int n, C_word x1, C_word x2, C_word x3, C_word x4,
3272 C_word x5)
3273 {
3274 C_word *p = *ptr, *p0 = p;
3275
3276 *(p++) = C_VECTOR_TYPE | 5;
3277 *(p++) = x1;
3278 *(p++) = x2;
3279 *(p++) = x3;
3280 *(p++) = x4;
3281 *(p++) = x5;
3282 *ptr = p;
3283 return (C_word)p0;
3284 }
3285
3286
C_a_i_vector6(C_word ** ptr,int n,C_word x1,C_word x2,C_word x3,C_word x4,C_word x5,C_word x6)3287 inline static C_word C_a_i_vector6(C_word **ptr, int n, C_word x1, C_word x2, C_word x3, C_word x4,
3288 C_word x5, C_word x6)
3289 {
3290 C_word *p = *ptr, *p0 = p;
3291
3292 *(p++) = C_VECTOR_TYPE | 6;
3293 *(p++) = x1;
3294 *(p++) = x2;
3295 *(p++) = x3;
3296 *(p++) = x4;
3297 *(p++) = x5;
3298 *(p++) = x6;
3299 *ptr = p;
3300 return (C_word)p0;
3301 }
3302
3303
C_a_i_vector7(C_word ** ptr,int n,C_word x1,C_word x2,C_word x3,C_word x4,C_word x5,C_word x6,C_word x7)3304 inline static C_word C_a_i_vector7(C_word **ptr, int n, C_word x1, C_word x2, C_word x3, C_word x4,
3305 C_word x5, C_word x6, C_word x7)
3306 {
3307 C_word *p = *ptr, *p0 = p;
3308
3309 *(p++) = C_VECTOR_TYPE | 7;
3310 *(p++) = x1;
3311 *(p++) = x2;
3312 *(p++) = x3;
3313 *(p++) = x4;
3314 *(p++) = x5;
3315 *(p++) = x6;
3316 *(p++) = x7;
3317 *ptr = p;
3318 return (C_word)p0;
3319 }
3320
3321
C_a_i_vector8(C_word ** ptr,int n,C_word x1,C_word x2,C_word x3,C_word x4,C_word x5,C_word x6,C_word x7,C_word x8)3322 inline static C_word C_a_i_vector8(C_word **ptr, int n, C_word x1, C_word x2, C_word x3, C_word x4,
3323 C_word x5, C_word x6, C_word x7, C_word x8)
3324 {
3325 C_word *p = *ptr, *p0 = p;
3326
3327 *(p++) = C_VECTOR_TYPE | 8;
3328 *(p++) = x1;
3329 *(p++) = x2;
3330 *(p++) = x3;
3331 *(p++) = x4;
3332 *(p++) = x5;
3333 *(p++) = x6;
3334 *(p++) = x7;
3335 *(p++) = x8;
3336 *ptr = p;
3337 return (C_word)p0;
3338 }
3339
3340
C_a_pair(C_word ** ptr,C_word car,C_word cdr)3341 inline static C_word C_fcall C_a_pair(C_word **ptr, C_word car, C_word cdr)
3342 {
3343 C_word *p = *ptr, *p0 = p;
3344
3345 *(p++) = C_PAIR_TYPE | (C_SIZEOF_PAIR - 1);
3346 *(p++) = car;
3347 *(p++) = cdr;
3348 *ptr = p;
3349 return (C_word)p0;
3350 }
3351
C_a_weak_pair(C_word ** ptr,C_word head,C_word tail)3352 inline static C_word C_fcall C_a_weak_pair(C_word **ptr, C_word head, C_word tail)
3353 {
3354 C_word *p = *ptr, *p0 = p;
3355
3356 *(p++) = C_WEAK_PAIR_TAG; /* Changes to strong if sym is persisted */
3357 *(p++) = head;
3358 *(p++) = tail;
3359 *ptr = p;
3360 return (C_word)p0;
3361 }
3362
3363
C_a_i_list1(C_word ** a,int n,C_word x1)3364 inline static C_word C_a_i_list1(C_word **a, int n, C_word x1)
3365 {
3366 return C_a_pair(a, x1, C_SCHEME_END_OF_LIST);
3367 }
3368
3369
C_a_i_list2(C_word ** a,int n,C_word x1,C_word x2)3370 inline static C_word C_a_i_list2(C_word **a, int n, C_word x1, C_word x2)
3371 {
3372 C_word x = C_a_pair(a, x2, C_SCHEME_END_OF_LIST);
3373
3374 return C_a_pair(a, x1, x);
3375 }
3376
3377
C_a_i_list3(C_word ** a,int n,C_word x1,C_word x2,C_word x3)3378 inline static C_word C_a_i_list3(C_word **a, int n, C_word x1, C_word x2, C_word x3)
3379 {
3380 C_word x = C_a_pair(a, x3, C_SCHEME_END_OF_LIST);
3381
3382 x = C_a_pair(a, x2, x);
3383 return C_a_pair(a, x1, x);
3384 }
3385
3386
C_a_i_list4(C_word ** a,int n,C_word x1,C_word x2,C_word x3,C_word x4)3387 inline static C_word C_a_i_list4(C_word **a, int n, C_word x1, C_word x2, C_word x3, C_word x4)
3388 {
3389 C_word x = C_a_pair(a, x4, C_SCHEME_END_OF_LIST);
3390
3391 x = C_a_pair(a, x3, x);
3392 x = C_a_pair(a, x2, x);
3393 return C_a_pair(a, x1, x);
3394 }
3395
3396
C_a_i_list5(C_word ** a,int n,C_word x1,C_word x2,C_word x3,C_word x4,C_word x5)3397 inline static C_word C_a_i_list5(C_word **a, int n, C_word x1, C_word x2, C_word x3, C_word x4,
3398 C_word x5)
3399 {
3400 C_word x = C_a_pair(a, x5, C_SCHEME_END_OF_LIST);
3401
3402 x = C_a_pair(a, x4, x);
3403 x = C_a_pair(a, x3, x);
3404 x = C_a_pair(a, x2, x);
3405 return C_a_pair(a, x1, x);
3406 }
3407
3408
C_a_i_list6(C_word ** a,int n,C_word x1,C_word x2,C_word x3,C_word x4,C_word x5,C_word x6)3409 inline static C_word C_a_i_list6(C_word **a, int n, C_word x1, C_word x2, C_word x3, C_word x4,
3410 C_word x5, C_word x6)
3411 {
3412 C_word x = C_a_pair(a, x6, C_SCHEME_END_OF_LIST);
3413
3414 x = C_a_pair(a, x5, x);
3415 x = C_a_pair(a, x4, x);
3416 x = C_a_pair(a, x3, x);
3417 x = C_a_pair(a, x2, x);
3418 return C_a_pair(a, x1, x);
3419 }
3420
3421
C_a_i_list7(C_word ** a,int n,C_word x1,C_word x2,C_word x3,C_word x4,C_word x5,C_word x6,C_word x7)3422 inline static C_word C_a_i_list7(C_word **a, int n, C_word x1, C_word x2, C_word x3, C_word x4,
3423 C_word x5, C_word x6, C_word x7)
3424 {
3425 C_word x = C_a_pair(a, x7, C_SCHEME_END_OF_LIST);
3426
3427 x = C_a_pair(a, x6, x);
3428 x = C_a_pair(a, x5, x);
3429 x = C_a_pair(a, x4, x);
3430 x = C_a_pair(a, x3, x);
3431 x = C_a_pair(a, x2, x);
3432 return C_a_pair(a, x1, x);
3433 }
3434
3435
C_a_i_list8(C_word ** a,int n,C_word x1,C_word x2,C_word x3,C_word x4,C_word x5,C_word x6,C_word x7,C_word x8)3436 inline static C_word C_a_i_list8(C_word **a, int n, C_word x1, C_word x2, C_word x3, C_word x4,
3437 C_word x5, C_word x6, C_word x7, C_word x8)
3438 {
3439 C_word x = C_a_pair(a, x8, C_SCHEME_END_OF_LIST);
3440
3441 x = C_a_pair(a, x7, x);
3442 x = C_a_pair(a, x6, x);
3443 x = C_a_pair(a, x5, x);
3444 x = C_a_pair(a, x4, x);
3445 x = C_a_pair(a, x3, x);
3446 x = C_a_pair(a, x2, x);
3447 return C_a_pair(a, x1, x);
3448 }
3449
3450
3451 /*
3452 * From Hacker's Delight by Henry S. Warren
3453 * based on a modified nlz() from section 5-3 (fig. 5-7)
3454 */
C_ilen(C_uword x)3455 inline static int C_ilen(C_uword x)
3456 {
3457 C_uword y;
3458 C_word n = 0;
3459
3460 #ifdef C_SIXTY_FOUR
3461 y = x >> 32; if (y != 0) { n += 32; x = y; }
3462 #endif
3463 y = x >> 16; if (y != 0) { n += 16; x = y; }
3464 y = x >> 8; if (y != 0) { n += 8; x = y; }
3465 y = x >> 4; if (y != 0) { n += 4; x = y; }
3466 y = x >> 2; if (y != 0) { n += 2; x = y; }
3467 y = x >> 1; if (y != 0) return n + 2;
3468 return n + x;
3469 }
3470
3471 /* These strl* functions are based on public domain code by C.B. Falconer */
3472 #ifdef HAVE_STRLCPY
3473 # define C_strlcpy strlcpy
3474 #else
C_strlcpy(char * dst,const char * src,size_t sz)3475 inline static size_t C_strlcpy(char *dst, const char *src, size_t sz)
3476 {
3477 const char *start = src;
3478
3479 if (sz--) {
3480 while ((*dst++ = *src))
3481 if (sz--) src++;
3482 else {
3483 *(--dst) = '\0';
3484 break;
3485 }
3486 }
3487 while (*src++) continue;
3488 return src - start - 1;
3489 }
3490 #endif
3491
3492 #ifdef HAVE_STRLCAT
3493 # define C_strlcat strlcat
3494 #else
C_strlcat(char * dst,const char * src,size_t sz)3495 inline static size_t C_strlcat(char *dst, const char *src, size_t sz)
3496 {
3497 char *start = dst;
3498
3499 while (*dst++) /* assumes sz >= strlen(dst) */
3500 if (sz) sz--; /* i.e. well formed string */
3501 dst--;
3502 return dst - start + C_strlcpy(dst, src, sz);
3503 }
3504 #endif
3505
3506 /*
3507 * MinGW's stat() is less than ideal in a couple of ways, so we provide a
3508 * wrapper that:
3509 *
3510 * 1. Strips all trailing slashes and retries on failure, since stat() will
3511 * yield ENOENT when given two (on MSYS) or more (on MinGW and MSYS2).
3512 * 2. Fails with ENOTDIR when given a path to a non-directory file that ends
3513 * in a slash, since in this case MinGW's stat() will succeed but return a
3514 * non-directory mode in buf.st_mode.
3515 */
3516 #if defined(__MINGW32__)
C_stat(const char * path,struct stat * buf)3517 inline static int C_stat(const char *path, struct stat *buf)
3518 {
3519 size_t len = C_strlen(path);
3520 char slash = len && C_strchr("\\/", path[len - 1]), *str;
3521
3522 if(stat(path, buf) == 0)
3523 goto dircheck;
3524
3525 if(slash && errno == ENOENT) {
3526 C_strlcpy((str = (char *)C_alloca(len + 1)), path, len + 1);
3527 while(len > 1 && C_strchr("\\/", path[--len]))
3528 str[len] = '\0';
3529 if(stat(str, buf) == 0)
3530 goto dircheck;
3531 }
3532
3533 return -1;
3534
3535 dircheck:
3536 if(slash && !S_ISDIR(buf->st_mode)) {
3537 errno = ENOTDIR;
3538 return -1;
3539 }
3540
3541 return 0;
3542 }
3543 /*
3544 * Haiku's stat() has a similar issue, where it will gladly succeed
3545 * when given a path to a filename with a trailing slash.
3546 */
3547 #elif defined(__HAIKU__)
C_stat(const char * path,struct stat * buf)3548 inline static int C_stat(const char *path, struct stat *buf)
3549 {
3550 size_t len = C_strlen(path);
3551 char slash = len && path[len - 1] == '/';
3552
3553 if(stat(path, buf) != 0) {
3554 return -1;
3555 }
3556
3557 if (slash && !S_ISDIR(buf->st_mode)) {
3558 errno = ENOTDIR;
3559 return -1;
3560 }
3561
3562 return 0;
3563 }
3564 #else
3565 # define C_stat stat
3566 #endif
3567
3568 /* Safe realpath usage depends on a reliable PATH_MAX. */
3569 #ifdef PATH_MAX
3570 # define C_realpath realpath
3571 #else
C_realpath(const char * path,char * resolved)3572 inline static char *C_realpath(const char *path, char *resolved)
3573 {
3574 # if _POSIX_C_SOURCE >= 200809L
3575 char *p;
3576 size_t n;
3577 if((p = realpath(path, NULL)) == NULL)
3578 return NULL;
3579 n = C_strlcpy(resolved, p, C_MAX_PATH);
3580 C_free(p);
3581 if(n < C_MAX_PATH)
3582 return resolved;
3583 # endif
3584 return NULL;
3585 }
3586 #endif
3587
3588 C_END_C_DECLS
3589
3590 #endif /* ___CHICKEN */
3591