1 /*
2 * Main include-file for CLISP
3 * Bruno Haible 1990-2011, 2016-2018
4 * Marcus Daniels 11.11.1994
5 * Sam Steingold 1998-2012, 2016-2018
6 * Vladimir Tzankov 2008-2012, 2017
7 * German comments translated into English: Stefan Kain 2001-09-24
8
9 Flags that may be set through CFLAGS:
10
11 Flags that enable/disable features:
12
13 Flags that enable features:
14 Unicode characters (prerequisite for internationalization):
15 ENABLE_UNICODE
16 Foreign function interface (based on the GNU libffcall library):
17 DYNAMIC_FFI
18 Dynamic loading of modules:
19 DYNAMIC_MODULES
20 Just-in-time compiler (experimental):
21 USE_JITC
22 Multithreading (experimental):
23 MULTITHREAD
24 Create binary package on Unix (use this if you want to install
25 binaries created on one machine on other machines):
26 UNIX_BINARY_DISTRIB
27
28 Flags that disable features (enabled by default):
29 Advanced line editing in terminal emulators
30 (based on the GNU readline library):
31 NO_READLINE
32 Advanced user interface in terminal emulators
33 (based on the termcap or GNU ncurses library):
34 NO_TERMCAP_NCURSES
35 Internationalization
36 (based on the libintl library from GNU gettext):
37 NO_GETTEXT
38
39 Flags that determine how clisp features are implemented:
40 Multithreading:
41 Flavor of thread implementation:
42 POSIX_THREADS
43 Thread local storage storage when no compiler support is available
44 (32 bit platforms only). The SP is mapped to clisp_thread_t pointer:
45 USE_CUSTOM_TLS={1,2,3} - see comments for the options
46
47 Flags that determine the object representation:
48 Store only minimal type information in a pointer:
49 HEAPCODES
50 Store a good amount of type information in a pointer:
51 TYPECODES
52 More detailed object representation schemes:
53 Object representation schemes on 32-bit platforms:
54 ONE_FREE_BIT_HEAPCODES
55 KERNELVOID32_HEAPCODES
56 Specific variants of KERNELVOID32_HEAPCODES on 32-bit platforms:
57 KERNELVOID32A_HEAPCODES
58 KERNELVOID32B_HEAPCODES
59 Object representation schemes on 64-bit platforms:
60 ONE_FREE_BIT_HEAPCODES
61 GENERIC64_HEAPCODES
62 Specific variants of GENERIC64_HEAPCODES on 64-bit platforms:
63 GENERIC64A_HEAPCODES
64 GENERIC64B_HEAPCODES
65 GENERIC64C_HEAPCODES
66 Use 64-bit pointers on 32-bit platforms
67 (try to avoid it: wastes a lot of memory):
68 WIDE_SOFT, WIDE_SOFT_LARGEFIXNUM
69
70 Flags that determine how the memory management is implemented:
71
72 Flags that determine how to get memory from the OS:
73 Whether to use a fixed heap size and allocate all the heap at the start
74 (try to avoid it):
75 NO_VIRTUAL_MEMORY
76 Don't make assumptions about the address space layout. In particular,
77 ignore the values of CODE_ADDRESS_RANGE, MALLOC_ADDRESS_RANGE,
78 SHLIB_ADDRESS_RANGE, STACK_ADDRESS_RANGE determined by an autoconf test.
79 NO_ADDRESS_SPACE_ASSUMPTIONS
80 Assuming an object representation with TYPECODES, put objects
81 at their address by using mmap with MAP_FIXED; every such memory
82 range is mapped exactly once: SINGLEMAP_MEMORY
83 NO_SINGLEMAP
84 Put objects at their address by using mmap with MAP_FIXED:
85 TRIVIALMAP_MEMORY
86 NO_TRIVIALMAP
87 In case of SPVW_PAGES, to prefer SPVW_PURE over SPVW_MIXED:
88 PREFER_PURE_PAGES
89 Depending on these, there is an automatic determination of
90 - SPVW_BLOCKS vs. SPVW_PAGES,
91 - SPVW_MIXED vs. SPVW_PURE,
92 - MAP_MEMORY_TABLES,
93 - SINGLEMAP_MEMORY_STACK,
94 - TRIVIALMAP_MEMORY_STACK.
95
96 Flags that determine the GC algorithm:
97 Whether to use generational GC (quite advanced fiddling with memory page
98 permissions and page faults): GENERATIONAL_GC
99 NO_GENERATIONAL_GC
100 Whether to use the GC code in its state before MULTITHREAD support
101 was added (that is, in clisp-2.47 state):
102 OLD_GC
103 Whether conses are garbage-collected through an algorithm that preserves
104 locality (but makes debugging of GC crashes very hard): MORRIS_GC
105 NO_MORRIS_GC
106 Whether conses are allocated in their block or page in ascending or
107 descending order:
108 CONS_HEAP_GROWS_DOWN
109 CONS_HEAP_GROWS_UP
110
111 Flags that enable/disable optimizations (no features, just speed):
112
113 Flags that enable optimizations:
114 Exploit GCC global register variables (risky):
115 USE_GCC_REGISTER_VARIABLES
116
117 Flags that disable optimizations:
118 Safety level:
119 SAFETY={0,1,2,3}
120 Low-cost memory allocation on the C stack:
121 NO_ALLOCA
122 Hand-written assembler code for arithmetic, especially multi-precision
123 arithmetic:
124 NO_ARI_ASM
125 Hand-written assembler code for stack pointer access:
126 NO_SP_ASM
127 Use of inline assembler code (__asm__):
128 NO_ASM
129 Memory saving representation of strings with only 8-bit characters
130 or only 16-bit characters:
131 NO_SMALL_SSTRING
132 Memory saving representation of variable binding frames, that stores
133 the binding state bits in the symbol word:
134 NO_SYMBOLFLAGS
135
136 Flags for debugging of clisp internals (for the clisp developers only):
137 Some of these are turned on by the configure option '--with-debug'.
138 DEBUG_GCSAFETY (requires the configure option or env variable CC="g++")
139 DEBUG_OS_ERROR
140 DEBUG_SPVW
141 DEBUG_BYTECODE
142 DEBUG_BACKTRACE (slows down the interpreter a lot)
143 DEBUG_COMPILER
144
145 Flags that you cannot set from CFLAGS (they are automatically determined)
146 and that enable/disable optimizations:
147 Access the machine stack pointer directly:
148 SP_register
149 Use a register instead of a global variable for the Lisp stack pointer:
150 STACK_register
151 Clumsy saving/restoring of STACK when invoking system code:
152 HAVE_SAVED_STACK
153 Represent single-floats as immediate objects:
154 IMMEDIATE_FFLOAT
155
156 */
157
158 /* this machine: WIN32 or GENERIC_UNIX */
159 #if (defined(__unix) || defined(__unix__) || defined(_AIX) || defined(sinix) || defined(__MACH__) || defined(__POSIX__) || defined(__NetBSD__) || defined(__OpenBSD__) || defined(__BEOS__) || defined(__HAIKU__) || defined(__minix)) && !defined(unix)
160 #define unix
161 #endif
162 #if defined(_WIN32) && (defined(_MSC_VER) || defined(__MINGW32__))
163 #undef WIN32 /* because of __MINGW32__ */
164 #define WIN32
165 #endif
166 #if !defined(WIN32)
167 #if defined(unix)
168 #define GENERIC_UNIX
169 #else
170 #error Unknown machine type!
171 #endif
172 #endif
173 /* additional specification of the machine: */
174 #if defined(WIN32)
175 /* declare availability of typical PC facilities,
176 like a console with a graphics mode that differs from the text mode,
177 or a keyboard with function keys F1..F12. */
178 #define PC386 /* IBMPC-compatible with 80386/80486-processor */
179 #endif
180 #ifdef GENERIC_UNIX
181 #if (defined(unix) && (defined(linux) || defined(__CYGWIN__) || defined(__FreeBSD__) || defined(__NetBSD__) || defined(__OpenBSD__) || defined(__DragonFly__)) && (defined(i386) || defined(__i386__) || defined(__x86_64__) || defined(__amd64__)))
182 #define PC386
183 #endif
184 #if (defined(sun) && defined(unix) && defined(sparc))
185 #define SUN4
186 #endif
187 #if defined(hp9000s800) || defined(__hp9000s800)
188 #define HP8XX
189 #endif
190 #endif
191
192 /* Determine the processor:
193 M68K == all processors of the Motorola 68000 series, starting at MC68020
194 SPARC == the Sun SPARC processor
195 HPPA == all processors of the HP Precision Architecture
196 MIPS == all processors of the MIPS series
197 POWERPC == the IBM RS/6000 and PowerPC processor family
198 I80386 == all processors of the Intel 8086 series, starting at 80386,
199 nowadays called IA32
200 ARM == the ARM processor
201 DECALPHA == the DEC Alpha superchip
202 IA64 == the Intel IA-64 latecomer chip
203 AMD64 == the AMD hammer chip
204 S390 == the IBM S/390 processor
205 RISCV64 == the 64-bit RISC-V processor family */
206 /* 32-bit processors: */
207 #if defined(m68k) || defined(__m68k__)
208 #define M68K
209 #endif
210 /* Processors with 32-bit and 64-bit instruction sets: */
211 #if defined(i386) || defined(__i386) || defined(__i386__) || defined(_I386) \
212 || defined(_M_IX86) || defined(_X86_) /* native Windows */
213 #define I80386
214 #endif
215 #if defined(__x86_64__) || defined(__amd64__)
216 #define AMD64
217 #endif
218 #if defined(arm) || defined(__arm) || defined(__arm__)
219 #define ARM
220 #endif
221 #ifdef __aarch64__
222 #define ARM64
223 #endif
224 #if defined(sparc) || defined(__sparc__)
225 #define SPARC
226 #if defined(__sparcv9) || defined(__arch64__)
227 #define SPARC64
228 #endif
229 #endif
230 #if defined(mips) || defined(__mips) || defined(__mips__)
231 #define MIPS
232 #ifdef __mips64
233 #define MIPS64
234 #elif defined(_MIPS_SZLONG)
235 #if (_MIPS_SZLONG == 64)
236 /* We should also check for (_MIPS_SZPTR == 64), but gcc keeps this at 32. */
237 #define MIPS64
238 #endif
239 #endif
240 #endif
241 #if defined(HP8XX) || defined(hppa) || defined(__hppa) || defined(__hppa__)
242 #define HPPA
243 #if defined(__LP64__)
244 #define HPPA64
245 #endif
246 #endif
247 #if defined(_IBMR2) || defined(__powerpc) || defined(__powerpc__) || defined(__ppc) || defined(__ppc__)
248 #define POWERPC
249 #if defined(__powerpc64__) || defined(__ppc64__) || defined(_ARCH_PPC64)
250 #define POWERPC64
251 #endif
252 #endif
253 #if defined(__s390__)
254 #define S390
255 #if defined(__s390x__)
256 #define S390_64
257 #endif
258 #endif
259 #if defined(__riscv) && (__riscv_xlen == 64)
260 #define RISCV64
261 #endif
262 /* 64-bit processors: */
263 #ifdef __alpha
264 #define DECALPHA
265 #endif
266 #ifdef __ia64__
267 #define IA64
268 #endif
269
270 /* Selection of the operating system */
271 #ifdef WIN32
272 /* Windows NT, Windows 95 */
273 #define WIN32_NATIVE /* native NT API, no DOS calls */
274 #endif
275 #ifdef GENERIC_UNIX
276 #define UNIX
277 #ifdef __linux__
278 #define UNIX_LINUX /* Linux (Linus Torvalds Unix) */
279 #endif
280 #ifdef __GNU__
281 #define UNIX_HURD /* the GNU system (Hurd + glibc) */
282 #endif
283 #ifdef __NetBSD__
284 #define UNIX_NETBSD
285 #endif
286 #if defined(__FreeBSD__) || defined(__DragonFly__)
287 /* FreeBSD or its fork called DragonFly BSD. */
288 #define UNIX_FREEBSD
289 #elif defined(__FreeBSD_kernel__)
290 #define UNIX_GNU_FREEBSD /* GNU/kFreeBSD */
291 #endif
292 #ifdef __OpenBSD__
293 #define UNIX_OPENBSD
294 #endif
295 #if defined(hpux) || defined(__hpux)
296 #define UNIX_HPUX /* HP-UX */
297 #endif
298 #if defined(SVR3) || defined(__SVR3) || defined(SVR4) || defined(__SVR4) || defined(SYSTYPE_SVR4) || defined(__SYSTYPE_SVR4) || defined(__svr4__) || defined(USG) || defined(UNIX_HPUX) /* ?? */
299 #define UNIX_SYSV /* UNIX System V */
300 #endif
301 #ifdef _AIX
302 #define UNIX_AIX /* IBM AIX */
303 #endif
304 #ifdef __sgi
305 #define UNIX_IRIX /* SGI IRIX */
306 #endif
307 #ifdef __osf__
308 #define UNIX_OSF /* OSF/1 */
309 #endif
310 #if defined(__APPLE__) && defined(__MACH__)
311 #define UNIX_MACOSX /* MacOS X a.k.a. Darwin */
312 /* MacOSX pathnames are UTF-8 strings, not byte sequences
313 http://thread.gmane.org/gmane.lisp.clisp.general/13725
314 https://sourceforge.net/p/clisp/mailman/message/27345286/
315 http://developer.apple.com/library/mac/#qa/qa2001/qa1173.html */
316 #define CONSTANT_PATHNAME_ENCODING Symbol_value(S(utf_8))
317 #endif
318 #ifdef __CYGWIN__
319 #define UNIX_CYGWIN /* Cygwin (UNIXlike on Windows) */
320 #endif
321 #ifdef __BEOS__
322 #define UNIX_BEOS /* BeOS (UNIXlike) */
323 #endif
324 #ifdef __HAIKU__
325 #define UNIX_HAIKU /* Haiku (a BeOS derivative) */
326 #endif
327 #ifdef __minix
328 #define UNIX_MINIX /* Minix 3 */
329 #endif
330 #endif
331 %% #ifdef WIN32_NATIVE
332 %% puts("#define WIN32_NATIVE");
333 %% #endif
334 %% #ifdef UNIX
335 %% puts("#define UNIX");
336 %% #endif
337
338
339 /* Determine properties of compiler and environment: */
340 #if defined(UNIX) || defined(__MINGW32__)
341 #include "config.h" /* configuration generated by configure */
342 #include "intparam.h" /* integer-type characteristics created by the machine */
343 #include "floatparam.h" /* floating-point type characteristics */
344 #elif defined(WIN32) && !defined(__MINGW32__)
345 #include "version.h" /* defines PACKAGE_* */
346 #define char_bitsize 8
347 #define short_bitsize 16
348 #define int_bitsize 32
349 #if defined(I80386)
350 #define long_bitsize 32
351 #elif defined(DECALPHA)
352 #define long_bitsize 64
353 #endif
354 #if defined(I80386)
355 #define pointer_bitsize 32
356 #elif defined(DECALPHA)
357 #define pointer_bitsize 64
358 #endif
359 #define alignment_long 4
360 #if defined(I80386) || defined(ARM) || defined(DECALPHA)
361 #define short_little_endian
362 #define long_little_endian
363 #endif
364 #define stack_grows_down
365 #define CODE_ADDRESS_RANGE 0
366 #define MALLOC_ADDRESS_RANGE 0
367 #define SHLIB_ADDRESS_RANGE 0
368 #define STACK_ADDRESS_RANGE ~0UL
369 #define ICONV_CONST
370 #else
371 #error where is the configuration for your platform?
372 #endif
373
374 /* These properties of compiler and environment match the CPU.
375 For example, on DECALPHA we have long_bitsize = pointer_bitsize = 64.
376 But there are special ABIs:
377 * On AMD64, you can have long_bitsize = pointer_bitsize = 32.
378 This is the so-called x32 ABI. It is advertised through the _ILP32
379 predefined macro.
380 * On MIPS64, you can have long_bitsize = pointer_bitsize = 32.
381 This is the so-called n32 ABI. It is advertised through the _ABIN32
382 predefined macro.
383 * On ARM64, you can have long_bitsize = pointer_bitsize = 32.
384 This is the so-called ilp32 ABI. It is advertised through the _ILP32
385 predefined macro.
386 * On IA64 with HP-UX, there is an ilp32 ABI as well.
387 */
388
389
390 /* A more precise classification of the operating system: */
391 #if defined(UNIX) && defined(SIGNALBLOCK_BSD) && !defined(SIGNALBLOCK_SYSV)
392 #define UNIX_BSD /* BSD Unix */
393 #endif
394 #if defined(__sun)
395 #define UNIX_SUNOS5 /* Sun OS Version 5.x (Solaris 2) */
396 #endif
397
398 /* On Linux/arm64, MALLOC_ADDRESS_RANGE comes out as a value < 1*2^32, but
399 for larger malloc()s, the address can be around 0x20*2^32 or 0x7F*2^32. */
400 #if defined(UNIX_LINUX) && defined(ARM64)
401 #undef MALLOC_ADDRESS_RANGE
402 #define MALLOC_ADDRESS_RANGE STACK_ADDRESS_RANGE
403 #endif
404
405
406 /* Choose the character set: */
407 #if defined(UNIX) || defined(WIN32)
408 #define ISOLATIN_CHS /* ISO 8859-1, see isolatin.chs */
409 /* Most Unix systems today support the ISO Latin-1 character set, in
410 particular because they have X11 and the X11 fonts are in ISO Latin-1.
411 Exceptions below.
412 On Win32, the standard character set is ISO-8859-1. Only the DOS box
413 displays CP437, but we convert from ISO-8859-1 to CP437 in the
414 low-level output routine full_write(). */
415 #endif
416 #if defined(UNIX_BEOS) || defined(UNIX_HAIKU)
417 /* The default encoding on BeOS is UTF-8, not ISO 8859-1.
418 If compiling with Unicode support, we use it. Else fall back to ASCII. */
419 #undef ISOLATIN_CHS
420 #ifdef ENABLE_UNICODE
421 #define UTF8_CHS /* UTF-8 */
422 #endif
423 #endif
424 #ifdef HP8XX
425 #undef ISOLATIN_CHS
426 #define HPROMAN8_CHS /* HP-Roman8, see hproman8.chs */
427 /* under X-Term however: #define ISOLATIN_CHS ?? */
428 #endif
429 #if !(defined(ISOLATIN_CHS) || defined(HPROMAN8_CHS))
430 #define ASCII_CHS /* Default: plain ASCII charset without special chars */
431 #endif
432
433
434 /* Choose the compiler: */
435 #if defined(__GNUC__)
436 #define GNU
437 /* known bugs */
438 #if (__GNUC__ < 2) || ((__GNUC__ == 2) && (__GNUC_MINOR__ < 95))
439 #error "The minimum supported GCC version is GCC 2.95.3"
440 #endif
441 #if defined(__cplusplus) && (__GNUC__ == 4) && ((__GNUC_MINOR__ == 2) || ((__GNUC_MINOR__ == 3) && (__GNUC_PATCHLEVEL__ < 1))) && !defined(__clang__)
442 #error g++ 4.2.* and 4.3.0 are not supported due to g++ bug 35708
443 #endif
444 #endif
445 #if defined(__STDC__) || defined(__cplusplus)
446 /* ANSI C compilers define __STDC__ (but some define __STDC__=0 !).
447 HP aCC is an example of a C++ compiler which defines __cplusplus but
448 not __STDC__. */
449 #define ANSI
450 #endif
451 #if defined(_MSC_VER)
452 #define MICROSOFT
453 #endif
454 #if defined(__INTEL_COMPILER)
455 #define INTEL
456 #endif
457
458
459 /* Selection of floating-point capabilities:
460 FAST_DOUBLE should be defined if there is a floating-point coprocessor
461 with a 'double'-type IEEE-Floating-Points with 64 Bits.
462 FAST_FLOAT should be defined if there is a floating-point co-processor
463 with a 'float'-type IEEE-Floating-Points with 32 Bits,
464 and a C-Compiler that generates 'float'-operations
465 instead of 'double'-operations */
466 #if (float_mant_bits == 24) && (float_rounds == rounds_to_nearest) && float_rounds_correctly && !defined(FLOAT_OVERFLOW_EXCEPTION) && !defined(FLOAT_UNDERFLOW_EXCEPTION) && !defined(FLOAT_INEXACT_EXCEPTION)
467 #define FAST_FLOAT
468 #endif
469 #if (double_mant_bits == 53) && (double_rounds == rounds_to_nearest) && double_rounds_correctly && !defined(DOUBLE_OVERFLOW_EXCEPTION) && !defined(DOUBLE_UNDERFLOW_EXCEPTION) && !defined(DOUBLE_INEXACT_EXCEPTION)
470 #define FAST_DOUBLE
471 #endif
472 #ifdef ARM
473 /* The processor is little-endian w.r.t. integer types but stores 'double'
474 floats in big-endian word order! */
475 #undef FAST_DOUBLE
476 #endif
477 #ifdef NO_FAST_DOUBLE
478 #undef FAST_DOUBLE
479 #endif
480 #ifdef NO_FAST_FLOAT
481 #undef FAST_FLOAT
482 #endif
483
484 /* Selection of the safety-level:
485 SAFETY=0 : all optimizations are turned on
486 SAFETY=1 : all optimizations on, but keep STACKCHECKs
487 SAFETY=2 : only simple assembler-support
488 SAFETY=3 : no optimizations */
489 #ifndef SAFETY
490 #define SAFETY 0
491 #endif
492 #if SAFETY >= 3
493 #ifndef NO_ASM
494 #define NO_ASM
495 #endif
496 #ifndef NO_ARI_ASM
497 #define NO_ARI_ASM
498 #endif
499 #ifndef NO_FAST_DISPATCH
500 #define NO_FAST_DISPATCH
501 #endif
502 #endif
503
504 /* We don't support pre-ANSI-C compilers any more. */
505 #if !defined(ANSI)
506 #error An ANSI C or C++ compiler is required to compile CLISP!
507 #endif
508
509 /* Choose the appropriate designated field initializer syntax.
510 The standard syntax nowadays is .field = value
511 but it not supported in GNU g++ < 4.7.
512 The older GNU syntax field : value
513 is supported at least throughout GNU gcc and g++ 2.95 to 4.8
514 but is marked obsolete and elicits a warning in clang. */
515 #if defined(GNU) && !defined(__clang__) && defined(__cplusplus) && (__GNUC__ + (__GNUC_MINOR__ >= 7) <= 4)
516 #define designated_init(field,value) field:value
517 #else
518 #define designated_init(field,value) .field=value
519 #endif
520 %% export_def(designated_init(field,value));
521
522 /* A property of the compiler:
523 Whether it supports aligning variables on 8-byte boundaries. */
524 #if defined(GNU) || defined(__SUNPRO_C)
525 #define HAVE_GLOBAL_VAR_ALIGN
526 #endif
527
528 /* A property of the processor:
529 The sequence in which words/long-words are being put into bytes */
530 #if defined(short_little_endian) || defined(int_little_endian) || defined(long_little_endian)
531 /* Z80, VAX, I80386, DECALPHA, MIPSEL, IA64, AMD64, RISCV64, ...:
532 Low Byte is the lowest, High Byte in a higher address */
533 #if defined(BIG_ENDIAN_P)
534 #error Bogus BIG_ENDIAN_P!
535 #endif
536 #define BIG_ENDIAN_P 0
537 #endif
538 #if defined(short_big_endian) || defined(int_big_endian) || defined(long_big_endian)
539 /* M68K, SPARC, HPPA, MIPSEB, POWERPC, S390, ...:
540 High Byte is the lowest, Low Byte is a higher adress (easier to read) */
541 #if defined(BIG_ENDIAN_P)
542 #error Bogus BIG_ENDIAN_P!
543 #endif
544 #define BIG_ENDIAN_P 1
545 #endif
546 #if !defined(BIG_ENDIAN_P)
547 #error Bogus BIG_ENDIAN_P!
548 #endif
549 %% export_def(BIG_ENDIAN_P);
550
551 /* A property of the processor (and C compiler): The alignment of C functions.
552 (See gcc's machine descriptions, macro FUNCTION_BOUNDARY, for information.) */
553 #if defined(__frv__)
554 #define C_CODE_ALIGNMENT 16
555 #define log2_C_CODE_ALIGNMENT 4
556 #endif
557 #if defined(IA64)
558 /* A function pointer on ia64 is a pointer to a two 8-bytes-word structure
559 (first word: a code pointer, second word: a value which will be put in
560 register %r1).
561 The HP-UX linker does not guarantee an alignment of 16, only 8. */
562 #define C_CODE_ALIGNMENT 8
563 #define log2_C_CODE_ALIGNMENT 3
564 #endif
565 #if defined(HPPA64)
566 /* A function pointer on hppa64 is a pointer to a four-word structure
567 (third word: a code pointer, fourth word: a value which will be put in
568 register %r27). */
569 #define C_CODE_ALIGNMENT 8
570 #define log2_C_CODE_ALIGNMENT 3
571 #endif
572 #if defined(S390) || defined(__SPU__) || defined(__tilegx__) || defined(__tilepro__)
573 #define C_CODE_ALIGNMENT 8
574 #define log2_C_CODE_ALIGNMENT 3
575 #endif
576 #if (defined(I80386) && defined(GNU)) || defined(DECALPHA) || defined(SPARC) || defined(MIPS) || defined(POWERPC) || defined(ARM64) || defined(AMD64) || defined(__arc__) || defined(__bfin__) || defined(__TMS320C6X__) || defined(__epiphany__) || defined(__fr30__) || defined(__FT32__) || defined(__iq2000__) || defined(__lm32__) || defined(__M32R__) || defined(__m88k__) || defined(__MICROBLAZE__) || defined(__mmix__) || defined(__nds32__) || defined(__NIOS2__) || defined(__nvptx__) || defined(__VISIUM__) || defined(__xtensa__)
577 /* When using gcc on i386, this assumes that -malign-functions has not been
578 used to specify an alignment smaller than 4 bytes. */
579 #define C_CODE_ALIGNMENT 4
580 #define log2_C_CODE_ALIGNMENT 2
581 #endif
582 #if defined(HPPA) && !defined(HPPA64)
583 /* A function pointer on hppa is either
584 - a code pointer == 0 mod 4, or
585 - a pointer to a two-word structure (first word: a code pointer,
586 second word: a value which will be put in register %r19),
587 incremented by 2, hence == 2 mod 4.
588 The current compilers only emit the second kind of function pointers,
589 hence we can assume that all function pointers are == 2 mod 4. */
590 #define C_CODE_ALIGNMENT 2
591 #define log2_C_CODE_ALIGNMENT 1
592 #define C_FUNCTION_POINTER_BIAS 2
593 #endif
594 #if defined(M68K) || defined(RISCV64) || defined(__CR16__) || defined(__cris__) || defined(__H8300__) || defined(__mcore__) || defined(__mep__) || defined(__moxie__) || defined(__MSP430__) || defined(__pdp11__) || defined(__sh__) || defined(__xstormy16__) || defined(__v850__) || defined(__vax__)
595 #define C_CODE_ALIGNMENT 2
596 #define log2_C_CODE_ALIGNMENT 1
597 #endif
598 #if defined(ARM)
599 /* A function pointer on ARM is either
600 - a code pointer (of code that uses the ARM instruction set), == 0 mod 4,
601 or
602 - a code pointer (of code that uses the Thumb instruction set), == 0 mod 2,
603 plus 1.
604 See https://stackoverflow.com/questions/22205183/least-significant-bits-in-function-pointer
605 For GCC, which mode / instruction set is used can be specified through the
606 options -marm and -mthumb. */
607 #if defined(__thumb__)
608 #define C_CODE_ALIGNMENT 1
609 #define log2_C_CODE_ALIGNMENT 0
610 #else
611 #define C_CODE_ALIGNMENT 4
612 #define log2_C_CODE_ALIGNMENT 2
613 #endif
614 #endif
615 #if defined(__AVR__) || defined(__m32c__) || defined(__mn10300__) || defined(__RL78__)
616 #define C_CODE_ALIGNMENT 1
617 #define log2_C_CODE_ALIGNMENT 0
618 #endif
619 #if !defined(C_CODE_ALIGNMENT) /* e.g. (defined(I80386) && defined(MICROSOFT)) */
620 #define C_CODE_ALIGNMENT 1
621 #define log2_C_CODE_ALIGNMENT 0
622 #endif
623 #if !defined(C_FUNCTION_POINTER_BIAS)
624 #define C_FUNCTION_POINTER_BIAS 0
625 #endif
626
627 /* Flags for the system's include files. */
628
629 /* Width of object representation:
630 WIDE means than an object (pointer) occupies 64 bits (instead of 32 bits).
631 WIDE_HARD means on a 64-bit platform.
632 WIDE_SOFT means on a 32-bit platform, each object pointer occupies 2 words. */
633
634 #if (long_bitsize==64) && (pointer_bitsize==64)
635 #define WIDE_HARD
636 #endif
637
638 /* On 32-bit platforms, the only object representation choice that does not
639 make assumptions about the address space layout is WIDE_SOFT. */
640 #if defined(NO_ADDRESS_SPACE_ASSUMPTIONS) && !defined(WIDE_HARD) && !defined(WIDE_SOFT)
641 #define WIDE_SOFT
642 #endif
643
644 /* WIDE_SOFT_LARGEFIXNUM is a special case of WIDE_SOFT. */
645 #if defined(WIDE_SOFT_LARGEFIXNUM) && !defined(WIDE_SOFT)
646 #define WIDE_SOFT
647 #endif
648
649 #if defined(WIDE) && !(defined(WIDE_HARD) || defined(WIDE_SOFT))
650 #define WIDE_SOFT
651 #endif
652 #if defined(WIDE_HARD) || defined(WIDE_SOFT)
653 #ifndef WIDE
654 #define WIDE
655 #endif
656 #endif
657 /* Now: defined(WIDE) == defined(WIDE_HARD) || defined(WIDE_SOFT) */
658
659 /* this is necessary to avoid messages like
660 Info: resolving _mv_space by linking to __imp__mv_space (auto-import)
661 on woe32. */
662 #if defined(DYNAMIC_MODULES)
663 #if defined(WIN32_NATIVE) || defined(UNIX_CYGWIN)
664 #define DYNAMIC_TABLES 1
665 #define modexp __declspec(dllexport)
666 #define modimp __declspec(dllimport)
667 #define EXECUTABLE_NAME "lisp.exe"
668 #else
669 #define DYNAMIC_TABLES 0
670 #define modexp
671 #define modimp extern
672 #endif
673 #else
674 #define DYNAMIC_TABLES 0
675 #define modexp
676 #define modimp extern
677 #endif
678 %% export_def(DYNAMIC_TABLES);
679 %% export_def(modexp);
680 %% export_def(modimp);
681
682 /* Global register declarations.
683 Speed benefit: Just putting the STACK into a register, brought 5% of speed
684 around 1992. Now, with an AMD Athlon CPU from 2000, with good caches, it
685 still brings 4%.
686 The declarations must occur before any system include files define any
687 inline function, which is the case on UNIX_GNU.
688 Only GCC supports global register variables. Not Apple's variant of GCC.
689 Not clang, which disguises as GCC.
690 And only the C frontend, not the C++ frontend, understands the syntax.
691 And gcc-3.0 to 3.3.3 has severe bugs with global register variables, see
692 CLISP bugs 710737 and 723097 and
693 http://gcc.gnu.org/bugzilla/show_bug.cgi?id=7871
694 http://gcc.gnu.org/bugzilla/show_bug.cgi?id=10684
695 http://gcc.gnu.org/bugzilla/show_bug.cgi?id=14937
696 http://gcc.gnu.org/bugzilla/show_bug.cgi?id=14938
697 Likewise, gcc-4.2 has severe bugs with global register variables, see
698 CLISP bug 1836142 and http://gcc.gnu.org/bugzilla/show_bug.cgi?id=34300
699 Likewise for gcc-4.3-20080215 and probably future versions of GCC as well.
700 Therefore for these versions of gcc enable the global register variables
701 only when USE_GCC_REGISTER_VARIABLES is explicitly defined. */
702 #if defined(GNU) && !(__APPLE_CC__ > 1) && !defined(__clang__) && !defined(__cplusplus) && !(__GNUC__ == 3 && (__GNUC_MINOR__ < 3 || (__GNUC_MINOR__ == 3 && __GNUC_PATCHLEVEL__ < 4))) && !(((__GNUC__ == 4 && __GNUC_MINOR__ >= 2) || __GNUC__ > 4) && !defined(USE_GCC_REGISTER_VARIABLES)) && !defined(MULTITHREAD) && (SAFETY < 2) && !defined(USE_JITC)
703 /* Overview of use of registers in gcc terminology:
704 fixed: mentioned in FIXED_REGISTERS
705 used: mentioned in CALL_USED_REGISTERS but not FIXED_REGISTERS
706 (i.e. caller-saved)
707 save: otherwise (i.e. call-preserved, callee-saved)
708
709 STACK mv_count value1 back_trace
710 M68K used
711 I80386 save
712 SPARC (gcc2) fixed fixed fixed used
713 MIPS
714 HPPA save save save save
715 ARM save
716 DECALPHA save save save
717 IA64
718 AMD64
719 S390 save
720
721 Special notes:
722 - gcc3/Sparc (Linux & Solaris) handles registers differently from gcc2. FIXME
723 - If STACK is in a "used"/"save" register, it needs to be saved into
724 saved_STACK upon begin_call(), so that asynchronous interrupts will
725 be able to restore it.
726 - All of the "used" registers need to be backed up upon begin_call()
727 and restored during end_call().
728 - All of the "save" registers need to be backed up upon begin_callback()
729 and restored during end_callback().
730 - When the interpreter does a longjmp(), the registers STACK, mv_count,
731 value1 may need to be temporarily saved. This is highly machine
732 dependent and is indicated by the NEED_temp_xxxx macros.
733
734 * Register for STACK. */
735 #if defined(M68K)
736 #define STACK_register "a4" /* highest address register after sp=A7,fp=A6/A5 */
737 #endif
738 #if defined(I80386) && !(defined(UNIX_BEOS) || defined(UNIX_HAIKU)) && !defined(DYNAMIC_MODULES)
739 /* On BeOS and Haiku, everything is compiled as PIC, hence %ebx is already booked.
740 If DYNAMIC_MODULES is defined, external modules are compiled as PIC,
741 which is why %ebx is already in use. */
742 #if (__GNUC__ >= 2) /* The register names have changed */
743 #define STACK_register "%ebx" /* one of the call-saved registers without special hardware commands */
744 #else
745 #define STACK_register "bx"
746 #endif
747 #endif
748 #if defined(SPARC)
749 #define STACK_register "%g5" /* a global register */
750 #endif
751 #if defined(HPPA)
752 #define STACK_register "%r10" /* one of the general registers %r5..%r18 */
753 #endif
754 #if defined(ARM)
755 #define STACK_register "%r8" /* one of the general registers %r4..%r8 */
756 #endif
757 #if defined(DECALPHA)
758 #define STACK_register "$9" /* one of the general registers $9..$14 */
759 #endif
760 #if defined(S390) && ((__GNUC__ > 3) || ((__GNUC__ == 3) && (__GNUC_MINOR__ >= 1)))
761 /* global register assignment did not work on s390 until gcc 3.1 */
762 #define STACK_register "9" /* one of the general registers %r8..%r9 */
763 #endif
764 /* What about NEED_temp_STACK ?? Needed if STACK is in a "used" register??
765 Register for mv_count. */
766 #if defined(SPARC)
767 #define mv_count_register "%g6"
768 #if defined(UNIX_NETBSD)
769 #define NEED_temp_mv_count
770 #endif
771 #endif
772 #if defined(HPPA)
773 #define mv_count_register "%r11" /* one of the general registers %r5..%r18 */
774 #define NEED_temp_mv_count
775 #endif
776 #if defined(DECALPHA)
777 #define mv_count_register "$10" /* one of the general registers $9..$14 */
778 #define NEED_temp_mv_count
779 #endif
780 /* Register for value1. */
781 #if !(defined(WIDE) && !defined(WIDE_HARD))
782 #if defined(SPARC)
783 #define value1_register "%g7"
784 #if defined(UNIX_NETBSD)
785 #define NEED_temp_value1
786 #endif
787 #endif
788 #if defined(HPPA)
789 #define value1_register "%r12" /* one of the general registers %r5..%r18 */
790 #define NEED_temp_value1
791 #endif
792 #if defined(DECALPHA)
793 #define value1_register "$11" /* one of the general registers $9..$14 */
794 #define NEED_temp_value1
795 #endif
796 #endif
797 /* Register for back_trace. */
798 #if !(defined(WIDE) && !defined(WIDE_HARD))
799 #if defined(SPARC)
800 #define back_trace_register "%g4" /* a global register */
801 /* %g4 seems to be a scratch-register as of lately with gcc 2.3
802 This causes problems with libc.so.1.6.1 (and higher) (in getwd())
803 That's why HAVE_SAVED_back_trace has been defined above. */
804 #endif
805 #if defined(HPPA)
806 #define back_trace_register "%r13" /* one of the general registers %r5..%r18 */
807 #endif
808 #endif
809 /* Declare the registers now (before any system include file which could
810 contain some inline functions). */
811 #ifdef STACK_register
812 register long STACK_reg __asm__(STACK_register);
813 #endif
814 #ifdef mv_count_register
815 register long mv_count_reg __asm__(mv_count_register);
816 #endif
817 #ifdef value1_register
818 register long value1_reg __asm__(value1_register);
819 #endif
820 #ifdef back_trace_register
821 register long back_trace_reg __asm__(back_trace_register);
822 #endif
823 /* Saving "save" registers. */
824 #if (defined(I80386) || defined(HPPA) || defined(ARM) || defined(DECALPHA) || defined(S390)) && (defined(STACK_register) || defined(mv_count_register) || defined(value1_register) || defined(back_trace_register))
825 #define HAVE_SAVED_REGISTERS
826 struct registers {
827 #ifdef STACK_register
828 long STACK_register_contents;
829 #endif
830 #ifdef mv_count_register
831 long mv_count_register_contents;
832 #endif
833 #ifdef value1_register
834 long value1_register_contents;
835 #endif
836 #ifdef back_trace_register
837 long back_trace_register_contents;
838 #endif
839 };
840 extern struct registers * callback_saved_registers;
841 #ifdef STACK_register
842 #define SAVE_STACK_register(registers) \
843 registers->STACK_register_contents = STACK_reg
844 #define RESTORE_STACK_register(registers) \
845 STACK_reg = registers->STACK_register_contents
846 #else
847 #define SAVE_STACK_register(registers)
848 #define RESTORE_STACK_register(registers)
849 #endif
850 #ifdef mv_count_register
851 #define SAVE_mv_count_register(registers) \
852 registers->mv_count_register_contents = mv_count_reg
853 #define RESTORE_mv_count_register(registers) \
854 mv_count_reg = registers->mv_count_register_contents
855 #else
856 #define SAVE_mv_count_register(registers)
857 #define RESTORE_mv_count_register(registers)
858 #endif
859 #ifdef value1_register
860 #define SAVE_value1_register(registers) \
861 registers->value1_register_contents = value1_reg
862 #define RESTORE_value1_register(registers) \
863 value1_reg = registers->value1_register_contents
864 #else
865 #define SAVE_value1_register(registers)
866 #define RESTORE_value1_register(registers)
867 #endif
868 #ifdef back_trace_register
869 #define SAVE_back_trace_register(registers) \
870 registers->back_trace_register_contents = back_trace_reg
871 #define RESTORE_back_trace_register(registers) \
872 back_trace_reg = registers->back_trace_register_contents
873 #else
874 #define SAVE_back_trace_register(registers)
875 #define RESTORE_back_trace_register(registers)
876 #endif
877 #define SAVE_REGISTERS(inner_statement) \
878 do { \
879 var struct registers * registers = alloca(sizeof(struct registers)); \
880 SAVE_STACK_register(registers); \
881 SAVE_mv_count_register(registers); \
882 SAVE_value1_register(registers); \
883 SAVE_back_trace_register(registers); \
884 inner_statement; \
885 { var gcv_object_t* top_of_frame = STACK; \
886 pushSTACK(fake_gcv_object((aint)callback_saved_registers)); \
887 finish_frame(CALLBACK); \
888 } \
889 callback_saved_registers = registers; \
890 } while(0)
891 #define RESTORE_REGISTERS(inner_statement) \
892 do { \
893 var struct registers * registers = callback_saved_registers; \
894 if (!(framecode(STACK_0) == CALLBACK_frame_info)) abort(); \
895 callback_saved_registers = (struct registers *)(aint)as_oint(STACK_1);\
896 skipSTACK(2); \
897 inner_statement; \
898 RESTORE_STACK_register(registers); \
899 RESTORE_mv_count_register(registers); \
900 RESTORE_value1_register(registers); \
901 RESTORE_back_trace_register(registers); \
902 } while(0)
903 #endif
904 /* Saving the STACK (for asynchronous interrupts).
905 If STACK is a global variable or lies in a register which is left
906 untouched by operating system and library (this is the case on SUN4),
907 we don't need to worry about it. */
908 #if defined(STACK_register) && !defined(SUN4)
909 #define HAVE_SAVED_STACK
910 #endif
911 /* Saving "used" registers. */
912 #if defined(mv_count_register) && 0
913 #define HAVE_SAVED_mv_count
914 #endif
915 #if defined(value1_register) && 0
916 #define HAVE_SAVED_value1
917 #endif
918 #if defined(back_trace_register) && defined(SPARC)
919 #define HAVE_SAVED_back_trace
920 #endif
921 #endif
922 #ifndef HAVE_SAVED_REGISTERS
923 #define SAVE_REGISTERS(inner_statement)
924 #define RESTORE_REGISTERS(inner_statement)
925 #endif
926 %% #ifdef HAVE_SAVED_REGISTERS
927 %% puts("#ifndef IN_MODULE_CC");
928 %% #ifdef STACK_register
929 %% printf("register long STACK_reg __asm__(\"%s\");\n",STACK_register);
930 %% #endif
931 %% #ifdef mv_count_register
932 %% printf("register long mv_count_reg __asm__(\"%s\");\n",mv_count_register);
933 %% #endif
934 %% #ifdef value1_register
935 %% printf("register long value1_reg __asm__(\"%s\");\n",value1_register);
936 %% #endif
937 %% #ifdef back_trace_register
938 %% printf("register long back_trace_reg __asm__(\"%s\");\n",back_trace_register);
939 %% #endif
940 %% print("struct registers { ");
941 %% #ifdef STACK_register
942 %% print("long STACK_register_contents; ");
943 %% #endif
944 %% #ifdef mv_count_register
945 %% print("long mv_count_register_contents; ");
946 %% #endif
947 %% #ifdef value1_register
948 %% print("long value1_register_contents; ");
949 %% #endif
950 %% #ifdef back_trace_register
951 %% print("long back_trace_register_contents; ");
952 %% #endif
953 %% puts("};");
954 %% puts("extern struct registers * callback_saved_registers;");
955 %% puts("#endif");
956 %% #endif
957
958 #define VALUES_IF(cond) \
959 do { value1 = (cond) ? T : NIL; mv_count = 1; } while (0)
960 %% export_def(VALUES_IF(C));
961
962 #define VALUES0 \
963 do { value1 = NIL; mv_count = 0; } while (0)
964 %% export_def(VALUES0);
965
966 #define VALUES1(A) \
967 do { value1 = (A); mv_count = 1; } while (0)
968 %% export_def(VALUES1(A));
969
970 #define VALUES2(A,B) \
971 do { value1 = (A); value2 = (B); mv_count = 2; } while (0)
972 %% export_def(VALUES2(A,B));
973
974 #define VALUES3(A,B,C) \
975 do { value1 = (A); value2 = (B); value3 = (C); mv_count = 3; } while (0)
976 %% export_def(VALUES3(A,B,C));
977
978 /* ###################### Macros for C #################### */
979
980 #if !defined(return_void)
981 /* To return a type of value void: return_void(...); */
982 #ifdef GNU
983 #define return_void return /* 'return void;' is admissible */
984 #else
985 /* In general it is not legal to return `void' values. */
986 #define return_void /* Don't use 'return' for expressions of type 'void'. */
987 #endif
988 #endif
989 #if defined(GNU) && defined(__GNUG__)
990 /* Although legal, g++ warns about 'return void;'. Shut up the warning. */
991 #undef return_void
992 #define return_void
993 #endif
994
995 #if !defined(GNU) && !defined(inline)
996 #define inline /* inline foo() {...} --> foo() {...} */
997 #endif
998 %% puts("#if !defined(__GNUC__) && !defined(inline)");
999 %% puts("#define inline");
1000 %% puts("#endif");
1001
1002 /* Definitions for C++-Compilers: */
1003 #ifdef __cplusplus
1004 #define BEGIN_DECLS extern "C" {
1005 #define END_DECLS }
1006 #else
1007 #define BEGIN_DECLS
1008 #define END_DECLS
1009 #endif
1010 %% export_def(BEGIN_DECLS);
1011 %% export_def(END_DECLS);
1012
1013 /* Empty macro-arguments:
1014 Some compilers (ie. cc under HP-UX) seem to interpret a macro call
1015 foo(arg1,...,argn,) as equivalent to foo(arg1,...,argn), which will
1016 yield an error. _EMA_ stands for "empty macro argument".
1017 It will be inserted by CC_NEED_DEEMA,
1018 each time between comma and closing parentheses.
1019 It is also needed when potentially empty arguments
1020 are returned to other macros */
1021
1022 #define _EMA_
1023
1024 /* Concatenation of two macro-expanded tokens:
1025 Example:
1026 #undef x
1027 #define y 16
1028 CONCAT(x,y) ==> 'x16' (not 'xy' !) */
1029 #define CONCAT_(xxx,yyy) xxx##yyy
1030 #define CONCAT3_(aaa,bbb,ccc) aaa##bbb##ccc
1031 #define CONCAT4_(aaa,bbb,ccc,ddd) aaa##bbb##ccc##ddd
1032 #define CONCAT5_(aaa,bbb,ccc,ddd,eee) aaa##bbb##ccc##ddd##eee
1033 #define CONCAT6_(aaa,bbb,ccc,ddd,eee,fff) aaa##bbb##ccc##ddd##eee##fff
1034 #define CONCAT7_(aaa,bbb,ccc,ddd,eee,fff,ggg) aaa##bbb##ccc##ddd##eee##fff##ggg
1035 #define CONCAT(xxx,yyy) CONCAT_(xxx,yyy)
1036 #define CONCAT3(aaa,bbb,ccc) CONCAT3_(aaa,bbb,ccc)
1037 #define CONCAT4(aaa,bbb,ccc,ddd) CONCAT4_(aaa,bbb,ccc,ddd)
1038 #define CONCAT5(aaa,bbb,ccc,ddd,eee) CONCAT5_(aaa,bbb,ccc,ddd,eee)
1039 #define CONCAT6(aaa,bbb,ccc,ddd,eee,fff) CONCAT6_(aaa,bbb,ccc,ddd,eee,fff)
1040 #define CONCAT7(aaa,bbb,ccc,ddd,eee,fff,ggg) CONCAT7_(aaa,bbb,ccc,ddd,eee,fff,ggg)
1041 %% puts("#define CONCAT_(xxx,yyy) xxx##yyy");
1042 %% puts("#define CONCAT3_(aaa,bbb,ccc) aaa##bbb##ccc");
1043 %% #if notused
1044 %% puts("#define CONCAT4_(aaa,bbb,ccc,ddd) aaa##bbb##ccc##ddd");
1045 %% puts("#define CONCAT5_(aaa,bbb,ccc,ddd,eee) aaa##bbb##ccc##ddd##eee");
1046 %% #endif
1047 %% puts("#define CONCAT(xxx,yyy) CONCAT_(xxx,yyy)");
1048 %% puts("#define CONCAT3(aaa,bbb,ccc) CONCAT3_(aaa,bbb,ccc)");
1049 %% #if notused
1050 %% puts("#define CONCAT4(aaa,bbb,ccc,ddd) CONCAT4_(aaa,bbb,ccc,ddd)");
1051 %% puts("#define CONCAT5(aaa,bbb,ccc,ddd,eee) CONCAT5_(aaa,bbb,ccc,ddd,eee)");
1052 %% #endif
1053
1054 /* Generation of goto-tag macros:
1055 GENTAG(end) ==> end116
1056 This allows a macro defining marks to be used more than once per function
1057 but still only once per source-line. */
1058 #define GENTAG(xxx) CONCAT(xxx,__LINE__)
1059
1060 /* Converting tokens to strings:
1061 STRING(token) ==> "token" */
1062 #define STRING(token) #token
1063 #define STRINGIFY(token) STRING(token)
1064 %% puts("#define STRING(token) #token");
1065 %% puts("#define STRINGIFY(token) STRING(token)");
1066
1067 /* Storage-Class-Specifier in top-level-declarations:
1068 for variables:
1069 global globally visible variable
1070 local variable that is only visible in the file (local)
1071 extern pointer to a variable that's defined externally
1072 for functions:
1073 global globally visible function
1074 local function that is only visible in the file (local)
1075 extern pointer to a function that's defined externally
1076 extern_C pointer to a c-function that's defined externally
1077 _Noreturn function that will never return (draft C1X)
1078 maygc function that can trigger GC */
1079 #define global
1080 /* #define local static */ /* done below */
1081 /* #define extern extern */
1082 #ifdef __cplusplus
1083 #define extern_C extern "C"
1084 #else
1085 #define extern_C extern
1086 #endif
1087
1088 /* A function that can trigger GC is declared either as
1089 - maygc, if (1) all callers must assume the worst case: that it triggers GC,
1090 and (2) the function uses only the 'object's passed as arguments and
1091 on the STACK, but no objects stored in other non-GCsafe locations.
1092 - / * maygc * / otherwise. If (1) is not fulfilled, the functions begins
1093 with an appropriate GCTRIGGER_IF statement. If (2) is not
1094 fulfilled, the GCTRIGGER call needs to mention all other
1095 non-GCsafe locations whose values are used by the function,
1096 such as 'value1' or 'mv_space'. */
1097 #define maygc
1098
1099 /* Storage-Class-Specifier in declarations at the beginning of a block:
1100 var will lead a variable declaration
1101 used by utils/varbrace to allow declarations mixed with other statements */
1102 #define var
1103
1104 /* Ignore C++ keyword. */
1105 #define export export_sym
1106
1107 /* Swap the contents of two variables: swap(register int, x1, x2); */
1108 #define swap(swap_type,swap_var1,swap_var2) \
1109 do { var swap_type swap_temp; \
1110 swap_temp = swap_var1; swap_var1 = swap_var2; swap_var2 = swap_temp; \
1111 } while(0)
1112
1113 /* Marking a program line that may not be reached: NOTREACHED; */
1114 #define NOTREACHED error_notreached(__FILE__,__LINE__)
1115 %% puts("#define NOTREACHED error_notreached(__FILE__,__LINE__)");
1116
1117 /* Asserting an arithmetic expression: ASSERT(expr); */
1118 #define ASSERT(expr) do { if (!(expr)) NOTREACHED; } while(0)
1119 %% puts("#define ASSERT(expr) do { if (!(expr)) NOTREACHED; } while(0)");
1120
1121 #include <alloca.h>
1122 %% include_file("alloca.h");
1123 #include <stdlib.h>
1124 %% puts("#include <stdlib.h>");
1125 #include <sys/types.h>
1126 %% puts("#include <sys/types.h>");
1127 #include <unistd.h>
1128 #include <sys/socket.h> /* declares select, used in stream.d */
1129 #include <sys/select.h>
1130 #include <locale.h>
1131 #include <errno.h>
1132 #include <string.h> /* declares strlen() et al */
1133 #include <noreturn.h> /* defines _GL_NORETURN_FUNC, _GL_NORETURN_FUNCPTR */
1134
1135 /* Storage-Class-Specifier for identifiers only visible in the file. */
1136 /* Can't define this earlier, because <sys/types.h> on Haiku uses the
1137 identifier 'local'. */
1138 #define local static
1139
1140 #define MALLOC(size,type) (type*)malloc((size)*sizeof(type))
1141
1142 /* Literal constants of 64-bit integer types
1143 LL(nnnn) = nnnn parsed as a sint64
1144 ULL(nnnn) = nnnn parsed as a uint64 */
1145 #if defined(HAVE_LONG_LONG_INT)
1146 #define LL(nnnn) nnnn##LL
1147 #define ULL(nnnn) nnnn##ULL
1148 #elif defined(MICROSOFT)
1149 #define LL(nnnn) nnnn##i64
1150 #define ULL(nnnn) nnnn##ui64
1151 #endif
1152 %% #if defined(HAVE_LONG_LONG_INT)
1153 %% puts("#define LL(nnnn) nnnn##LL");
1154 %% puts("#define ULL(nnnn) nnnn##ULL");
1155 %% #elif defined(MICROSOFT)
1156 %% puts("#define LL(nnnn) nnnn##i64");
1157 %% puts("#define ULL(nnnn) nnnn##ui64");
1158 %% #endif
1159
1160 /* Synonyms for Byte, Word, Longword:
1161 SBYTE = signed 8 bit integer
1162 UBYTE = unsigned 8 bit int
1163 SWORD = signed 16 bit int
1164 UWORD = unsigned 16 bit int
1165 SLONG = signed 32 bit int
1166 ULONG = unsigned 32 bit int
1167 On the other hand, "char" is only used as an element of a string
1168 You never really compute with a "char"; it might depend on
1169 __CHAR_UNSIGNED___! */
1170 #if (char_bitsize==8)
1171 #ifdef __CHAR_UNSIGNED__
1172 typedef signed char SBYTE;
1173 #else
1174 typedef char SBYTE;
1175 #endif
1176 typedef unsigned char UBYTE;
1177 #else
1178 #error No 8 bit integer type? -- Which Integer-type has 8 Bit?
1179 #endif
1180 #if (short_bitsize==16)
1181 typedef short SWORD;
1182 typedef unsigned short UWORD;
1183 #else
1184 #error No 16 bit integer type? -- Which Integer-type has 16 Bit?
1185 #endif
1186 #if (long_bitsize==32)
1187 typedef long SLONG;
1188 typedef unsigned long ULONG;
1189 #elif (int_bitsize==32)
1190 typedef int SLONG;
1191 typedef unsigned int ULONG;
1192 #else
1193 #error No 32 bit integer type? -- Which Integer-type has 32 Bit?
1194 #endif
1195 #if (long_bitsize==64) && !defined(UNIX_CYGWIN)
1196 typedef long SLONGLONG;
1197 typedef unsigned long ULONGLONG;
1198 #ifndef HAVE_LONG_LONG_INT
1199 #define HAVE_LONG_LONG_INT
1200 #endif
1201 #elif defined(MICROSOFT)
1202 typedef __int64 SLONGLONG;
1203 typedef unsigned __int64 ULONGLONG;
1204 #define HAVE_LONG_LONG_INT
1205 #elif defined(HAVE_LONG_LONG_INT)
1206 #if defined(long_long_bitsize) && (long_long_bitsize==64)
1207 typedef long long SLONGLONG;
1208 typedef unsigned long long ULONGLONG;
1209 #else /* useless type */
1210 #undef HAVE_LONG_LONG_INT
1211 #endif
1212 #endif
1213 #if defined(WIDE) && !defined(HAVE_LONG_LONG_INT)
1214 #error No 64 bit integer type? -- Which Integer-type has 64 Bit?
1215 #endif
1216 %% #ifdef __CHAR_UNSIGNED__
1217 %% emit_typedef("signed char","SBYTE");
1218 %% #else
1219 %% emit_typedef("char","SBYTE");
1220 %% #endif
1221 %% emit_typedef("unsigned char","UBYTE");
1222 %% emit_typedef("short","SWORD");
1223 %% emit_typedef("unsigned short","UWORD");
1224 %% #if (long_bitsize==32)
1225 %% emit_typedef("long","SLONG");
1226 %% emit_typedef("unsigned long","ULONG");
1227 %% #elif (int_bitsize==32)
1228 %% emit_typedef("int","SLONG");
1229 %% emit_typedef("unsigned int","ULONG");
1230 %% #endif
1231 %% #if (long_bitsize==64) && !defined(UNIX_CYGWIN)
1232 %% emit_typedef("long","SLONGLONG");
1233 %% emit_typedef("unsigned long","ULONGLONG");
1234 %% #elif defined(MICROSOFT)
1235 %% emit_typedef("__int64","SLONGLONG");
1236 %% emit_typedef("unsigned __int64","ULONGLONG");
1237 %% #elif defined(HAVE_LONG_LONG_INT)
1238 %% emit_typedef("long long","SLONGLONG");
1239 %% emit_typedef("unsigned long long","ULONGLONG");
1240 %% #endif
1241
1242 #include <stdbool.h> /* boolean values */
1243 %% include_file("stdbool.h");
1244
1245 /* Type for signed values, results of comparisons, tertiary enums
1246 with values +1, 0, -1 */
1247 typedef signed int signean;
1248 #define signean_plus 1 /* +1 */
1249 #define signean_null 0 /* 0 */
1250 #define signean_minus -1 /* -1 */
1251
1252 /* Null pointers */
1253 #ifdef __cplusplus
1254 #undef NULL
1255 #define NULL 0
1256 #elif !(defined(INTEL) || defined(_AIX))
1257 #undef NULL
1258 #define NULL ((void*) 0L)
1259 #endif
1260 %% puts("#undef NULL");
1261 %% export_def(NULL);
1262
1263 /* libc I/O */
1264 #include <stdio.h>
1265 /* Use fprintf and printf only for format strings that take at least 1 argument.
1266 For literal strings, use print and fprint.
1267 Avoid using fputs, puts, fputc, putc, putchar directly, because these APIs
1268 are hard to memorize (fputs, fputc, putc don't take the stream first; puts
1269 outputs an extra newline) or redundant (fputc, putc, putchar are special
1270 cases of fputs that GCC recognizes anyway). */
1271 #define fprint(fp,string) fputs(string,fp)
1272 #define print(string) fputs(string,stdout)
1273
1274 /* A more precise classification of the operating system:
1275 (This test works only after at least one system header has been included.) */
1276 #if (__GLIBC__ >= 2)
1277 #define UNIX_GNU /* glibc2 (may be UNIX_LINUX, UNIX_HURD or UNIX_GNU_FREEBSD) */
1278 #endif
1279
1280 /* Determine the offset of a component 'ident' in a struct of the type 'type':
1281 See 0 as pointer to 'type', put a struct 'type' there and determine the
1282 address of its component 'ident' and return it as number: */
1283 #include <stddef.h>
1284 #ifndef offsetof
1285 #define offsetof(type,ident) ((ULONG)&(((type*)0)->ident))
1286 #endif
1287 /* Determine the offset of an array 'ident' in a struct of the type 'type': */
1288 #if defined(__cplusplus) || defined(MICROSOFT)
1289 #define offsetofa(type,ident) offsetof(type,ident)
1290 #else
1291 #define offsetofa(type,ident) offsetof(type,ident[0])
1292 #endif
1293
1294 /* alignof(type) is a constant expression, returning the alignment of type. */
1295 #ifdef __cplusplus
1296 #ifdef GNU
1297 #define alignof(type) __alignof__(type)
1298 #else
1299 template <class type> struct alignof_helper { char slot1; type slot2; };
1300 #define alignof(type) offsetof(alignof_helper<type>, slot2)
1301 #endif
1302 #else
1303 #define alignof(type) offsetof(struct { char slot1; type slot2; }, slot2)
1304 #endif
1305
1306 /* Unspecified length of arrays in structures:
1307 struct { ...; ...; type x[unspecified]; }
1308 Instead of sizeof(..) you'll always have to use offsetof(..,x). */
1309 #if defined(GNU) || defined(MICROSOFT) /* GNU & MS C are able to work with arrays of length 0 */
1310 #define unspecified 0
1311 #elif 0
1312 /* Usually one would omit the array's limit */
1313 #define unspecified
1314 #else
1315 /* However, HP-UX- and IRIX-compilers will only work with this: */
1316 #define unspecified 1
1317 #endif
1318 %% export_def(unspecified);
1319
1320 /* Pointer arithmetics: add a given offset (measured in bytes)
1321 to a pointer. */
1322 #if defined(GNU) || (pointer_bitsize > 32)
1323 /* Essential for GNU-C for initialization of static-variables
1324 (must be a bug in 'c-typeck.c' in 'initializer_constant_valid_p'):
1325 The only correct way, if sizeof(ULONG) < sizeof(void*): */
1326 #define pointerplus(pointer,offset) ((UBYTE*)(pointer)+(offset))
1327 #else
1328 /* Cheap way: */
1329 #define pointerplus(pointer,offset) ((void*)((ULONG)(pointer)+(offset)))
1330 #endif
1331 %% export_def(pointerplus(pointer,offset));
1332
1333 /* Bit number n (0<=n<32)
1334 This is an unsigned expression, in order to avoid signed integer overflow
1335 in expressions like bit(31) or bit(31)-1. */
1336 #define bit(n) (1UL<<(n))
1337 /* Bit number n (0<n<=32) mod 2^32 */
1338 #define bitm(n) (2UL<<((n)-1))
1339 /* Bit-test of bit n in x, n constant, x an oint: */
1340 #if !defined(SPARC)
1341 #define bit_test(x,n) ((x) & bit(n))
1342 #else
1343 /* On SPARC-processors, long constants are slower than shifts. */
1344 #if defined(SPARC64)
1345 #if !defined(GNU)
1346 #define bit_test(x,n) \
1347 ((n)<12 ? ((x) & bit(n)) : ((sint64)((uint64)(x) << (63-(n))) < 0))
1348 #else /* the GNU-compiler will optimize boolean expressions better this way: */
1349 #define bit_test(x,n) \
1350 ( ( ((n)<12) && ((x) & bit(n)) ) \
1351 || ( ((n)>=12) && ((sint64)((uint64)(x) << (63-(n))) < 0) ) \
1352 )
1353 #endif
1354 #else
1355 #if !defined(GNU)
1356 #define bit_test(x,n) \
1357 ((n)<12 ? ((x) & bit(n)) : ((sint32)((uint32)(x) << (31-(n))) < 0))
1358 #else /* the GNU-compiler will optimize boolean expressions better this way: */
1359 #define bit_test(x,n) \
1360 ( ( ((n)<12) && ((x) & bit(n)) ) \
1361 || ( ((n)>=12) && ((sint32)((uint32)(x) << (31-(n))) < 0) ) \
1362 )
1363 #endif
1364 #endif
1365 #endif
1366 /* Minus bit number n (0<=n<32) */
1367 #define minus_bit(n) (-1L<<(n))
1368 /* Minus bit number n (0<n<=32) mod 2^32 */
1369 #define minus_bitm(n) (-2L<<((n)-1))
1370 %% export_def(bit(n));
1371 %% #if notused
1372 %% export_def(bitm(n));
1373 %% #endif
1374 %% export_def(bit_test(x,n));
1375 %% export_def(minus_bit(n));
1376 %% #if notused
1377 %% export_def(minus_bitm(n));
1378 %% #endif
1379
1380 /* floor(a,b) yields for a>=0, b>0 floor(a/b).
1381 b should be a 'constant expression'. */
1382 #define floor(a_from_floor,b_from_floor) ((a_from_floor) / (b_from_floor))
1383 %% /* FIXME: Difference between lispbibl.d and clisp.h */
1384 %% puts("#define ifloor(a_from_floor,b_from_floor) ((a_from_floor) / (b_from_floor))");
1385
1386 /* ceiling(a,b) yields for a>=0, b>0 ceiling(a/b) = floor((a+b-1)/b).
1387 b should be a 'constant expression'. */
1388 #define ceiling(a_from_ceiling,b_from_ceiling) \
1389 (((a_from_ceiling) + (b_from_ceiling) - 1) / (b_from_ceiling))
1390 %% export_def(ceiling(a_from_ceiling,b_from_ceiling));
1391
1392 /* round_down(a,b) rounds a>=0 so that b>0 divides it.
1393 b should be a 'constant expression'. */
1394 #define round_down(a_from_round,b_from_round) \
1395 (floor(a_from_round,b_from_round)*(b_from_round))
1396 %% /* FIXME: Difference between lispbibl.d and clisp.h */
1397 %% puts("#define round_down(a_from_round,b_from_round) (ifloor(a_from_round,b_from_round)*(b_from_round))");
1398
1399 /* round_up(a,b) rounds a>=0 so that b>0 divides it.
1400 b should be a 'constant expression'. */
1401 #define round_up(a_from_round,b_from_round) \
1402 (ceiling(a_from_round,b_from_round)*(b_from_round))
1403 %% export_def(round_up(a_from_round,b_from_round));
1404
1405 /* non-local exits */
1406 #include <setjmp.h>
1407 %% #ifdef export_unwind_protect_macros
1408 %% puts("#include <setjmp.h>");
1409 %% #endif
1410 #if defined(UNIX) && defined(HAVE__JMP)
1411 /* The "_" routines are more efficient - do not save/restore signal masks,
1412 see http://article.gmane.org/gmane.lisp.clisp.devel/18227
1413 https://sourceforge.net/p/clisp/mailman/message/19448465/ */
1414 #undef setjmp
1415 #undef longjmp
1416 #define setjmp _setjmp
1417 #define longjmp _longjmp
1418 #ifdef LONGJMP_RETURNS
1419 /* _longjmp(jmpbuf,value) can return if jmpbuf is invalid. */
1420 #undef longjmp
1421 #define longjmp(x,y) (_longjmp(x,y), NOTREACHED)
1422 #endif
1423 #endif
1424 /* A longjmp() can only be called using an `int'.
1425 But if we want to use a `long' and if sizeof(int) < sizeof(long),
1426 we'll need a global variable: */
1427 #if (int_bitsize == long_bitsize)
1428 #define setjmpl(x) setjmp(x)
1429 #define longjmpl(x,y) longjmp(x,y)
1430 #else /* (int_bitsize < long_bitsize) */
1431 #ifndef MULTITHREAD
1432 /* MT: following is per thread in MT builds */
1433 extern long jmpl_value;
1434 #endif
1435 #define setjmpl(x) (setjmp(x) ? jmpl_value : 0)
1436 #define longjmpl(x,y) (jmpl_value = (y), longjmp(x,1))
1437 #endif
1438 %% #ifdef export_unwind_protect_macros
1439 %% #if (int_bitsize < long_bitsize) && !defined(MULTITHREAD)
1440 %% exportV(long,jmpl_value);
1441 %% #endif
1442 %% export_def(setjmpl(x))
1443 %% export_def(longjmpl(x))
1444 %% #endif
1445
1446 /* An alloca() replacement, used for DYNAMIC_ARRAY and SAVE_NUM_STACK.
1447 See spvw_alloca.d. */
1448 #if !(defined(GNU) || (defined(UNIX) && !defined(NO_ALLOCA) && !defined(SPARC)) || defined(MICROSOFT))
1449 #define NEED_MALLOCA
1450 extern void* malloca (size_t size);
1451 extern void freea (void* ptr);
1452 #endif
1453
1454 /* Dynamically allocated array with dynamic extent:
1455 Example:
1456 var DYNAMIC_ARRAY(my_array,uintL,n);
1457 ...
1458 FREE_DYNAMIC_ARRAY(my_array);
1459 Attention: depending on your implementation my_array is either the array
1460 itself or a pointer to the array! Always use my_array only as expression! */
1461 #if defined(GNU)
1462 /* can deal with dynamically allocated arrays in the machine stack
1463 { var uintL my_array[n]; ... } */
1464 #define DYNAMIC_ARRAY(arrayvar,arrayeltype,arraysize) \
1465 arrayeltype arrayvar[arraysize]
1466 #define FREE_DYNAMIC_ARRAY(arrayvar)
1467 #elif (defined(UNIX) && (defined(_AIX) || !defined(NO_ALLOCA))) || defined(MICROSOFT)
1468 /* Allocate space in machine stack.
1469 { var uintL* my_array = (uintL*)alloca(n*sizeof(uintL)); ... } */
1470 #define DYNAMIC_ARRAY(arrayvar,arrayeltype,arraysize) \
1471 arrayeltype* arrayvar = (arrayeltype*)alloca((arraysize)*sizeof(arrayeltype))
1472 #define FREE_DYNAMIC_ARRAY(arrayvar)
1473 /* no error check?? */
1474 #else
1475 /* Allocate space somewhere else and then free it.
1476 { var uintL* my_array = (uintL*)malloc(n*sizeof(uintL)); ... free(my_array); } */
1477 #define DYNAMIC_ARRAY(arrayvar,arrayeltype,arraysize) \
1478 arrayeltype* arrayvar = (arrayeltype*)malloca((arraysize)*sizeof(arrayeltype))
1479 #define FREE_DYNAMIC_ARRAY(arrayvar) freea(arrayvar)
1480 #endif
1481 %% export_def(DYNAMIC_ARRAY(arrayvar,arrayeltype,arraysize));
1482 %% export_def(FREE_DYNAMIC_ARRAY(arrayvar));
1483
1484 /* Signed/Unsigned-Integer-types with given minumum size: */
1485 typedef UBYTE uint1; /* unsigned 1 bit Integer */
1486 typedef SBYTE sint1; /* signed 1 bit Integer */
1487 typedef UBYTE uint2; /* unsigned 2 bit Integer */
1488 typedef SBYTE sint2; /* signed 2 bit Integer */
1489 typedef UBYTE uint3; /* unsigned 3 bit Integer */
1490 typedef SBYTE sint3; /* signed 3 bit Integer */
1491 typedef UBYTE uint4; /* unsigned 4 bit Integer */
1492 typedef SBYTE sint4; /* signed 4 bit Integer */
1493 typedef UBYTE uint5; /* unsigned 5 bit Integer */
1494 typedef SBYTE sint5; /* signed 5 bit Integer */
1495 typedef UBYTE uint6; /* unsigned 6 bit Integer */
1496 typedef SBYTE sint6; /* signed 6 bit Integer */
1497 typedef UBYTE uint7; /* unsigned 7 bit Integer */
1498 typedef SBYTE sint7; /* signed 7 bit Integer */
1499 typedef UBYTE uint8; /* unsigned 8 bit Integer */
1500 typedef SBYTE sint8; /* signed 8 bit Integer */
1501 typedef UWORD uint9; /* unsigned 9 bit Integer */
1502 typedef SWORD sint9; /* signed 9 bit Integer */
1503 typedef UWORD uint10; /* unsigned 10 bit Integer */
1504 typedef SWORD sint10; /* signed 10 bit Integer */
1505 typedef UWORD uint11; /* unsigned 11 bit Integer */
1506 typedef SWORD sint11; /* signed 11 bit Integer */
1507 typedef UWORD uint12; /* unsigned 12 bit Integer */
1508 typedef SWORD sint12; /* signed 12 bit Integer */
1509 typedef UWORD uint13; /* unsigned 13 bit Integer */
1510 typedef SWORD sint13; /* signed 13 bit Integer */
1511 typedef UWORD uint14; /* unsigned 14 bit Integer */
1512 typedef SWORD sint14; /* signed 14 bit Integer */
1513 typedef UWORD uint15; /* unsigned 15 bit Integer */
1514 typedef SWORD sint15; /* signed 15 bit Integer */
1515 typedef UWORD uint16; /* unsigned 16 bit Integer */
1516 typedef SWORD sint16; /* signed 16 bit Integer */
1517 typedef ULONG uint17; /* unsigned 17 bit Integer */
1518 typedef SLONG sint17; /* signed 17 bit Integer */
1519 typedef ULONG uint18; /* unsigned 18 bit Integer */
1520 typedef SLONG sint18; /* signed 18 bit Integer */
1521 typedef ULONG uint19; /* unsigned 19 bit Integer */
1522 typedef SLONG sint19; /* signed 19 bit Integer */
1523 typedef ULONG uint20; /* unsigned 20 bit Integer */
1524 typedef SLONG sint20; /* signed 20 bit Integer */
1525 typedef ULONG uint21; /* unsigned 21 bit Integer */
1526 typedef SLONG sint21; /* signed 21 bit Integer */
1527 typedef ULONG uint22; /* unsigned 22 bit Integer */
1528 typedef SLONG sint22; /* signed 22 bit Integer */
1529 typedef ULONG uint23; /* unsigned 23 bit Integer */
1530 typedef SLONG sint23; /* signed 23 bit Integer */
1531 typedef ULONG uint24; /* unsigned 24 bit Integer */
1532 typedef SLONG sint24; /* signed 24 bit Integer */
1533 typedef ULONG uint25; /* unsigned 25 bit Integer */
1534 typedef SLONG sint25; /* signed 25 bit Integer */
1535 typedef ULONG uint26; /* unsigned 26 bit Integer */
1536 typedef SLONG sint26; /* signed 26 bit Integer */
1537 typedef ULONG uint27; /* unsigned 27 bit Integer */
1538 typedef SLONG sint27; /* signed 27 bit Integer */
1539 typedef ULONG uint28; /* unsigned 28 bit Integer */
1540 typedef SLONG sint28; /* signed 28 bit Integer */
1541 typedef ULONG uint29; /* unsigned 29 bit Integer */
1542 typedef SLONG sint29; /* signed 29 bit Integer */
1543 typedef ULONG uint30; /* unsigned 30 bit Integer */
1544 typedef SLONG sint30; /* signed 30 bit Integer */
1545 typedef ULONG uint31; /* unsigned 31 bit Integer */
1546 typedef SLONG sint31; /* signed 31 bit Integer */
1547 typedef ULONG uint32; /* unsigned 32 bit Integer */
1548 typedef SLONG sint32; /* signed 32 bit Integer */
1549 #ifdef HAVE_LONG_LONG_INT
1550 typedef ULONGLONG uint33; /* unsigned 33 bit Integer */
1551 typedef SLONGLONG sint33; /* signed 33 bit Integer */
1552 typedef ULONGLONG uint48; /* unsigned 48 bit Integer */
1553 typedef SLONGLONG sint48; /* signed 48 bit Integer */
1554 typedef ULONGLONG uint64; /* unsigned 64 bit Integer */
1555 typedef SLONGLONG sint64; /* signed 64 bit Integer */
1556 #endif
1557 #define exact_uint_size_p(n) (((n)==char_bitsize)||((n)==short_bitsize)||((n)==int_bitsize)||((n)==long_bitsize))
1558 #define signed_int_with_n_bits(n) CONCAT(sint,n)
1559 #define unsigned_int_with_n_bits(n) CONCAT(uint,n)
1560 /* Use 'uintn' and 'sintn' for Integers with exactly specified width.
1561 exact_uint_size_p(n) specifies, whether the uint with n Bits has really
1562 only n Bits. */
1563 %% { int i;
1564 %% for (i=1; i<=8; i++) {
1565 %% sprintf(buf,"uint%d",i); emit_typedef("UBYTE",buf);
1566 %% sprintf(buf,"sint%d",i); emit_typedef("SBYTE",buf);
1567 %% }
1568 %% for (i=9; i<=16; i++) {
1569 %% sprintf(buf,"uint%d",i); emit_typedef("UWORD",buf);
1570 %% sprintf(buf,"sint%d",i); emit_typedef("SWORD",buf);
1571 %% }
1572 %% for (i=17; i<=32; i++) {
1573 %% sprintf(buf,"uint%d",i); emit_typedef("ULONG",buf);
1574 %% sprintf(buf,"sint%d",i); emit_typedef("SLONG",buf);
1575 %% }
1576 %% #ifdef HAVE_LONG_LONG_INT
1577 %% for (i=33; i<=64; i++)
1578 %% if ((i==33) || (i==48) || (i==64)) {
1579 %% sprintf(buf,"uint%d",i); emit_typedef("ULONGLONG",buf);
1580 %% sprintf(buf,"sint%d",i); emit_typedef("SLONGLONG",buf);
1581 %% }
1582 %% #endif
1583 %% }
1584
1585 /* 'uintX' and 'sintX' mean unsigned bzw. signed integer - types with
1586 wordsize X (X=B,W,L,Q) here as well. */
1587 #define intBsize 8
1588 typedef signed_int_with_n_bits(intBsize) sintB;
1589 typedef unsigned_int_with_n_bits(intBsize) uintB;
1590 #define intWsize 16
1591 typedef signed_int_with_n_bits(intWsize) sintW;
1592 typedef unsigned_int_with_n_bits(intWsize) uintW;
1593 #define intLsize 32
1594 typedef signed_int_with_n_bits(intLsize) sintL;
1595 typedef unsigned_int_with_n_bits(intLsize) uintL;
1596 #if (long_bitsize==64) || defined(MIPS64) || defined(IA64) || defined(AMD64) || defined(ARM64)
1597 /* Machine has real 64-bit integers in hardware. */
1598 #define intQsize 64
1599 typedef signed_int_with_n_bits(intQsize) sintQ;
1600 typedef unsigned_int_with_n_bits(intQsize) uintQ;
1601 /* Bit number n (0<=n<64)
1602 This is an uintQ expression, in order to avoid signed integer overflow
1603 in expressions like bitQ(63) or bitQ(63)-1. */
1604 #define bitQ(n) ((uintQ)1<<(n))
1605 /* Bit number n (0<n<=64) mod 2^64 */
1606 #define bitQm(n) ((uintQ)2<<((n)-1))
1607 /* Bit-test of bit n in x, n constant, x an uintQ or sintQ: */
1608 #define bitQ_test(x,n) ((x) & bitQ(n))
1609 /* Minus bit number n (0<=n<64) */
1610 #define minus_bitQ(n) (-(sintQ)1<<(n))
1611 /* Minus bit number n (0<n<=64) mod 2^64 */
1612 #define minus_bitQm(n) (-(sintQ)2<<((n)-1))
1613 typedef sintQ sintL2;
1614 typedef uintQ uintL2;
1615 #else
1616 /* Emulate 64-Bit-numbers using two 32-Bit-numbers. */
1617 typedef struct { sintL hi; uintL lo; } sintL2; /* signed 64 Bit integer */
1618 typedef struct { uintL hi; uintL lo; } uintL2; /* unsigned 64 Bit integer */
1619 #endif
1620 /* Use 'uintX' and 'sintX' for Integers with approximately given width
1621 and a minumum of storage space. */
1622 %% sprintf(buf,"sint%d",intBsize); emit_typedef(buf,"sintB");
1623 %% sprintf(buf,"uint%d",intBsize); emit_typedef(buf,"uintB");
1624 %% sprintf(buf,"sint%d",intWsize); emit_typedef(buf,"sintW");
1625 %% sprintf(buf,"uint%d",intWsize); emit_typedef(buf,"uintW");
1626 %% sprintf(buf,"sint%d",intLsize); emit_typedef(buf,"sintL");
1627 %% sprintf(buf,"uint%d",intLsize); emit_typedef(buf,"uintL");
1628 %% #if notused
1629 %% #ifdef intQsize
1630 %% sprintf(buf,"sint%d",intQsize); emit_typedef(buf,"sintQ");
1631 %% sprintf(buf,"uint%d",intQsize); emit_typedef(buf,"uintQ");
1632 %% #else
1633 %% emit_typedef("struct { sintL hi; uintL lo; }","sintL2");
1634 %% emit_typedef("struct { uintL hi; uintL lo; }","uintL2");
1635 %% #endif
1636 %% #endif
1637
1638 /* From here on 'uintP' and 'sintP' are unsigned or signed integer types,
1639 which are as wide as void* - pointers */
1640 typedef signed_int_with_n_bits(pointer_bitsize) sintP;
1641 typedef unsigned_int_with_n_bits(pointer_bitsize) uintP;
1642 %% sprintf(buf,"sint%d",pointer_bitsize); emit_typedef(buf,"sintP");
1643 %% sprintf(buf,"uint%d",pointer_bitsize); emit_typedef(buf,"uintP");
1644
1645 /* From here on 'uintXY' and 'sintXY' mean unsigned or signed integer types,
1646 with word sizes X or Y (X,Y=B,W,L). */
1647 #if defined(M68K)
1648 /* The 68000 offers good processing of uintB and uintW, especially
1649 DBRA-commands for uintW. */
1650 #define intBWsize intBsize
1651 #define intWLsize intWsize
1652 #define intBWLsize intBsize
1653 #elif defined(SPARC) || defined(HPPA) || defined(MIPS) || defined(POWERPC) || defined(S390)
1654 /* The Sparc-processor computes rather badly with uintB and uintW.
1655 Other 32-Bit-processoren have similar weaknesses. */
1656 #define intBWsize intWsize
1657 #define intWLsize intLsize
1658 #define intBWLsize intLsize
1659 #elif defined(I80386) || defined(AMD64)
1660 /* If you compute using uintB and uintW on a 80386, there will be many
1661 Zero-Extends, that will - because there aren't enough registers - load
1662 other variables into memory, which is rather unnecessary. */
1663 #define intBWsize intWsize
1664 #define intWLsize intLsize
1665 #define intBWLsize intLsize
1666 #elif defined(ARM)
1667 /* The ARM computes very badly when it uses uintB and uintW. */
1668 #define intBWsize intBsize
1669 #define intWLsize intLsize
1670 #define intBWLsize intLsize
1671 #elif defined(DECALPHA) || defined(IA64)
1672 /* 64-bit processors also compute badly with uintB and uintW. */
1673 #define intBWsize intWsize
1674 #define intWLsize intLsize
1675 #define intBWLsize intLsize
1676 #elif 1
1677 /* For unknown CPUs, we prefer slightly suboptimal code to a compilation failure. */
1678 #define intBWsize intWsize
1679 #define intWLsize intLsize
1680 #define intBWLsize intLsize
1681 #else
1682 #error Preferred integer sizes depend on CPU -- readjust intBWsize, intWLsize, intBWLsize!
1683 #endif
1684 typedef signed_int_with_n_bits(intBWsize) sintBW;
1685 typedef unsigned_int_with_n_bits(intBWsize) uintBW;
1686 typedef signed_int_with_n_bits(intWLsize) sintWL;
1687 typedef unsigned_int_with_n_bits(intWLsize) uintWL;
1688 typedef signed_int_with_n_bits(intBWLsize) sintBWL;
1689 typedef unsigned_int_with_n_bits(intBWLsize) uintBWL;
1690 /* Use 'uintXY' and 'sintXY' for integers with given minumum width,
1691 that allow easy computations. */
1692 %% #if notused
1693 %% sprintf(buf,"sint%d",intBWsize); emit_typedef(buf,"sintBW");
1694 %% sprintf(buf,"uint%d",intBWsize); emit_typedef(buf,"uintBW");
1695 %% sprintf(buf,"sint%d",intWLsize); emit_typedef(buf,"sintWL");
1696 %% #endif
1697 %% sprintf(buf,"uint%d",intWLsize); emit_typedef(buf,"uintWL");
1698 %% #if notused
1699 %% sprintf(buf,"sint%d",intBWLsize); emit_typedef(buf,"sintBWL");
1700 %% #endif
1701 %% sprintf(buf,"uint%d",intBWLsize); emit_typedef(buf,"uintBWL");
1702
1703 /* Loop that will excute as statement a certain number of times:
1704 dotimesW(countvar,count,statement); if count fits into a uintW,
1705 dotimesL(countvar,count,statement); if count only fits into a uintL,
1706 dotimesV(countvar,count,statement); if count only fits into a uintV,
1707 dotimespW(countvar,count,statement); if count fits into a uintW and is >0,
1708 dotimespL(countvar,count,statement); if count fits only into a uintL and is >0.
1709 dotimespV(countvar,count,statement); if count fits only into a uintV and is >0.
1710 The variable countvar has to be declared previously, be of type uintW or uintL,
1711 and will be changed by this expression.
1712 It must not be used in the statement itself!
1713 The expression count will only be evaluated once (at the beginning). */
1714 #if defined(GNU) && defined(M68K)
1715 /* GNU-C on a 680X0 can be persuaded to use the DBRA-instruction: */
1716 #define fast_dotimesW
1717 /* To find out, what the best was to 'persuade' GNU-C is, check the
1718 code, that'll be generated for spvw.d:gc_markphase().
1719 Or a small test program (dbratest.c), that is compiled with
1720 "gcc -O6 -da -S dbratest.c", and take a look at dbratest.s
1721 and dbratest.c.flow as well as dbratest.c.combine. */
1722 #if (__GNUC__<2) /* GNU C Version 1 */
1723 #define dotimesW_(countvar_from_dotimesW,count_from_dotimesW,statement_from_dotimesW) \
1724 { countvar_from_dotimesW = (count_from_dotimesW); \
1725 if (!(countvar_from_dotimesW==0)) \
1726 { countvar_from_dotimesW--; \
1727 do {statement_from_dotimesW} \
1728 while ((sintW)--countvar_from_dotimesW != -1); \
1729 } }
1730 #define dotimespW_(countvar_from_dotimespW,count_from_dotimespW,statement_from_dotimespW) \
1731 { countvar_from_dotimespW = (count_from_dotimespW)-1; \
1732 do {statement_from_dotimespW} while ((sintW)--countvar_from_dotimespW != -1); \
1733 }
1734 #else
1735 #define dotimesW_(countvar_from_dotimesW,count_from_dotimesW,statement_from_dotimesW) \
1736 { countvar_from_dotimesW = (count_from_dotimesW); \
1737 if (!(countvar_from_dotimesW==0)) \
1738 { countvar_from_dotimesW--; \
1739 do {statement_from_dotimesW} \
1740 while ((sintW)(--countvar_from_dotimesW)+1 != 0); \
1741 } }
1742 #define dotimespW_(countvar_from_dotimespW,count_from_dotimespW,statement_from_dotimespW) \
1743 { countvar_from_dotimespW = (count_from_dotimespW)-1; \
1744 do {statement_from_dotimespW} while ((sintW)(--countvar_from_dotimespW)+1 != 0); \
1745 }
1746 #endif
1747 #else
1748 #define dotimesW_(countvar_from_dotimesW,count_from_dotimesW,statement_from_dotimesW) \
1749 { countvar_from_dotimesW = (count_from_dotimesW); \
1750 while (countvar_from_dotimesW != 0) \
1751 {statement_from_dotimesW; countvar_from_dotimesW--; } \
1752 }
1753 #define dotimespW_(countvar_from_dotimespW,count_from_dotimespW,statement_from_dotimespW) \
1754 { countvar_from_dotimespW = (count_from_dotimespW); \
1755 do {statement_from_dotimespW} while (--countvar_from_dotimespW != 0); \
1756 }
1757 #endif
1758 #if defined(GNU) && defined(M68K)
1759 /* GNU-C on a 680X0 can be 'persuaded' to use the DBRA-instruction
1760 in an intelligent manner: */
1761 #define fast_dotimesL
1762 #define dotimesL_(countvar_from_dotimesL,count_from_dotimesL,statement_from_dotimesL) \
1763 { countvar_from_dotimesL = (count_from_dotimesL); \
1764 if (!(countvar_from_dotimesL==0)) \
1765 { countvar_from_dotimesL--; \
1766 do {statement_from_dotimesL} \
1767 while ((sintL)(--countvar_from_dotimesL) != -1); \
1768 } }
1769 #define dotimespL_(countvar_from_dotimespL,count_from_dotimespL,statement_from_dotimespL) \
1770 { countvar_from_dotimespL = (count_from_dotimespL)-1; \
1771 do {statement_from_dotimespL} while ((sintL)(--countvar_from_dotimespL) != -1); \
1772 }
1773 #endif
1774 #ifndef dotimesL_
1775 #define dotimesL_(countvar_from_dotimesL,count_from_dotimesL,statement_from_dotimesL) \
1776 { countvar_from_dotimesL = (count_from_dotimesL); \
1777 while (countvar_from_dotimesL != 0) \
1778 {statement_from_dotimesL; countvar_from_dotimesL--; } \
1779 }
1780 #define dotimespL_(countvar_from_dotimespL,count_from_dotimespL,statement_from_dotimespL) \
1781 { countvar_from_dotimespL = (count_from_dotimespL); \
1782 do {statement_from_dotimespL} while (--countvar_from_dotimespL != 0); \
1783 }
1784 #endif
1785 #if defined(GNU) && defined(__OPTIMIZE__)
1786 /* It happened twice to me that I used dotimesL on a
1787 variable of type uintC. I check for that now, so that
1788 Joerg and Marcus won't have to search for that anymore.
1789 The GCC will optimize the dummy-call away, if things go by plan.
1790 If not, you'll see a linker error. */
1791 #define dotimes_check_sizeof(countvar,type) \
1792 if (!(sizeof(countvar)==sizeof(type))) { dotimes_called_with_count_of_wrong_size(); }
1793 extern void dotimes_called_with_count_of_wrong_size (void); /* non-existing function */
1794 %% exportF(void,dotimes_called_with_count_of_wrong_size,(void));
1795 #else
1796 #define dotimes_check_sizeof(countvar,type)
1797 #endif
1798 #define dotimesW(countvar_from_dotimesW,count_from_dotimesW,statement_from_dotimesW) \
1799 do { dotimes_check_sizeof(countvar_from_dotimesW,uintW); \
1800 dotimesW_(countvar_from_dotimesW,count_from_dotimesW,statement_from_dotimesW); \
1801 } while(0)
1802 #define dotimespW(countvar_from_dotimespW,count_from_dotimespW,statement_from_dotimespW) \
1803 do { dotimes_check_sizeof(countvar_from_dotimespW,uintW); \
1804 dotimespW_(countvar_from_dotimespW,count_from_dotimespW,statement_from_dotimespW); \
1805 } while(0)
1806 #define dotimesL(countvar_from_dotimesL,count_from_dotimesL,statement_from_dotimesL) \
1807 do { dotimes_check_sizeof(countvar_from_dotimesL,uintL); \
1808 dotimesL_(countvar_from_dotimesL,count_from_dotimesL,statement_from_dotimesL); \
1809 } while(0)
1810 #define dotimespL(countvar_from_dotimespL,count_from_dotimespL,statement_from_dotimespL) \
1811 do { dotimes_check_sizeof(countvar_from_dotimespL,uintL); \
1812 dotimespL_(countvar_from_dotimespL,count_from_dotimespL,statement_from_dotimespL); \
1813 } while(0)
1814 #define dotimesV(countvar_from_dotimesV,count_from_dotimesV,statement_from_dotimesV) \
1815 do { dotimes_check_sizeof(countvar_from_dotimesV,uintV); \
1816 dotimesL_(countvar_from_dotimesV,count_from_dotimesV,statement_from_dotimesV); \
1817 } while(0)
1818 #define dotimespV(countvar_from_dotimespV,count_from_dotimespV,statement_from_dotimespV) \
1819 do { dotimes_check_sizeof(countvar_from_dotimespV,uintV); \
1820 dotimespL_(countvar_from_dotimespV,count_from_dotimespV,statement_from_dotimespV); \
1821 } while(0)
1822 /* doconsttimes(count,statement);
1823 executes a statement count times (count times the code!),
1824 where count is a constant-expression >=0, <=8. */
1825 #define doconsttimes(count_from_doconsttimes,statement_from_doconsttimes) \
1826 do { if (0 < (count_from_doconsttimes)) { statement_from_doconsttimes; } \
1827 if (1 < (count_from_doconsttimes)) { statement_from_doconsttimes; } \
1828 if (2 < (count_from_doconsttimes)) { statement_from_doconsttimes; } \
1829 if (3 < (count_from_doconsttimes)) { statement_from_doconsttimes; } \
1830 if (4 < (count_from_doconsttimes)) { statement_from_doconsttimes; } \
1831 if (5 < (count_from_doconsttimes)) { statement_from_doconsttimes; } \
1832 if (6 < (count_from_doconsttimes)) { statement_from_doconsttimes; } \
1833 if (7 < (count_from_doconsttimes)) { statement_from_doconsttimes; } \
1834 } while(0)
1835 /* DOCONSTTIMES(count,macroname);
1836 calls the macro macroname count times (count times the code!),
1837 where count is a constant-expression >=0, <=8.
1838 And macroname will get the values 0,...,count-1 in sequence. */
1839 #define DOCONSTTIMES(count_from_DOCONSTTIMES,macroname_from_DOCONSTTIMES) \
1840 do { if (0 < (count_from_DOCONSTTIMES)) { macroname_from_DOCONSTTIMES((0 < (count_from_DOCONSTTIMES) ? 0 : 0)); } \
1841 if (1 < (count_from_DOCONSTTIMES)) { macroname_from_DOCONSTTIMES((1 < (count_from_DOCONSTTIMES) ? 1 : 0)); } \
1842 if (2 < (count_from_DOCONSTTIMES)) { macroname_from_DOCONSTTIMES((2 < (count_from_DOCONSTTIMES) ? 2 : 0)); } \
1843 if (3 < (count_from_DOCONSTTIMES)) { macroname_from_DOCONSTTIMES((3 < (count_from_DOCONSTTIMES) ? 3 : 0)); } \
1844 if (4 < (count_from_DOCONSTTIMES)) { macroname_from_DOCONSTTIMES((4 < (count_from_DOCONSTTIMES) ? 4 : 0)); } \
1845 if (5 < (count_from_DOCONSTTIMES)) { macroname_from_DOCONSTTIMES((5 < (count_from_DOCONSTTIMES) ? 5 : 0)); } \
1846 if (6 < (count_from_DOCONSTTIMES)) { macroname_from_DOCONSTTIMES((6 < (count_from_DOCONSTTIMES) ? 6 : 0)); } \
1847 if (7 < (count_from_DOCONSTTIMES)) { macroname_from_DOCONSTTIMES((7 < (count_from_DOCONSTTIMES) ? 7 : 0)); } \
1848 } while(0)
1849
1850 /* From here on uintC means an unsigned integer type, that'll allow
1851 easy counting. Subset relation: uintW <= uintC <= uintL. */
1852 #define intCsize intWLsize
1853 #define uintC uintWL
1854 #define sintC sintWL
1855 #if (intCsize==intWsize)
1856 #define dotimesC dotimesW
1857 #define dotimespC dotimespW
1858 #endif
1859 #if (intCsize==intLsize)
1860 #define dotimesC dotimesL
1861 #define dotimespC dotimespL
1862 #endif
1863 /* Use 'uintC' for counters, which are small most of the time. */
1864 %% export_def(uintC);
1865 %% #if notused
1866 %% export_def(sintC);
1867 %% #endif
1868
1869 /* The arithmetics use "digit sequences" of "digits".
1870 They are unsigned ints with intDsize bits (should be =8 or =16 or =32).
1871 If HAVE_DD: "double-digits" are unsigned ints with 2*intDsize<=32 bits. */
1872 #if 1 /* defined(M68K) || defined(I80386) || defined(SPARC) || defined(HPPA) || defined(MIPS) || defined(POWERPC) || defined(ARM) || defined(DECALPHA) || defined(IA64) || defined(AMD64) || defined(S390) || defined(RISCV64) || ... */
1873 #define intDsize 32
1874 #define intDDsize 64 /* = 2*intDsize */
1875 #define log2_intDsize 5 /* = log2(intDsize) */
1876 #else
1877 #error Preferred digit size depends on CPU -- readjust intDsize!
1878 #endif
1879 typedef unsigned_int_with_n_bits(intDsize) uintD;
1880 typedef signed_int_with_n_bits(intDsize) sintD;
1881 #if (intDDsize<=32) || ((intDDsize<=64) && ((long_bitsize==64) || defined(MIPS64) || defined(IA64) || defined(AMD64) || defined(ARM64)))
1882 #define HAVE_DD 1
1883 typedef unsigned_int_with_n_bits(intDDsize) uintDD;
1884 typedef signed_int_with_n_bits(intDDsize) sintDD;
1885 #else
1886 #define HAVE_DD 0
1887 #endif
1888 %% #if notused
1889 %% sprintf(buf,"sint%d",intDsize); emit_typedef(buf,"sintD");
1890 %% #endif
1891 %% sprintf(buf,"uint%d",intDsize); emit_typedef(buf,"uintD");
1892
1893
1894 /* ###################### OS-related routines #################### */
1895
1896 /* general standard constants for control chars: */
1897 #define BS 8 /* #\Backspace Backspace */
1898 #define TAB 9 /* #\Tab Tabulator */
1899 #define LF 10 /* #\Linefeed linefeed */
1900 #define CR 13 /* #\Return carriage return */
1901 #define PG 12 /* #\Page form feed, new page */
1902
1903 /* Desired reaction when an I/O operation cannot be completed immediately. */
1904 typedef enum {
1905 persev_full, /* Continue the I/O operation until the whole buffer is
1906 handled or EOF or an error occurred. May hang. */
1907 persev_partial, /* Continue the I/O operation until some (non-empty) part
1908 of the buffer is handled or EOF or an error occurred.
1909 May hang. */
1910 persev_immediate, /* Act immediately. Perform I/O only if we know in advance
1911 that it will not block. In case of doubt, perform it
1912 anyway. May return with 0 bytes handled. Does usually
1913 not hang. */
1914 persev_bonus /* Act immediately. Perform I/O only if we know in advance
1915 that it will not block. In case of doubt, don't perform
1916 it. May return with 0 bytes handled. Does not hang. */
1917 } perseverance_t;
1918 %% printf("typedef enum { persev_full=%d, persev_partial=%d, persev_immediate=%d, persev_bonus=%d } perseverance_t;\n",persev_full,persev_partial,persev_immediate,persev_bonus);
1919
1920 #if defined(UNIX) || defined(WIN32)
1921
1922 #ifdef UNIX
1923 #include "unix.c"
1924 #endif
1925 #ifdef WIN32_NATIVE
1926 #include "win32.c"
1927 #endif
1928 %% #if defined(UNIX)
1929 %% emit_typedef("int","Handle");
1930 %% emit_typedef("int","SOCKET");
1931 %% #ifdef UNIX_CYGWIN
1932 %% puts("#include <windows.h>");
1933 %% puts("#undef WIN32");
1934 %% exportF(long,time_t_from_filetime,(const FILETIME * ptr));
1935 %% exportF(void,time_t_to_filetime,(time_t time_in, FILETIME * out));
1936 %% #endif
1937 %% #elif defined(WIN32_NATIVE)
1938 %% puts("#include <winsock2.h>"); /* defines SOCKET */
1939 %% puts("#include <windows.h>");
1940 %% export_def(Handle);
1941 %% #else
1942 %% puts("#error what is Handle on your platform?!");
1943 %% #endif
1944 %% #if defined(UNIX)
1945 %% exportF(ssize_t,fd_read,(int fd, void* buf, size_t nbyte, perseverance_t persev));
1946 %% exportF(ssize_t,fd_write,(int fd, const void* buf, size_t nbyte, perseverance_t persev));
1947 %% #elif defined(WIN32_NATIVE)
1948 %% exportF(ssize_t,fd_read,(Handle fd, void* buf, size_t nbyte, perseverance_t persev));
1949 %% exportF(ssize_t,fd_write,(Handle fd, const void* buf, size_t nbyte, perseverance_t persev));
1950 %% #endif
1951
1952 /* execute statement on interrupt:
1953 interruptp(statement); */
1954 #if defined(UNIX) || defined(WIN32_NATIVE)
1955 /* A keyboard interrupt (signal SIGINT, generated by Ctrl-C)
1956 is pending for one second. It can be treated with 'interruptp' in
1957 a continuable manner in that time. After this time has passed, the
1958 program will be interrupted and cannot be continued. */
1959 #if !defined(MULTITHREAD)
1960 #define PENDING_INTERRUPTS
1961 /* Flag telling whether a Ctrl-C has been seen and is waiting to be
1962 handled. */
1963 extern uintB interrupt_pending;
1964 #define interruptp(statement) if (interrupt_pending) { statement; }
1965 #else
1966 /* In MT interrupt_pending and interuptp are not used at all.
1967 actually even tast_break() is obsolete.*/
1968 #define interruptp(statement)
1969 #endif
1970 #endif
1971 /* used by EVAL, IO, SPVW, STREAM */
1972
1973 #endif /* UNIX || WIN32 */
1974
1975 #if (defined(UNIX) || defined(WIN32_NATIVE)) && defined(HAVE_LIBSIGSEGV)
1976 /* Support for fault handling. */
1977 #include <sigsegv.h>
1978 #if defined(UNIX_CYGWIN)
1979 /* <sigsegv.h> includes <windows.h> */
1980 #undef WIN32
1981 #endif
1982 #endif
1983
1984 /* Ignoring of a value (instead of assigning it to a variable)
1985 unused ...
1986 <sigsegv.h> includes <windows.h> which uses unused! */
1987 #ifndef unused /* win32.d defines unused */
1988 #ifdef GNU /* to prevent a gcc-warning "statement with no effect" */
1989 #define unused (void)
1990 #else
1991 #define unused
1992 #endif
1993 #endif
1994
1995 /* Consensys and Solaris: "#define DS 3", "#define SP ESP", "#define EAX 11".
1996 Grr... */
1997 #undef DS
1998 #undef SP
1999 #undef EAX
2000 /* 386BSD does "#define CBLOCK 64". Grr... */
2001 #undef CBLOCK
2002 /* AIX 3.2.5 does "#define hz 100". Grr... */
2003 #undef hz
2004
2005 #ifdef UNIX
2006 /* Handling of UNIX errors
2007 OS_error();
2008 > int errno: error code */
2009 extern _Noreturn void OS_error (void);
2010 /* used by SPVW, STREAM, PATHNAME, GRAPH */
2011 #endif
2012 #if defined(WIN32_NATIVE)
2013 /* Handling of Win32 errors
2014 OS_error();
2015 > GetLastError(): error code */
2016 extern _Noreturn void OS_error (void);
2017 #endif
2018 #if defined(DEBUG_OS_ERROR)
2019 /* Show the file and line number of the caller of OS_error(). For debugging. */
2020 #define OS_error() \
2021 (fprintf(stderr,"\n[%s:%d] ",__FILE__,__LINE__), (OS_error)())
2022 #endif
2023 %% exportE(OS_error,(void));
2024
2025 /* Handling of ANSI C errors
2026 ANSIC_error();
2027 > int errno: error code */
2028 #ifdef UNIX
2029 #define ANSIC_error OS_error
2030 %% export_def(ANSIC_error);
2031 #else
2032 _Noreturn extern void ANSIC_error (void);
2033 %% exportE(ANSIC_error,(void));
2034 #endif
2035 /* used by SPVW, STREAM */
2036
2037 /* ##################### Further system-dependencies #################### */
2038
2039 /* At first dependencies that are visible to the LISP-level: */
2040
2041 /* setting of the table of character-names: */
2042 #ifdef WIN32
2043 #define WIN32_CHARNAMES
2044 #endif
2045 #ifdef UNIX
2046 #define UNIX_CHARNAMES
2047 #endif
2048 /* When changed: extend CONSTOBJ, CHARSTRG, FORMAT.LISP. */
2049
2050 /* Whether to use the GNU gettext library for internationalization: */
2051 #if defined(ENABLE_NLS) && !defined(NO_GETTEXT)
2052 #define GNU_GETTEXT
2053 #endif
2054
2055 /* Whether to create a stream *KEYBOARD-INPUT*
2056 and whether it will be used for the stream *TERMINAL-IO*: */
2057 #if (defined(UNIX) && !defined(NO_TERMCAP_NCURSES)) || defined(WIN32_NATIVE)
2058 #define KEYBOARD
2059 #if 0
2060 #define TERMINAL_USES_KEYBOARD
2061 #endif
2062 #endif
2063 /* When changed: extend stream.d, keyboard.lisp */
2064
2065 /* Whether to use the GNU readline library for *TERMINAL-IO*: */
2066 #if defined(HAVE_READLINE) && !defined(NO_READLINE)
2067 #define GNU_READLINE
2068 #endif
2069
2070 /* Whether there are Window-streams and a package SCREEN: */
2071 #if (defined(UNIX) && !defined(NO_TERMCAP_NCURSES)) || defined(WIN32_NATIVE)
2072 #define SCREEN
2073 #endif
2074 /* When changed: extend stream.d (loads of work!). */
2075
2076 /* Whether there are Pipe-streams: */
2077 #if defined(UNIX) || defined(WIN32_NATIVE)
2078 #define PIPES
2079 #if defined(UNIX) || defined(WIN32_NATIVE)
2080 #define PIPES2 /* bidirectional pipes */
2081 #endif
2082 #endif
2083 /* When changed: extend stream.d and runprog.lisp. */
2084
2085 /* If the system has sockets, we support socket streams:
2086 We assume that if we have gethostbyname(), we have a networking OS
2087 (Unix or Win32). Then we decide independently about UNIX domain connections
2088 and TCP/IP connections. */
2089 #if defined(HAVE_GETHOSTBYNAME) /* ==> defined(UNIX) || defined(WIN32_NATIVE) */
2090 #ifdef HAVE_SYS_UN_H /* have <sys/un.h> and Unix domain sockets? */
2091 #define UNIXCONN /* use Unix domain sockets */
2092 #endif
2093 #define TCPCONN /* use TCP/IP sockets */
2094 /* Now, which kinds of socket streams: */
2095 #define X11SOCKETS /* works even without TCPCONN (very young Linux) */
2096 #define SOCKET_STREAMS
2097 #endif
2098 /* When changed: extend stream.d, socket.d */
2099
2100 /* Whether there are generic streams: */
2101 #if 1
2102 #define GENERIC_STREAMS
2103 #endif
2104 /* When changed: do nothing */
2105
2106 /* Whether a foreign function interface is provided: */
2107 #if (defined(UNIX) && !defined(UNIX_BINARY_DISTRIB)) || defined(DYNAMIC_FFI)
2108 #define HAVE_FFI
2109 #endif
2110 /* When changed: ?? */
2111
2112 /* Now the ones that are only relevant internally: */
2113
2114 /* Whether the GC closes files that aren't referenced any longer: */
2115 #if defined(UNIX) || defined(WIN32)
2116 #define GC_CLOSES_FILES
2117 #endif
2118 /* When changed: do nothing */
2119
2120 /* How time is measured: */
2121 #if defined(UNIX)
2122 #define TIME_UNIX
2123 #elif defined(WIN32_NATIVE)
2124 #define TIME_WIN32
2125 #else
2126 #error how do you measure time on this system
2127 #endif
2128 /* When changed: extend time.d */
2129
2130 /* Whether the operating system provides virtual memory. */
2131 #if (defined(UNIX) || defined(WIN32)) && !defined(NO_VIRTUAL_MEMORY)
2132 #define VIRTUAL_MEMORY
2133 #endif
2134 /* When changed: do nothing */
2135
2136 /* Where the operating system allocates memory (via mmap or malloc).
2137 Some of these locations may be randomized to some extent; cf.
2138 "address space layout randomization" (ASLR)
2139 <https://en.wikipedia.org/wiki/Address_space_layout_randomization>.
2140
2141 To determine the address space layout:
2142 1) Attempt to build clisp with
2143 $ make -f Makefile.devel build-porting32-gcc-portability
2144 (for 32-bit ABIs) or
2145 $ make -f Makefile.devel build-porting64-gcc-portability
2146 The build does not need to complete; you only need the lisp.run
2147 program.
2148 $ cd build-porting{32,64}-gcc-portability
2149 2) Gain an understanding of the address space layout:
2150 $ grep HIGHEST config.status
2151 $ grep RANGE config.status
2152 $ ./lisp.run -mm
2153 If some randomization is present, run
2154 $ for i in `seq 100`; do ./lisp.run -mm; done | sort
2155 You can use the tools listed in unix/PLATFORMS here.
2156 3) Define the values
2157 MAPPABLE_ADDRESS_RANGE_START
2158 MAPPABLE_ADDRESS_RANGE_END
2159 here. Or for two ranges:
2160 MAPPABLE_ADDRESS_RANGE1_START
2161 MAPPABLE_ADDRESS_RANGE1_END
2162 MAPPABLE_ADDRESS_RANGE2_START
2163 MAPPABLE_ADDRESS_RANGE2_END
2164 The _START values should be multiples of the page size.
2165 The _END values + 1 should be multiples of the page size.
2166 If no such range can be determined, define ADDRESS_RANGE_RANDOMIZED.
2167 4) Recompile lisp.run and run
2168 $ make marc.out
2169 */
2170 /* Sort order: Keep this list sorted by
2171 1. word size (32-bit before 64-bit),
2172 2. operating system (Linux, *BSD, Mac OS X, proprietary Unices, Windows)
2173 3. CPU and ABI (alphabetically) */
2174 #if !defined(WIDE_HARD)
2175 /* 32-bit platforms */
2176 #if defined(UNIX_LINUX) && defined(AMD64)
2177 /* On Linux/x86_64 with 32-bit x32 ABI:
2178 MMAP_FIXED_ADDRESS_HIGHEST_BIT = 30
2179 CODE_ADDRESS_RANGE = 0x00000000UL
2180 MALLOC_ADDRESS_RANGE = 0x01000000UL ... 0x02000000UL
2181 SHLIB_ADDRESS_RANGE = 0xF7000000UL
2182 STACK_ADDRESS_RANGE = 0xFF000000UL
2183 There is room from 0x03000000UL to 0xF7000000UL, but let's keep some
2184 distance. */
2185 #define MAPPABLE_ADDRESS_RANGE_START 0x10000000UL
2186 #define MAPPABLE_ADDRESS_RANGE_END 0xEFFFFFFFUL
2187 #endif
2188 #if defined(UNIX_LINUX) && defined(ARM)
2189 /* On Linux/arm:
2190 MMAP_FIXED_ADDRESS_HIGHEST_BIT = 30
2191 CODE_ADDRESS_RANGE = 0x00000000UL
2192 MALLOC_ADDRESS_RANGE = 0x00000000UL ... 0x02000000UL
2193 SHLIB_ADDRESS_RANGE = 0xB6000000UL
2194 STACK_ADDRESS_RANGE = 0xBE000000UL
2195 On Linux/arm64 with CC="arm-linux-gnueabihf-gcc-4.8":
2196 MMAP_FIXED_ADDRESS_HIGHEST_BIT = 30
2197 CODE_ADDRESS_RANGE = 0x00000000UL
2198 MALLOC_ADDRESS_RANGE = 0x00000000UL
2199 SHLIB_ADDRESS_RANGE = 0x40000000UL or 0xF7000000UL
2200 STACK_ADDRESS_RANGE = 0xFF000000UL
2201 There is room from 0x43000000UL to 0xB6000000UL, but let's keep some
2202 distance. */
2203 #define MAPPABLE_ADDRESS_RANGE_START 0x48000000UL
2204 #define MAPPABLE_ADDRESS_RANGE_END 0xAFFFFFFFUL
2205 #endif
2206 #if defined(UNIX_LINUX) && defined(HPPA)
2207 /* On Linux/hppa in qemu user-mode emulation:
2208 MMAP_FIXED_ADDRESS_HIGHEST_BIT = 30
2209 CODE_ADDRESS_RANGE = 0x00000000UL
2210 MALLOC_ADDRESS_RANGE = 0x00000000UL
2211 SHLIB_ADDRESS_RANGE = 0xF6000000UL
2212 STACK_ADDRESS_RANGE = 0xF6000000UL
2213 There is room from 0x00000000UL to 0xF6000000UL, but let's keep some
2214 distance. */
2215 #define MAPPABLE_ADDRESS_RANGE_START 0x08000000UL
2216 #define MAPPABLE_ADDRESS_RANGE_END 0xEFFFFFFFUL
2217 #endif
2218 #if defined(UNIX_LINUX) && defined(I80386)
2219 /* On Linux/i386:
2220 MMAP_FIXED_ADDRESS_HIGHEST_BIT = 30
2221 CODE_ADDRESS_RANGE = 0x00000000UL (Debian 9.1) or 0x08000000UL (Ubuntu 17.04)
2222 MALLOC_ADDRESS_RANGE = 0x01000000UL (Debian 9.1) or 0x08000000UL (Ubuntu 17.04)
2223 SHLIB_ADDRESS_RANGE = 0xB7000000UL
2224 STACK_ADDRESS_RANGE = 0xBF000000UL
2225 On Linux/x86_64 with 32-bit i386 ABI:
2226 MMAP_FIXED_ADDRESS_HIGHEST_BIT = 30
2227 CODE_ADDRESS_RANGE = 0x08000000UL
2228 MALLOC_ADDRESS_RANGE = 0x08000000UL ... 0x0A000000UL
2229 SHLIB_ADDRESS_RANGE = 0xF7000000UL
2230 STACK_ADDRESS_RANGE = 0xFF000000UL
2231 On some Linux/i386 Debian build machines:
2232 MMAP_FIXED_ADDRESS_HIGHEST_BIT = 30
2233 CODE_ADDRESS_RANGE = 0x56000000UL
2234 MALLOC_ADDRESS_RANGE = 0x56000000UL ... 0x58000000UL
2235 SHLIB_ADDRESS_RANGE = 0xF7000000UL
2236 STACK_ADDRESS_RANGE = 0xFF000000UL
2237 On Linux/i386 (Alpine 3.7):
2238 MMAP_FIXED_ADDRESS_HIGHEST_BIT = 30
2239 CODE_ADDRESS_RANGE = 0x10000000UL ... 0x1B000000UL
2240 MALLOC_ADDRESS_RANGE = 0x10000000UL ... 0x1B000000UL
2241 SHLIB_ADDRESS_RANGE = 0x48000000UL ... 0x57000000UL
2242 STACK_ADDRESS_RANGE = 0x58000000UL ... 0x5F000000UL
2243 Additionally, the ranges 0x70000000UL ... 0x78FFFFFFUL, 0xA8000000UL ... 0xB7FFFFFFUL
2244 are used, and addresses >= 0x60000000UL cannot be allocated.
2245 There is room from 0x1C000000UL to 0x48000000UL,
2246 but let's keep some distance. */
2247 /* Force the same CODE_ADDRESS_RANGE across platforms. */
2248 #if (CODE_ADDRESS_RANGE == 0x00000000UL || CODE_ADDRESS_RANGE == 0x08000000UL || (CODE_ADDRESS_RANGE >= 0x10000000UL && CODE_ADDRESS_RANGE < 0x1C000000UL) || CODE_ADDRESS_RANGE == 0x56000000UL)
2249 #undef CODE_ADDRESS_RANGE
2250 #define CODE_ADDRESS_RANGE 0x5F000000UL
2251 #endif
2252 #define MAPPABLE_ADDRESS_RANGE_START 0x1E000000UL
2253 #define MAPPABLE_ADDRESS_RANGE_END 0x45FFFFFFUL
2254 #endif
2255 #if defined(UNIX_LINUX) && defined(M68K)
2256 /* On Linux/m68k in qemu user-mode emulation:
2257 MMAP_FIXED_ADDRESS_HIGHEST_BIT = 30
2258 CODE_ADDRESS_RANGE = 0x80000000UL
2259 MALLOC_ADDRESS_RANGE = 0x80000000UL
2260 SHLIB_ADDRESS_RANGE = 0xF6000000UL
2261 STACK_ADDRESS_RANGE = 0xF6000000UL
2262 There is room from 0x00000000UL to 0x80000000UL, but let's keep some
2263 distance. */
2264 #define MAPPABLE_ADDRESS_RANGE_START 0x01000000UL
2265 #define MAPPABLE_ADDRESS_RANGE_END 0x7EFFFFFFUL
2266 #endif
2267 #if defined(UNIX_LINUX) && (defined(MIPS) || defined(MIPS64))
2268 #if !(_MIPS_SIM == _ABIN32)
2269 /* On Linux/mipseb and Linux/mipsel with o32 ABI:
2270 MMAP_FIXED_ADDRESS_HIGHEST_BIT = 30
2271 CODE_ADDRESS_RANGE = 0x00000000UL
2272 MALLOC_ADDRESS_RANGE = 0x00000000UL
2273 SHLIB_ADDRESS_RANGE = 0x77000000UL
2274 STACK_ADDRESS_RANGE = 0x7F000000UL
2275 On Linux/mips64eb with o32 ABI:
2276 MMAP_FIXED_ADDRESS_HIGHEST_BIT = 30
2277 CODE_ADDRESS_RANGE = 0x00000000UL
2278 MALLOC_ADDRESS_RANGE = 0x00000000UL
2279 SHLIB_ADDRESS_RANGE = 0x2B000000UL
2280 STACK_ADDRESS_RANGE = 0x7F000000UL
2281 On some Linux/mips Debian build machines:
2282 MMAP_FIXED_ADDRESS_HIGHEST_BIT = 30
2283 CODE_ADDRESS_RANGE = 0x55000000UL ... 0x56000000UL
2284 MALLOC_ADDRESS_RANGE = 0x55000000UL ... 0x56000000UL
2285 SHLIB_ADDRESS_RANGE = 0x77000000UL
2286 STACK_ADDRESS_RANGE = 0x7F000000UL
2287 There is room from 0x2C000000UL to 0x53000000UL
2288 and from 0x58000000UL to 0x76000000UL. */
2289 /* Force the same CODE_ADDRESS_RANGE across platforms. */
2290 #if (CODE_ADDRESS_RANGE == 0x00000000UL || (CODE_ADDRESS_RANGE >= 0x55000000UL && CODE_ADDRESS_RANGE < 0x57000000UL))
2291 #undef CODE_ADDRESS_RANGE
2292 #define CODE_ADDRESS_RANGE 0x57000000UL
2293 #endif
2294 #define MAPPABLE_ADDRESS_RANGE_START 0x2C000000UL
2295 #define MAPPABLE_ADDRESS_RANGE_END 0x52FFFFFFUL
2296 #else
2297 /* On Linux/mips64eb and Linux/mips64el with n32 ABI:
2298 MMAP_FIXED_ADDRESS_HIGHEST_BIT = 30
2299 CODE_ADDRESS_RANGE = 0x10000000UL
2300 MALLOC_ADDRESS_RANGE = 0x10000000UL
2301 SHLIB_ADDRESS_RANGE = 0x77000000UL or (sometimes) 0x2B000000UL
2302 STACK_ADDRESS_RANGE = 0x7F000000UL
2303 There is room from 0x11000000UL to 0x76000000UL. */
2304 #define MAPPABLE_ADDRESS_RANGE_START 0x2C000000UL
2305 #define MAPPABLE_ADDRESS_RANGE_END 0x75FFFFFFUL
2306 #endif
2307 #endif
2308 #if defined(UNIX_LINUX) && defined(POWERPC)
2309 /* On Linux/powerpc64 with 32-bit ABI:
2310 MMAP_FIXED_ADDRESS_HIGHEST_BIT = 30
2311 CODE_ADDRESS_RANGE = 0x10000000UL
2312 MALLOC_ADDRESS_RANGE = 0x10000000UL
2313 SHLIB_ADDRESS_RANGE = 0x0F000000UL
2314 STACK_ADDRESS_RANGE = 0xFF000000UL
2315 On some Linux/powerpc machines (Linux 4.6):
2316 MMAP_FIXED_ADDRESS_HIGHEST_BIT = 30
2317 CODE_ADDRESS_RANGE = 0x10000000UL
2318 MALLOC_ADDRESS_RANGE = 0x10000000UL
2319 SHLIB_ADDRESS_RANGE = 0x0F000000UL
2320 STACK_ADDRESS_RANGE = 0xBF000000UL
2321 On some Linux/powerpc build machines:
2322 MMAP_FIXED_ADDRESS_HIGHEST_BIT = 30
2323 CODE_ADDRESS_RANGE = 0x00000000UL
2324 MALLOC_ADDRESS_RANGE = 0x00000000UL
2325 SHLIB_ADDRESS_RANGE = 0x00000000UL
2326 STACK_ADDRESS_RANGE = 0xFF000000UL
2327 On some Linux/powerpc build machines:
2328 MMAP_FIXED_ADDRESS_HIGHEST_BIT = 30
2329 CODE_ADDRESS_RANGE = 0x20000000UL
2330 MALLOC_ADDRESS_RANGE = 0x20000000UL
2331 SHLIB_ADDRESS_RANGE = 0x20000000UL
2332 STACK_ADDRESS_RANGE = 0xFF000000UL
2333 There is room from 0x21000000UL to 0xB7000000UL, but let's keep some
2334 distance. */
2335 /* Force the same CODE_ADDRESS_RANGE across platforms. */
2336 #if (CODE_ADDRESS_RANGE == 0x00000000UL || CODE_ADDRESS_RANGE == 0x10000000UL || CODE_ADDRESS_RANGE == 0x20000000UL)
2337 #undef CODE_ADDRESS_RANGE
2338 #define CODE_ADDRESS_RANGE 0x30000000UL
2339 #endif
2340 #define MAPPABLE_ADDRESS_RANGE_START 0x30000000UL
2341 #define MAPPABLE_ADDRESS_RANGE_END 0xAFFFFFFFUL
2342 #endif
2343 #if defined(UNIX_LINUX) && defined(S390)
2344 /* On Linux/s390x with 32-bit ABI:
2345 MMAP_FIXED_ADDRESS_HIGHEST_BIT = 30
2346 CODE_ADDRESS_RANGE = 0x00000000UL
2347 MALLOC_ADDRESS_RANGE = 0x00000000UL
2348 SHLIB_ADDRESS_RANGE = 0x7C000000UL or 0x7D000000UL
2349 STACK_ADDRESS_RANGE = 0x7F000000UL
2350 There is room from 0x01000000UL to 0x7C000000UL, but let's keep some
2351 distance. */
2352 #define MAPPABLE_ADDRESS_RANGE_START 0x08000000UL
2353 #define MAPPABLE_ADDRESS_RANGE_END 0x6FFFFFFFUL
2354 #endif
2355 #if defined(UNIX_LINUX) && defined(SPARC)
2356 /* On Linux 3.2/sparc64 with 32-bit ABI:
2357 MMAP_FIXED_ADDRESS_HIGHEST_BIT = 30
2358 CODE_ADDRESS_RANGE = 0x00000000UL
2359 MALLOC_ADDRESS_RANGE = 0x00000000UL
2360 SHLIB_ADDRESS_RANGE = 0x70000000UL
2361 STACK_ADDRESS_RANGE = 0xFF000000UL
2362 On Linux 4.13/sparc64 with 32-bit ABI:
2363 MMAP_FIXED_ADDRESS_HIGHEST_BIT = 30
2364 CODE_ADDRESS_RANGE = 0x70000000UL
2365 MALLOC_ADDRESS_RANGE = 0x70000000UL
2366 SHLIB_ADDRESS_RANGE = 0xF7000000UL
2367 STACK_ADDRESS_RANGE = 0xFF000000UL
2368 There is room from 0x01000000UL to 0x70000000UL. */
2369 /* Force the same CODE_ADDRESS_RANGE across platforms. */
2370 #if (CODE_ADDRESS_RANGE == 0x00000000UL || CODE_ADDRESS_RANGE == 0x70000000UL)
2371 #undef CODE_ADDRESS_RANGE
2372 #define CODE_ADDRESS_RANGE 0x70000000UL
2373 #endif
2374 #define MAPPABLE_ADDRESS_RANGE_START 0x01000000UL
2375 #define MAPPABLE_ADDRESS_RANGE_END 0x6FFFFFFFUL
2376 #endif
2377 #if defined(UNIX_HURD) && defined(I80386)
2378 /* On Hurd/i386:
2379 MMAP_FIXED_ADDRESS_HIGHEST_BIT = 30
2380 CODE_ADDRESS_RANGE = 0x00000000UL or 0x08000000UL
2381 MALLOC_ADDRESS_RANGE = 0x08000000UL
2382 SHLIB_ADDRESS_RANGE = 0x01000000UL
2383 STACK_ADDRESS_RANGE = 0x01000000UL
2384 Addresses >= 0xC0000000UL are not mmapable.
2385 There is room from 0x11000000UL to 0xBFFFFFFFUL, but let's keep some
2386 distance. */
2387 #define MAPPABLE_ADDRESS_RANGE_START 0x18000000UL
2388 #define MAPPABLE_ADDRESS_RANGE_END 0xBFFFFFFFUL
2389 #endif
2390 #if (defined(__FreeBSD__) || defined(UNIX_GNU_FREEBSD)) && defined(I80386)
2391 /* On FreeBSD/i386:
2392 MMAP_FIXED_ADDRESS_HIGHEST_BIT = 30
2393 CODE_ADDRESS_RANGE = 0x08000000UL
2394 MALLOC_ADDRESS_RANGE = 0x28000000UL
2395 SHLIB_ADDRESS_RANGE = 0x28000000UL
2396 STACK_ADDRESS_RANGE = 0xBF000000UL
2397 On GNU/kFreeBSD/i386:
2398 MMAP_FIXED_ADDRESS_HIGHEST_BIT = 30
2399 CODE_ADDRESS_RANGE = 0x08000000UL
2400 MALLOC_ADDRESS_RANGE = 0x08000000UL
2401 SHLIB_ADDRESS_RANGE = 0x28000000UL
2402 STACK_ADDRESS_RANGE = 0xBF000000UL
2403 There is room from 0x29000000UL to 0xBF000000UL, but let's keep some
2404 distance. */
2405 #define MAPPABLE_ADDRESS_RANGE_START 0x30000000UL
2406 #define MAPPABLE_ADDRESS_RANGE_END 0xB7FFFFFFUL
2407 #endif
2408 #if defined(__DragonFly__) && defined(I80386)
2409 /* On DragonFly/i386:
2410 MMAP_FIXED_ADDRESS_HIGHEST_BIT = 30
2411 CODE_ADDRESS_RANGE = 0x08000000UL
2412 MALLOC_ADDRESS_RANGE = 0x28000000UL
2413 SHLIB_ADDRESS_RANGE = 0x28000000UL
2414 STACK_ADDRESS_RANGE = 0x9F000000UL
2415 There is room from 0x29000000UL to 0x9F000000UL, but let's keep some
2416 distance. */
2417 #define MAPPABLE_ADDRESS_RANGE_START 0x30000000UL
2418 #define MAPPABLE_ADDRESS_RANGE_END 0x97FFFFFFUL
2419 #endif
2420 #if defined(UNIX_NETBSD) && defined(I80386)
2421 /* On NetBSD/i386:
2422 MMAP_FIXED_ADDRESS_HIGHEST_BIT = 30
2423 CODE_ADDRESS_RANGE = 0x08000000UL
2424 MALLOC_ADDRESS_RANGE = 0xBB000000UL
2425 SHLIB_ADDRESS_RANGE = 0xBB000000UL
2426 STACK_ADDRESS_RANGE = 0xBF000000UL
2427 There is room from 0x09000000UL to 0xBB000000UL, but let's keep some
2428 distance. */
2429 #define MAPPABLE_ADDRESS_RANGE_START 0x10000000UL
2430 #define MAPPABLE_ADDRESS_RANGE_END 0xAFFFFFFFUL
2431 #endif
2432 #if defined(UNIX_NETBSD) && defined(SPARC)
2433 /* On NetBSD/sparc:
2434 MMAP_FIXED_ADDRESS_HIGHEST_BIT = 30
2435 CODE_ADDRESS_RANGE = 0x00000000UL
2436 MALLOC_ADDRESS_RANGE = 0xED000000UL
2437 SHLIB_ADDRESS_RANGE = 0xED000000UL
2438 STACK_ADDRESS_RANGE = 0xEF000000UL
2439 On NetBSD/sparc64 with 32-bit ABI:
2440 CODE_ADDRESS_RANGE = 0x00000000UL
2441 MALLOC_ADDRESS_RANGE = 0x20000000UL ... 0x30000000UL
2442 SHLIB_ADDRESS_RANGE = 0x20000000UL ... 0x40000000UL
2443 STACK_ADDRESS_RANGE = 0xFF000000UL
2444 There is room from 0x41000000UL to 0xED000000UL, but let's keep some
2445 distance. */
2446 #define MAPPABLE_ADDRESS_RANGE_START 0x48000000UL
2447 #define MAPPABLE_ADDRESS_RANGE_END 0xDFFFFFFFUL
2448 #endif
2449 #if defined(UNIX_OPENBSD) && defined(I80386)
2450 /* On OpenBSD/i386:
2451 MMAP_FIXED_ADDRESS_HIGHEST_BIT = 30
2452 CODE_ADDRESS_RANGE varies from 0x14000000UL to 0x1B000000UL
2453 MALLOC_ADDRESS_RANGE varies from 0x74000000UL..0x84000000UL to 0x7A000000UL..0x8A000000UL
2454 SHLIB_ADDRESS_RANGE varies from 0x21000000UL to 0x2F000000UL
2455 STACK_ADDRESS_RANGE = 0xCF000000UL
2456 The allocated ranges are randomized across the ranges
2457 from 0x00000000UL to 0x0FFFFFFFUL,
2458 from 0x14000000UL to 0x1BFFFFFFUL,
2459 from 0x20000000UL to 0x2FFFFFFFUL,
2460 from 0x34000000UL to 0x3BFFFFFFUL,
2461 from 0x74000000UL to 0x8BFFFFFFUL,
2462 from 0xCD000000UL to 0xCDFFFFFFUL,
2463 from 0xCF000000UL to 0xCFFFFFFFUL.
2464 There is room from 0x3C000000UL to 0x74000000UL
2465 and from 0x8C000000UL to 0xCD000000UL, but let's keep some
2466 distance. */
2467 /* Force the same CODE_ADDRESS_RANGE across platforms. */
2468 #if (CODE_ADDRESS_RANGE >= 0x14000000UL || CODE_ADDRESS_RANGE <= 0x1B000000UL)
2469 #undef CODE_ADDRESS_RANGE
2470 #define CODE_ADDRESS_RANGE 0x1B000000UL
2471 #endif
2472 #define MAPPABLE_ADDRESS_RANGE_START 0x40000000UL
2473 #define MAPPABLE_ADDRESS_RANGE_END 0x6FFFFFFFUL
2474 #endif
2475 #if defined(UNIX_MACOSX) && defined(I80386)
2476 /* On Mac OS X 10.5.8/x86_64 with 32-bit ABI:
2477 MMAP_FIXED_ADDRESS_HIGHEST_BIT = 30
2478 CODE_ADDRESS_RANGE = 0x00000000UL
2479 MALLOC_ADDRESS_RANGE = 0x00000000UL
2480 SHLIB_ADDRESS_RANGE = 0x8F000000UL ... 0xA0000000UL
2481 STACK_ADDRESS_RANGE = 0xB0000000UL ... 0xBF000000UL
2482 There is room from 0x02000000UL to 0x8F000000UL, but let's keep some
2483 distance. */
2484 #define MAPPABLE_ADDRESS_RANGE_START 0x10000000UL
2485 #define MAPPABLE_ADDRESS_RANGE_END 0x87FFFFFFUL
2486 #endif
2487 #if defined(UNIX_MACOSX) && defined(POWERPC)
2488 /* On Mac OS X 10.5.8/PowerPC and
2489 on Mac OS X 10.5.8/x86_64 with CC="gcc -arch ppc":
2490 MMAP_FIXED_ADDRESS_HIGHEST_BIT = 30
2491 CODE_ADDRESS_RANGE = 0x00000000UL
2492 MALLOC_ADDRESS_RANGE = 0x00000000UL and 0x01000000UL
2493 SHLIB_ADDRESS_RANGE = 0x8F000000UL ... 0xA0000000UL
2494 STACK_ADDRESS_RANGE = 0xBC000000UL ... 0xBF000000UL
2495 There is room from 0x02000000UL to 0x80000000UL, but let's keep some
2496 distance. */
2497 #define MAPPABLE_ADDRESS_RANGE_START 0x10000000UL
2498 #define MAPPABLE_ADDRESS_RANGE_END 0x7FFFFFFFUL
2499 #endif
2500 #if defined(UNIX_AIX) && defined(POWERPC)
2501 /* On AIX/POWER with 32-bit ABI:
2502 CODE_ADDRESS_RANGE = 0x10000000UL (r-x) and 0x20000000UL (rw-)
2503 MALLOC_ADDRESS_RANGE = 0x20000000UL or 0x30000000UL
2504 SHLIB_ADDRESS_RANGE = 0xD0000000UL (r-x) and 0xF0000000UL (rw-)
2505 STACK_ADDRESS_RANGE = 0x2F000000UL
2506 See also "The 32-bit AIX Virtual Memory Model"
2507 <https://www.ibm.com/support/knowledgecenter/en/SSYKE2_8.0.0/com.ibm.java.aix.80.doc/diag/problem_determination/aix_mem_32.html>.
2508 There is room from 0x40000000UL to 0xD0000000UL. */
2509 /* Force the same CODE_ADDRESS_RANGE across platforms. */
2510 #if (CODE_ADDRESS_RANGE == 0x10000000UL || CODE_ADDRESS_RANGE == 0x20000000UL)
2511 #undef CODE_ADDRESS_RANGE
2512 #define CODE_ADDRESS_RANGE 0x30000000UL
2513 #endif
2514 #define MAPPABLE_ADDRESS_RANGE_START 0x40000000UL
2515 #define MAPPABLE_ADDRESS_RANGE_END 0xCFFFFFFFUL
2516 #endif
2517 #if defined(UNIX_HPUX) && defined(HPPA)
2518 /* On HP-UX/hppa with 32-bit ABI:
2519 CODE_ADDRESS_RANGE = 0x40000000UL
2520 MALLOC_ADDRESS_RANGE = 0x40000000UL
2521 SHLIB_ADDRESS_RANGE = 0x6F000000UL
2522 STACK_ADDRESS_RANGE = 0x6F000000UL
2523 There is room from 0x70000000UL to 0xC0000000UL
2524 and also from 0x01000000UL to 0x40000000UL. */
2525 #define MAPPABLE_ADDRESS_RANGE_START 0x70000000UL
2526 #define MAPPABLE_ADDRESS_RANGE_END 0xBFFFFFFFUL
2527 #endif
2528 #if defined(UNIX_HPUX) && defined(IA64)
2529 /* On HP-UX/ia64 with 32-bit ABI:
2530 CODE_ADDRESS_RANGE = 0x77000000UL
2531 MALLOC_ADDRESS_RANGE = 0x40000000UL
2532 SHLIB_ADDRESS_RANGE = 0x77000000UL
2533 STACK_ADDRESS_RANGE = 0x7F000000UL
2534 There is room from 0x05000000UL to 0x40000000UL
2535 and also from 0x41000000UL to 0x77000000UL
2536 and also from 0x80000000UL to 0xC0000000UL. */
2537 #define MAPPABLE_ADDRESS_RANGE_START 0x80000000UL
2538 #define MAPPABLE_ADDRESS_RANGE_END 0xBFFFFFFFUL
2539 #endif
2540 #if defined(UNIX_IRIX) && (defined(MIPS) || defined(MIPS64))
2541 #if !(_MIPS_SIM == _ABIN32)
2542 /* On IRIX 6.5 with o32 ABI:
2543 MMAP_FIXED_ADDRESS_HIGHEST_BIT = 30
2544 CODE_ADDRESS_RANGE = 0x00000000UL
2545 MALLOC_ADDRESS_RANGE = 0x10000000UL
2546 SHLIB_ADDRESS_RANGE = 0x0F000000UL
2547 STACK_ADDRESS_RANGE = 0x7F000000UL
2548 There is room from 0x11000000UL to 0x5E800000UL. */
2549 #define MAPPABLE_ADDRESS_RANGE_START 0x11000000UL
2550 #define MAPPABLE_ADDRESS_RANGE_END 0x5E7FFFFFUL
2551 #else
2552 /* On IRIX 6.5 with n32 ABI:
2553 MMAP_FIXED_ADDRESS_HIGHEST_BIT = 30
2554 CODE_ADDRESS_RANGE = 0x10000000UL
2555 MALLOC_ADDRESS_RANGE = 0x10000000UL
2556 SHLIB_ADDRESS_RANGE = 0x0F000000UL
2557 STACK_ADDRESS_RANGE = 0x7F000000UL
2558 There is room from 0x11000000UL to 0x5E800000UL. */
2559 #define MAPPABLE_ADDRESS_RANGE_START 0x11000000UL
2560 #define MAPPABLE_ADDRESS_RANGE_END 0x5E7FFFFFUL
2561 #endif
2562 #endif
2563 #if defined(UNIX_SUNOS5) && defined(I80386)
2564 /* On Solaris 10/x86_64 with 32-bit ABI:
2565 MMAP_FIXED_ADDRESS_HIGHEST_BIT = 30
2566 CODE_ADDRESS_RANGE = 0x08000000UL
2567 MALLOC_ADDRESS_RANGE = 0x08000000UL
2568 SHLIB_ADDRESS_RANGE = 0xFE000000UL
2569 STACK_ADDRESS_RANGE = 0x08000000UL
2570 On Solaris 11/x86_64 with 32-bit ABI:
2571 MMAP_FIXED_ADDRESS_HIGHEST_BIT = 30
2572 CODE_ADDRESS_RANGE = 0x08000000UL
2573 MALLOC_ADDRESS_RANGE = 0x08000000UL
2574 SHLIB_ADDRESS_RANGE = 0xFE000000UL
2575 STACK_ADDRESS_RANGE = 0xFE000000UL
2576 There is room from 0x09000000UL to 0xFE000000UL, but let's keep some
2577 distance. */
2578 #define MAPPABLE_ADDRESS_RANGE_START 0x10000000UL
2579 #define MAPPABLE_ADDRESS_RANGE_END 0xEFFFFFFFUL
2580 #endif
2581 #if defined(UNIX_SUNOS5) && defined(SPARC)
2582 /* On Solaris 10/sparc64 with 32-bit ABI:
2583 MMAP_FIXED_ADDRESS_HIGHEST_BIT = 30
2584 CODE_ADDRESS_RANGE = 0x00000000UL
2585 MALLOC_ADDRESS_RANGE = 0x00000000UL
2586 SHLIB_ADDRESS_RANGE = 0xFF000000UL
2587 STACK_ADDRESS_RANGE = 0xFF000000UL
2588 There is room from 0x01000000UL to 0xFE000000UL, but let's keep some
2589 distance. */
2590 #define MAPPABLE_ADDRESS_RANGE_START 0x10000000UL
2591 #define MAPPABLE_ADDRESS_RANGE_END 0xEFFFFFFFUL
2592 #endif
2593 #if defined(UNIX_HAIKU) && defined(I80386)
2594 /* On Haiku/i386:
2595 MMAP_FIXED_ADDRESS_HIGHEST_BIT = 30
2596 CODE_ADDRESS_RANGE = 0x00000000UL ... 0x02000000UL
2597 MALLOC_ADDRESS_RANGE = 0x18000000UL ... 0x19000000UL
2598 SHLIB_ADDRESS_RANGE = 0x00000000UL ... 0x02000000UL
2599 STACK_ADDRESS_RANGE = 0x70000000UL ... 0x73000000UL
2600 There is room from 0x1A000000UL to 0x60000000UL, but let's keep some
2601 distance. */
2602 /* Force the same CODE_ADDRESS_RANGE across platforms. */
2603 #if (CODE_ADDRESS_RANGE == 0x00000000UL || CODE_ADDRESS_RANGE == 0x01000000UL || CODE_ADDRESS_RANGE == 0x02000000UL)
2604 #undef CODE_ADDRESS_RANGE
2605 #define CODE_ADDRESS_RANGE 0x03000000UL
2606 #endif
2607 #define MAPPABLE_ADDRESS_RANGE_START 0x20000000UL
2608 #define MAPPABLE_ADDRESS_RANGE_END 0x5FFFFFFFUL
2609 #endif
2610 #if defined(UNIX_MINIX) && defined(I80386)
2611 /* On Minix/i386:
2612 MMAP_FIXED_ADDRESS_HIGHEST_BIT = 30
2613 CODE_ADDRESS_RANGE = 0x08000000UL
2614 MALLOC_ADDRESS_RANGE = 0x08000000UL
2615 SHLIB_ADDRESS_RANGE = 0x08000000UL
2616 STACK_ADDRESS_RANGE = 0xEF000000UL
2617 There is room from 0x09000000UL to 0xEF000000UL, but let's keep some
2618 distance. */
2619 #define MAPPABLE_ADDRESS_RANGE_START 0x10000000UL
2620 #define MAPPABLE_ADDRESS_RANGE_END 0xDFFFFFFFUL
2621 #endif
2622 #if defined(UNIX_CYGWIN) && defined(I80386)
2623 /* On Cygwin, running on Windows 10 (64-bit):
2624 CODE_ADDRESS_RANGE = 0x00000000UL
2625 MALLOC_ADDRESS_RANGE = 0x20000000UL
2626 SHLIB_ADDRESS_RANGE = 0x00000000UL
2627 STACK_ADDRESS_RANGE = 0x00000000UL
2628 There is room from 0x21000000UL to 0x5D000000UL
2629 (from which addresses < 0x38000000UL cannot be allocated)
2630 and from 0x80000000UL to 0xFF000000UL. */
2631 #if 0 /* both are possible */
2632 #define MAPPABLE_ADDRESS_RANGE_START 0x38000000UL
2633 #define MAPPABLE_ADDRESS_RANGE_END 0x57FFFFFFUL
2634 #else
2635 #define MAPPABLE_ADDRESS_RANGE_START 0x80000000UL
2636 #define MAPPABLE_ADDRESS_RANGE_END 0xFEFFFFFFUL
2637 #endif
2638 #endif
2639 #if defined(WIN32_NATIVE) && defined(I80386)
2640 /* On mingw, running on Windows 10 (64-bit):
2641 CODE_ADDRESS_RANGE = 0x00000000UL
2642 MALLOC_ADDRESS_RANGE = 0x00000000UL
2643 SHLIB_ADDRESS_RANGE = 0x00000000UL
2644 STACK_ADDRESS_RANGE = 0x00000000UL
2645 Addresses >= 0x80000000UL are not mmapable.
2646 There is room from 0x03000000UL to 0x57000000UL. */
2647 #define MAPPABLE_ADDRESS_RANGE_START 0x03000000UL
2648 #define MAPPABLE_ADDRESS_RANGE_END 0x4FFFFFFFUL
2649 #endif
2650 #else
2651 /* 64-bit platforms */
2652 #if defined(UNIX_LINUX) && defined(AMD64)
2653 /* On Linux/x86_64:
2654 MMAP_FIXED_ADDRESS_HIGHEST_BIT = 46
2655 CODE_ADDRESS_RANGE = 0x0000000000000000UL or 0x000055xxxx000000UL or 0x000056xxxx000000UL (in Linux 4.13)
2656 MALLOC_ADDRESS_RANGE = 0x000000000x000000UL or 0x000055xxxx000000UL (in Linux 4.13)
2657 SHLIB_ADDRESS_RANGE = 0x00000034F5000000UL or 0x0000003844000000UL or 0x00007Fxxxx000000UL
2658 or 0x0000002Axx000000UL or 0x0000002Bxx000000UL (in Linux 3.2, when invoked by 'make')
2659 or 0x00007Fxxxx000000UL (in WSL)
2660 STACK_ADDRESS_RANGE = 0x0000007FBF000000UL or 0x00007FFDxx000000UL or 0x00007FFEBF000000UL or 0x00007FFECF000000UL
2661 On Linux/x86_64 (Alpine 3.7):
2662 MMAP_FIXED_ADDRESS_HIGHEST_BIT = 46
2663 CODE_ADDRESS_RANGE = 0x000000xxxx000000UL ... 0x00000Fxxxx000000UL
2664 MALLOC_ADDRESS_RANGE = 0x000000xxxx000000UL ... 0x00000Fxxxx000000UL
2665 SHLIB_ADDRESS_RANGE = 0x000060xxxx000000UL ... 0x00007Fxxxx000000UL
2666 STACK_ADDRESS_RANGE = 0x000070xxxx000000UL ... 0x00007Fxxxx000000UL
2667 There is room from 0x100000000000UL to 0x2A0000000000UL
2668 and from 0x400000000000UL to 0x540000000000UL
2669 and from 0x580000000000UL to 0x600000000000UL. */
2670 /* Force the same CODE_ADDRESS_RANGE across platforms. */
2671 #if ((CODE_ADDRESS_RANGE >= 0x0000000000000000UL && CODE_ADDRESS_RANGE < 0x0000100000000000UL) || (CODE_ADDRESS_RANGE >= 0x0000550000000000UL && CODE_ADDRESS_RANGE < 0x0000570000000000UL))
2672 #undef CODE_ADDRESS_RANGE
2673 #define CODE_ADDRESS_RANGE 0x00005FFF00000000UL
2674 #endif
2675 #define MAPPABLE_ADDRESS_RANGE_START 0x100000000000UL
2676 #define MAPPABLE_ADDRESS_RANGE_END 0x1FFFFFFFFFFFUL
2677 #endif
2678 #if defined(UNIX_LINUX) && defined(ARM64)
2679 /* On Linux/arm64:
2680 MMAP_FIXED_ADDRESS_HIGHEST_BIT = 38
2681 CODE_ADDRESS_RANGE = 0x0000000000000000UL
2682 MALLOC_ADDRESS_RANGE = 0x0000000009000000UL or 0x000000000E000000UL or 0x000000001E000000UL or 0x0000000021000000UL
2683 SHLIB_ADDRESS_RANGE = 0x0000002000000000UL or 0x0000007F82000000UL
2684 STACK_ADDRESS_RANGE = 0x0000007FC8000000UL or 0x0000007F7A000000UL or 0x0000007FF0000000UL or 0x0000007FFC000000UL
2685 On Linux/arm64 build.opensuse.org or Debian build machines:
2686 MMAP_FIXED_ADDRESS_HIGHEST_BIT = 47
2687 CODE_ADDRESS_RANGE = 0x0000000000000000UL or 0x0000AAAAxx000000UL
2688 MALLOC_ADDRESS_RANGE = 0x0000000000000000UL or 0x0000AAAAxx000000UL
2689 SHLIB_ADDRESS_RANGE = 0x0000400000000000UL or 0x0000FFFFxx000000UL
2690 STACK_ADDRESS_RANGE = 0x0000FFFFFF000000UL or 0x0000FFFFxx000000UL
2691 There is room from 0x002100000000UL to 0x007F00000000UL. */
2692 /* Force the same CODE_ADDRESS_RANGE across platforms. */
2693 #if (CODE_ADDRESS_RANGE == 0x0000000000000000UL || (CODE_ADDRESS_RANGE >= 0x0000AAAA00000000UL && CODE_ADDRESS_RANGE < 0x0000AAAB00000000UL))
2694 #undef CODE_ADDRESS_RANGE
2695 #define CODE_ADDRESS_RANGE 0x0000AAAAFF000000UL
2696 #endif
2697 #define MAPPABLE_ADDRESS_RANGE_START 0x002100000000UL
2698 #define MAPPABLE_ADDRESS_RANGE_END 0x007EFFFFFFFFUL
2699 #endif
2700 #if defined(UNIX_LINUX) && defined(DECALPHA)
2701 /* On Linux/alpha:
2702 Virtual address limit: 0x0000040000000000UL
2703 CODE_ADDRESS_RANGE = 0x0000000120000000UL
2704 MALLOC_ADDRESS_RANGE = 0x0000000120000000UL or 0x0000015555000000UL
2705 SHLIB_ADDRESS_RANGE = 0x0000015555000000UL or 0x0000020000000000UL
2706 STACK_ADDRESS_RANGE = 0x000000011F000000UL
2707 There is room from 0x000200000000UL to 0x015000000000UL. */
2708 #define MAPPABLE_ADDRESS_RANGE_START 0x000200000000UL
2709 #define MAPPABLE_ADDRESS_RANGE_END 0x014FFFFFFFFFUL
2710 #endif
2711 #if defined(UNIX_LINUX) && defined(IA64)
2712 /* On Linux/ia64:
2713 Bits 63..61 = region code,
2714 Bits 60..39 all zero or all one,
2715 Virtual address limit: R*2^61..R*2^61+2^39, (R+1)*2^61-2^39..(R+1)*2^61.
2716 CODE_ADDRESS_RANGE = 0x4000000000000000UL
2717 MALLOC_ADDRESS_RANGE = 0x6000000000000000UL
2718 SHLIB_ADDRESS_RANGE = 0x2000000000000000UL
2719 STACK_ADDRESS_RANGE = 0x60000FFFFF000000UL or 0x9FFFFFFFFF000000UL
2720 A vdso at 0xA000000000000000UL
2721 There is room from 0x6000000100000000UL to 0x600007FF00000000UL. */
2722 #define MAPPABLE_ADDRESS_RANGE_START 0x6000000100000000UL
2723 #define MAPPABLE_ADDRESS_RANGE_END 0x600007FEFFFFFFFFUL
2724 #endif
2725 #if defined(UNIX_LINUX) && defined(MIPS64)
2726 /* On Linux/mips64eb and Linux/mips64el with 64-bit ABI:
2727 MMAP_FIXED_ADDRESS_HIGHEST_BIT = 39
2728 CODE_ADDRESS_RANGE = 0x0000000120000000UL
2729 MALLOC_ADDRESS_RANGE = 0x000000012x000000UL
2730 SHLIB_ADDRESS_RANGE = 0x000000555F000000UL or 0x000000FFEF000000UL..0x000000FFF2000000UL
2731 STACK_ADDRESS_RANGE = 0x000000FFFF000000UL
2732 On some Linux/mips64 Debian build machines:
2733 MMAP_FIXED_ADDRESS_HIGHEST_BIT = 39
2734 CODE_ADDRESS_RANGE = 0x000000AABx000000UL
2735 MALLOC_ADDRESS_RANGE = 0x000000AABx000000UL
2736 SHLIB_ADDRESS_RANGE = 0x000000FFFx000000UL
2737 STACK_ADDRESS_RANGE = 0x000000FFFF000000UL
2738 There is room from 0x005600000000UL to 0x00AA00000000UL. */
2739 /* Force the same CODE_ADDRESS_RANGE across platforms. */
2740 #if (CODE_ADDRESS_RANGE == 0x0000000000000000UL || (CODE_ADDRESS_RANGE >= 0x000000AA00000000UL && CODE_ADDRESS_RANGE < 0x000000AB00000000UL))
2741 #undef CODE_ADDRESS_RANGE
2742 #define CODE_ADDRESS_RANGE 0x000000AAFF000000UL
2743 #endif
2744 #define MAPPABLE_ADDRESS_RANGE_START 0x005600000000UL
2745 #define MAPPABLE_ADDRESS_RANGE_END 0x00A9FFFFFFFFUL
2746 #endif
2747 #if defined(UNIX_LINUX) && defined(POWERPC64)
2748 /* On Linux/powerpc64 and Linux/powerpc64le:
2749 MMAP_FIXED_ADDRESS_HIGHEST_BIT = 45
2750 CODE_ADDRESS_RANGE = 0x0000000010000000UL or 0x0000000102000000UL or 0x0000000124000000UL
2751 MALLOC_ADDRESS_RANGE = 0x00000100xx000000UL
2752 SHLIB_ADDRESS_RANGE = 0x00003FFF79000000UL ... 0x00003FFFA0000000UL
2753 STACK_ADDRESS_RANGE = 0x00003FFFD1000000UL ... 0x00003FFFFF000000UL
2754 On some Linux/powerpc64 Debian build machines:
2755 MMAP_FIXED_ADDRESS_HIGHEST_BIT = 48
2756 CODE_ADDRESS_RANGE = 0x000000012x000000UL
2757 MALLOC_ADDRESS_RANGE = 0x00000100xx000000UL
2758 SHLIB_ADDRESS_RANGE = 0x00007FFF82000000UL ... 0x00007FFFA4000000UL
2759 STACK_ADDRESS_RANGE = 0x00007FFFD6000000UL ... 0x00007FFFE5000000UL
2760 There is room from 0x011000000000UL to 0x3FF000000000UL. */
2761 /* Force the same CODE_ADDRESS_RANGE across platforms. */
2762 #if (CODE_ADDRESS_RANGE < 0x0000000200000000UL)
2763 #undef CODE_ADDRESS_RANGE
2764 #define CODE_ADDRESS_RANGE 0x00000001FF000000UL
2765 #endif
2766 #define MAPPABLE_ADDRESS_RANGE_START 0x011000000000UL
2767 #define MAPPABLE_ADDRESS_RANGE_END 0x3FEFFFFFFFFFUL
2768 #endif
2769 #if defined(UNIX_LINUX) && defined(RISCV64)
2770 /* On Linux/riscv64:
2771 MMAP_FIXED_ADDRESS_HIGHEST_BIT = 37
2772 CODE_ADDRESS_RANGE = 0x0000000000000000UL
2773 MALLOC_ADDRESS_RANGE = 0x0000000000000000UL
2774 SHLIB_ADDRESS_RANGE = 0x0000002000000000UL
2775 STACK_ADDRESS_RANGE = 0x0000003FFF000000UL
2776 There is room from 0x000080000000UL to 0x002000000000UL. */
2777 #define MAPPABLE_ADDRESS_RANGE_START 0x000080000000UL
2778 #define MAPPABLE_ADDRESS_RANGE_END 0x001FFFFFFFFFUL
2779 #endif
2780 #if defined(UNIX_LINUX) && defined(S390_64)
2781 /* On Linux/s390x:
2782 MMAP_FIXED_ADDRESS_HIGHEST_BIT = 52
2783 CODE_ADDRESS_RANGE = 0x0000000080000000UL or 0x0000000106000000UL or 0x0000000119000000UL
2784 MALLOC_ADDRESS_RANGE = 0x0000000081000000UL ... 0x00000000BE000000UL or 0x000000012x000000UL
2785 SHLIB_ADDRESS_RANGE = 0x000003FF81000000UL ... 0x000003FFFD000000UL
2786 STACK_ADDRESS_RANGE = 0x000003FFC2000000UL ... 0x000003FFFF000000UL
2787 On Linux/s390x build.opensuse.org machines:
2788 MMAP_FIXED_ADDRESS_HIGHEST_BIT = 62
2789 CODE_ADDRESS_RANGE = 0x0000000001000000UL
2790 MALLOC_ADDRESS_RANGE = 0x0000000001000000UL
2791 SHLIB_ADDRESS_RANGE = 0x0000020000000000UL
2792 STACK_ADDRESS_RANGE = 0x000003FFFF000000UL
2793 There is room from 0x000200000000UL to 0x020000000000UL. */
2794 /* Force the same CODE_ADDRESS_RANGE across platforms. */
2795 #if (CODE_ADDRESS_RANGE < 0x0000000200000000UL)
2796 #undef CODE_ADDRESS_RANGE
2797 #define CODE_ADDRESS_RANGE 0x00000001FF000000UL
2798 #endif
2799 #define MAPPABLE_ADDRESS_RANGE_START 0x000200000000UL
2800 #define MAPPABLE_ADDRESS_RANGE_END 0x01FFFFFFFFFFUL
2801 #endif
2802 #if defined(UNIX_LINUX) && defined(SPARC64)
2803 /* On Linux 3.2/sparc64:
2804 MMAP_FIXED_ADDRESS_HIGHEST_BIT = 42
2805 CODE_ADDRESS_RANGE = 0x0000000000000000UL or 0x0000010000000000UL
2806 MALLOC_ADDRESS_RANGE = 0x0000000000000000UL or 0x0000010000000000UL
2807 SHLIB_ADDRESS_RANGE = 0xFFFFF80100000000UL
2808 STACK_ADDRESS_RANGE = 0x000007FEFF000000UL
2809 One some Linux/sparc64 Debian build machines:
2810 MMAP_FIXED_ADDRESS_HIGHEST_BIT = 46
2811 CODE_ADDRESS_RANGE = 0x0000010000000000UL
2812 MALLOC_ADDRESS_RANGE = 0x0000010000000000UL
2813 SHLIB_ADDRESS_RANGE = 0xFFFF800100000000UL
2814 STACK_ADDRESS_RANGE = 0x000007FEFF000000UL
2815 On Linux 4.13/sparc64:
2816 MMAP_FIXED_ADDRESS_HIGHEST_BIT = 50
2817 CODE_ADDRESS_RANGE = 0x0000010000000000UL
2818 MALLOC_ADDRESS_RANGE = 0x0000010000000000UL
2819 SHLIB_ADDRESS_RANGE = 0xFFF8000100000000UL
2820 STACK_ADDRESS_RANGE = 0x000007FEFF000000UL
2821 There is room from 0x0000018000000000UL to 0x000007FE00000000UL. */
2822 /* Force the same CODE_ADDRESS_RANGE across platforms. */
2823 #if (CODE_ADDRESS_RANGE == 0x0000000000000000UL || CODE_ADDRESS_RANGE == 0x0000010000000000UL)
2824 #undef CODE_ADDRESS_RANGE
2825 #define CODE_ADDRESS_RANGE 0x0000010000000000UL
2826 #endif
2827 #define MAPPABLE_ADDRESS_RANGE_START 0x0000018000000000UL
2828 #define MAPPABLE_ADDRESS_RANGE_END 0x000007FDFFFFFFFFUL
2829 #endif
2830 #if (defined(UNIX_FREEBSD) || defined(UNIX_GNU_FREEBSD)) && defined(AMD64)
2831 /* On FreeBSD/x86_64:
2832 MMAP_FIXED_ADDRESS_HIGHEST_BIT = 46
2833 CODE_ADDRESS_RANGE = 0x0000000000000000UL
2834 MALLOC_ADDRESS_RANGE = 0x0000000000000000UL or 0x0000000801000000UL
2835 SHLIB_ADDRESS_RANGE = 0x0000000800000000UL
2836 STACK_ADDRESS_RANGE = 0x00007FFFFF000000UL
2837 On GNU/kFreeBSD/x86_64:
2838 CODE_ADDRESS_RANGE = 0x0000000000000000UL
2839 MALLOC_ADDRESS_RANGE = 0x0000000000000000UL
2840 SHLIB_ADDRESS_RANGE = 0x0000000800000000UL
2841 STACK_ADDRESS_RANGE = 0x00007FFFFF000000UL
2842 There is room from 0x000900000000UL to 0x7FFF00000000UL. */
2843 #define MAPPABLE_ADDRESS_RANGE_START 0x000900000000UL
2844 #define MAPPABLE_ADDRESS_RANGE_END 0x7FFEFFFFFFFFUL
2845 #endif
2846 #if defined(UNIX_FREEBSD) && defined(ARM64)
2847 /* On FreeBSD/arm64:
2848 MMAP_FIXED_ADDRESS_HIGHEST_BIT = 47
2849 CODE_ADDRESS_RANGE = 0x0000000000000000UL
2850 MALLOC_ADDRESS_RANGE = 0x0000000040000000UL
2851 SHLIB_ADDRESS_RANGE = 0x0000000040000000UL
2852 STACK_ADDRESS_RANGE = 0x0000FFFFFF000000UL
2853 There is room from 0x000100000000UL to 0xFFFF00000000UL. */
2854 #define MAPPABLE_ADDRESS_RANGE_START 0x000100000000UL
2855 #define MAPPABLE_ADDRESS_RANGE_END 0xFFFEFFFFFFFFUL
2856 #endif
2857 #if defined(UNIX_FREEBSD) && defined(DECALPHA)
2858 /* On FreeBSD/alpha:
2859 CODE_ADDRESS_RANGE = 0x0000000120000000UL
2860 MALLOC_ADDRESS_RANGE = 0x0000000120000000UL
2861 SHLIB_ADDRESS_RANGE = 0x0000000160000000UL
2862 STACK_ADDRESS_RANGE = 0x0000000011000000UL
2863 There is room from 0x000200000000UL to 0x03FF00000000UL. */
2864 #define MAPPABLE_ADDRESS_RANGE_START 0x000200000000UL
2865 #define MAPPABLE_ADDRESS_RANGE_END 0x03FF00000000UL
2866 #endif
2867 #if defined(UNIX_NETBSD) && defined(AMD64)
2868 /* On NetBSD/x86_64:
2869 MMAP_FIXED_ADDRESS_HIGHEST_BIT = 46
2870 CODE_ADDRESS_RANGE = 0x0000000000000000UL
2871 MALLOC_ADDRESS_RANGE = 0x00007F7FF7000000UL
2872 SHLIB_ADDRESS_RANGE = 0x00007F7FF7000000UL
2873 STACK_ADDRESS_RANGE = 0x00007F7FFF000000UL
2874 There is room from 0x000100000000UL to 0x7F7000000000UL. */
2875 #define MAPPABLE_ADDRESS_RANGE_START 0x000100000000UL
2876 #define MAPPABLE_ADDRESS_RANGE_END 0x7F6FFFFFFFFFUL
2877 #endif
2878 #if defined(UNIX_NETBSD) && defined(DECALPHA)
2879 /* On NetBSD/alpha:
2880 CODE_ADDRESS_RANGE = 0x0000000120000000UL
2881 MALLOC_ADDRESS_RANGE = 0x0000000120000000UL
2882 SHLIB_ADDRESS_RANGE = 0x0000000160000000UL
2883 STACK_ADDRESS_RANGE = 0x00000001FF000000UL
2884 There is room from 0x000200000000UL to 0x03FF00000000UL. */
2885 #define MAPPABLE_ADDRESS_RANGE_START 0x000200000000UL
2886 #define MAPPABLE_ADDRESS_RANGE_END 0x03FF00000000UL
2887 #endif
2888 #if defined(UNIX_NETBSD) && defined(SPARC64)
2889 /* On NetBSD/sparc64:
2890 MMAP_FIXED_ADDRESS_HIGHEST_BIT = 42
2891 CODE_ADDRESS_RANGE = 0x0000000000000000UL
2892 MALLOC_ADDRESS_RANGE = 0x0000000040000000UL
2893 SHLIB_ADDRESS_RANGE = 0x0000000040000000UL
2894 STACK_ADDRESS_RANGE = 0xFFFFFFFFFF000000UL
2895 Addresses >= 0x07FFFFFFE000UL are not mmapable.
2896 There is room from 0x000048000000UL to 0x07F000000000UL. */
2897 #define MAPPABLE_ADDRESS_RANGE_START 0x000048000000UL
2898 #define MAPPABLE_ADDRESS_RANGE_END 0x07EFFFFFFFFFUL
2899 #endif
2900 #if defined(UNIX_OPENBSD) && defined(AMD64)
2901 /* On OpenBSD/x86_64:
2902 MMAP_FIXED_ADDRESS_HIGHEST_BIT = 46
2903 CODE_ADDRESS_RANGE = 0x000000xxxx000000UL ... 0x00001Fxxxx000000UL
2904 MALLOC_ADDRESS_RANGE = 0x000000xxxx000000UL ... 0x00001Fxxxx000000UL
2905 SHLIB_ADDRESS_RANGE = 0x000001xxxx000000UL ... 0x00001Fxxxx000000UL
2906 STACK_ADDRESS_RANGE = 0x00007F7FFx000000UL
2907 The allocated ranges are randomized across the range
2908 from 0x000000000000UL to 0x200000000000UL.
2909 There is room from 0x200000000000UL to 0x7F0000000000UL. */
2910 /* Force the same CODE_ADDRESS_RANGE across platforms. */
2911 #if (CODE_ADDRESS_RANGE <= 0x00001FFFFF000000UL)
2912 #undef CODE_ADDRESS_RANGE
2913 #define CODE_ADDRESS_RANGE 0x00001FFFFF000000UL
2914 #endif
2915 #define MAPPABLE_ADDRESS_RANGE_START 0x200000000000UL
2916 #define MAPPABLE_ADDRESS_RANGE_END 0x7EFFFFFFFFFFUL
2917 #endif
2918 #if defined(UNIX_MACOSX) && defined(AMD64)
2919 /* On Mac OS X 10.5.8/x86_64:
2920 MMAP_FIXED_ADDRESS_HIGHEST_BIT = 46
2921 CODE_ADDRESS_RANGE = 0x0000000100000000UL
2922 MALLOC_ADDRESS_RANGE = 0x0000000100000000UL
2923 SHLIB_ADDRESS_RANGE = 0x00007FFF70000000UL
2924 STACK_ADDRESS_RANGE = 0x00007FFF5F000000UL
2925 On Mac OS X 10.12.4/x86_64:
2926 MMAP_FIXED_ADDRESS_HIGHEST_BIT = 46
2927 CODE_ADDRESS_RANGE = 0x0000000105000000UL
2928 MALLOC_ADDRESS_RANGE = 0x00007FAB97000000UL
2929 SHLIB_ADDRESS_RANGE = 0x00007FAAF7000000UL
2930 STACK_ADDRESS_RANGE = 0x00007FFF5E000000UL
2931 There is room from 0x000200000000UL to 0x7F0000000000UL. */
2932 #define MAPPABLE_ADDRESS_RANGE_START 0x000200000000UL
2933 #define MAPPABLE_ADDRESS_RANGE_END 0x7EFFFFFFFFFFUL
2934 #if 0 /* old */
2935 /* On MacOS X 10.5 in 64-bit mode, the available addresses for mmap and
2936 mach_vm_allocate are in the range 2^33...2^47. */
2937 #define MAPPABLE_ADDRESS_RANGE_START 0x000200000000UL
2938 #define MAPPABLE_ADDRESS_RANGE_END 0x3FFFFFFFFFFFUL
2939 #endif
2940 #endif
2941 #if defined(UNIX_AIX) && defined(POWERPC64)
2942 /* On AIX/POWER with 64-bit ABI:
2943 CODE_ADDRESS_RANGE = 0x0000000100000000UL (r-x) or 0x0000000110000000UL (rw-)
2944 MALLOC_ADDRESS_RANGE = 0x0000000110000000UL
2945 SHLIB_ADDRESS_RANGE = 0x0900000xx0000000UL (r-x) or 0x09001000x0000000UL (rw-)
2946 STACK_ADDRESS_RANGE = 0x0FFFFFFFFF000000UL or 0x1000000000000000UL
2947 Addresses >= 0x0800000000000000UL are not mmapable.
2948 There is room from 0x0000000200000000UL to 0x0800000000000000UL. */
2949 #define MAPPABLE_ADDRESS_RANGE_START 0x0000000200000000UL
2950 #define MAPPABLE_ADDRESS_RANGE_END 0x07FFFFFFFFFFFFFFUL
2951 #endif
2952 #if defined(UNIX_HPUX) && defined(HPPA64)
2953 /* On HP-UX/hppa64:
2954 CODE_ADDRESS_RANGE = 0x4000000000000000UL
2955 MALLOC_ADDRESS_RANGE = 0x8000000100000000UL
2956 SHLIB_ADDRESS_RANGE = 0x800003FFEF000000UL
2957 STACK_ADDRESS_RANGE = 0x800003FFEF000000UL
2958 There is room from 0x4100000000000000UL to 0x8000000000000000UL. */
2959 #define MAPPABLE_ADDRESS_RANGE_START 0x4100000000000000UL
2960 #define MAPPABLE_ADDRESS_RANGE_END 0x7FFFFFFFFFFFFFFFUL
2961 #endif
2962 #if defined(UNIX_HPUX) && defined(IA64)
2963 /* On HP-UX/ia64:
2964 CODE_ADDRESS_RANGE = 0x87FFFFFFEF000000UL
2965 MALLOC_ADDRESS_RANGE = 0x6000000000000000UL
2966 SHLIB_ADDRESS_RANGE = 0x87FFFFFFEF000000UL
2967 STACK_ADDRESS_RANGE = 0x87FFFFFFFF000000UL
2968 There is room from 0x6000000100000000UL to 0x8000000000000000UL. */
2969 #define MAPPABLE_ADDRESS_RANGE_START 0x6000000100000000UL
2970 #define MAPPABLE_ADDRESS_RANGE_END 0x7FFFFFFFFFFFFFFFUL
2971 #endif
2972 #if defined(UNIX_OSF) && defined(DECALPHA)
2973 /* On OSF/1/alpha:
2974 Ordinary pointers are in the range 1*2^32..2*2^32.
2975 CODE_ADDRESS_RANGE = 0x0000000120000000UL
2976 MALLOC_ADDRESS_RANGE = 0x0000000140000000UL
2977 SHLIB_ADDRESS_RANGE = 0x000003FFC0000000UL
2978 STACK_ADDRESS_RANGE = ?
2979 There is room from 0x000200000000UL to 0x03FF00000000UL. */
2980 #define MAPPABLE_ADDRESS_RANGE_START 0x000200000000UL
2981 #define MAPPABLE_ADDRESS_RANGE_END 0x03FF00000000UL
2982 #endif
2983 #if defined(UNIX_SUNOS5) && defined(AMD64)
2984 /* On Solaris 10/x86_64:
2985 MMAP_FIXED_ADDRESS_HIGHEST_BIT = 46
2986 CODE_ADDRESS_RANGE = 0x0000000000000000UL
2987 MALLOC_ADDRESS_RANGE = 0x0000000000000000UL
2988 SHLIB_ADDRESS_RANGE = 0xFFFFFD7FFF000000UL
2989 STACK_ADDRESS_RANGE = 0xFFFFFD7FFF000000UL
2990 On Solaris 11/x86_64:
2991 MMAP_FIXED_ADDRESS_HIGHEST_BIT = 46
2992 CODE_ADDRESS_RANGE = 0x0000000000000000UL
2993 MALLOC_ADDRESS_RANGE = 0x0000000000000000UL
2994 SHLIB_ADDRESS_RANGE = 0xFFFF80FFBF000000UL
2995 STACK_ADDRESS_RANGE = 0xFFFF80FFBF000000UL
2996 There is room from 0x0000000100000000UL to 0x00007FFF00000000UL. */
2997 #define MAPPABLE_ADDRESS_RANGE_START 0x0000000100000000UL
2998 #define MAPPABLE_ADDRESS_RANGE_END 0x00007FFEFFFFFFFFUL
2999 #endif
3000 #if defined(UNIX_SUNOS5) && defined(SPARC64)
3001 /* On Solaris 10/sparc64:
3002 MMAP_FIXED_ADDRESS_HIGHEST_BIT = 46
3003 CODE_ADDRESS_RANGE = 0x0000000100000000UL
3004 MALLOC_ADDRESS_RANGE = 0x0000000100000000UL
3005 SHLIB_ADDRESS_RANGE = 0xFFFFFFFF7E000000UL
3006 STACK_ADDRESS_RANGE = 0xFFFFFFFF7F000000UL
3007 There is room from 0x0000000200000000UL to 0x00007FFF00000000UL. */
3008 #define MAPPABLE_ADDRESS_RANGE_START 0x0000000200000000UL
3009 #define MAPPABLE_ADDRESS_RANGE_END 0x00007FFEFFFFFFFFUL
3010 #endif
3011 #if defined(UNIX_CYGWIN) && defined(AMD64)
3012 /* On Cygwin, running on Windows 10:
3013 MMAP_FIXED_ADDRESS_HIGHEST_BIT = 46
3014 CODE_ADDRESS_RANGE = 0x0000000100000000UL
3015 MALLOC_ADDRESS_RANGE = 0x0000000600000000UL
3016 SHLIB_ADDRESS_RANGE = 0x00000000FF000000UL
3017 STACK_ADDRESS_RANGE = 0x00000000FF000000UL
3018 There is room from 0x000700000000UL to 0x06FF00000000UL. */
3019 #define MAPPABLE_ADDRESS_RANGE_START 0x000700000000UL
3020 #define MAPPABLE_ADDRESS_RANGE_END 0x05FFFFFFFFFFUL
3021 #endif
3022 #endif
3023 /* When changed: do nothing */
3024
3025 /* Whether the operating system is capable of sending interruptions
3026 (Ctrl-C and others) as signal: */
3027 #if defined(UNIX)
3028 #define HAVE_SIGNALS
3029 #endif
3030 /* Whether we can even react to asynchronous signals:
3031 (If WIDE && !WIDE_HARD, writing a pointer is usually no elementary
3032 operation anymore!) */
3033 #if (defined(WIDE) && !defined(WIDE_HARD)) && !(defined(GNU) && defined(SPARC))
3034 #define NO_ASYNC_INTERRUPTS
3035 #endif
3036 #if defined(NO_ASYNC_INTERRUPTS) && defined(MULTITHREAD)
3037 #error No multithreading possible with this memory model!
3038 #endif
3039 /* When changed: extend SPVW, write a interruptp(). */
3040
3041 /* Flavors of Pathname-management: */
3042 #ifdef UNIX
3043 #define PATHNAME_UNIX
3044 #endif
3045 #ifdef WIN32
3046 #define PATHNAME_WIN32
3047 #endif
3048 /* Components of pathnames: */
3049 #ifdef PATHNAME_WIN32
3050 #define HAS_HOST 1
3051 #define HAS_DEVICE 1
3052 #endif
3053 #ifdef PATHNAME_UNIX
3054 #define HAS_HOST 0
3055 #define HAS_DEVICE 0
3056 #endif
3057 /* Handling of the file "extension" (pathname-type): */
3058 #if 0
3059 #define PATHNAME_EXT /* Name and Type are separated, so no limitation of the length */
3060 #endif
3061 #if defined(PATHNAME_UNIX) || defined(PATHNAME_WIN32)
3062 #define PATHNAME_NOEXT /* no explicit extension. */
3063 #endif
3064 /* Whether "//" at the beginning of a pathname has to remain (and not to be shortened to "/"): */
3065 #ifdef UNIX_CYGWIN
3066 #define PATHNAME_UNIX_UNC
3067 #endif
3068 /* When changed: extend pathname.d */
3069
3070 /* Whether there is a type FOREIGN (a wrapper for various kinds of pointers): */
3071 #if defined(UNIX) || defined(DYNAMIC_FFI) || defined(WIN32_NATIVE)
3072 /* (Used by FFI and by CLX.) */
3073 #define FOREIGN void*
3074 #endif
3075 /* When changed: do nothing */
3076 %% #ifdef FOREIGN
3077 %% export_def(FOREIGN);
3078 %% #endif
3079
3080 /* Whether the STACK is checked at certain key points: */
3081 #define STACKCHECKS (SAFETY >= 1) /* when SUBRs and FSUBRs are called */
3082 #define STACKCHECKC (SAFETY >= 1) /* when compiled closures are interpreted */
3083 #define STACKCHECKR (SAFETY >= 1) /* in the reader */
3084 #define STACKCHECKP (SAFETY >= 1) /* in the printer */
3085 #define STACKCHECKB (SAFETY >= 1) /* in the bindings */
3086 /* When changed: do nothing */
3087
3088
3089 /* Feature dependent include files. */
3090
3091 #ifdef HAVE_ICONV
3092 #include <iconv.h>
3093 #if _LIBICONV_VERSION
3094 /* We use GNU libiconv. */
3095 #define GNU_LIBICONV
3096 #define HAVE_GOOD_ICONV
3097 #elif (__GLIBC__ > 2 || (__GLIBC__ == 2 && __GLIBC_MINOR__ >= 2))
3098 /* glibc-2.2 iconv is also very reliable. Use it. */
3099 #define HAVE_GOOD_ICONV
3100 #else
3101 /* Other iconv implementations are too unreliable.
3102 Don't define HAVE_GOOD_ICONV. */
3103 #endif
3104 #endif
3105
3106
3107 /* ############### List of implemented CLtL2-features ############### */
3108
3109 #define X3J13_005 /* 18.5.1993 */
3110 #define X3J13_014 /* 22.1.1995 */
3111 #define X3J13_149 /* 22.7.1993 */
3112 #define X3J13_175 /* 25.7.1993 */
3113
3114
3115 /* ##################### Memory representation of objects ###################
3116
3117 Memory Representation and the Type Code of the various data types
3118 =================================================================
3119
3120 1. The type code
3121 ----------------
3122
3123 An object consists of - in the same word - some type information and, for
3124 immediate types, a couple of data bits, or, for heap allocated types,
3125 a pointer to memory. There are many models of mixing type and pointer.
3126 In the standard model, 6 to 8 bits (the word's high bits) are used for the
3127 type. In the WIDE_HARD and WIDE_SOFT models, type and pointer are each 32
3128 bits. In the HEAPCODES model, there are only 2 to 6 bits.
3129
3130 One bit (normally bit 31) is used as mark bit by the garbage collector.
3131 Outside of GC, it is always cleared. (Except for the get_circularities and
3132 subst_circ routines, and in the STACK, the GC bit is used for marking frames.)
3133
3134 2. Memory formats
3135 -----------------
3136
3137 2.1. Immediate objects
3138
3139 2.1.1. Machine pointers
3140
3141 Machine pointers are immediate objects. They may point to the code area
3142 (.text segment), to data areas (.bss, .data segments, malloc'ed areas).
3143 Other values (e.g. pointers to text/data in shared libraries) are not
3144 allowed, because they may contain bits which are interpreted as a type code.
3145 To use such machine addresses, you must wrap them in foreign-pointers or
3146 simple-bit-vectors.
3147
3148 2.1.2. Other immediate objects
3149
3150 Character, Fixnum, Short-Float, and, if IMMEDIATE_FFLOAT, Single-Float.
3151 Furthermore: Frame-Pointer, Small-Read-Label, System. (System means some
3152 finite number of special values, such as #<UNBOUND>.)
3153
3154 2.2. SUBRs
3155
3156 They are immediate in the sense that they do not move (they do not need to,
3157 because they are allocated statically), but they have to be traversed by GC.
3158
3159 2.3. Pairs
3160
3161 These are heap objects containing just two pointers: Cons and, if SPVW_PURE,
3162 Ratio and Complex.
3163
3164 2.4. Varobjects
3165
3166 These are heap objects of varying size. GC needs a header word at the
3167 beginning of the object.
3168
3169 2.4.1. Records
3170
3171 These are varobjects which have additional type information and flags
3172 in the second header word. Closure, Structure, Stream, Instance are always
3173 records. Depending on the memory model, arrays, symbols etc. may or may
3174 not be records.
3175
3176 2.4.2. Arrays
3177
3178 Simple-Bit-Vector, Simple-String, Simple-Vector are the "simple" arrays.
3179 The non-simple ones are represented by a Iarray, yet the type code gives
3180 some information about the rank, the representation and the element type:
3181
3182 | "simple" | "not simple" |
3183 | Sarray | Iarray |
3184 ------------------------------+-----------------+----------------+
3185 (vector bit) | sbvector_type | bvector_type |
3186 ------------------------------+-----------------+----------------+
3187 (vector (unsigned-byte 2)) | sb2vector_type | b2vector_type |
3188 ------------------------------+-----------------+----------------+
3189 (vector (unsigned-byte 4)) | sb4vector_type | b4vector_type |
3190 ------------------------------+-----------------+----------------+
3191 (vector (unsigned-byte 8)) | sb8vector_type | b8vector_type |
3192 ------------------------------+-----------------+----------------+
3193 (vector (unsigned-byte 16)) | sb16vector_type | b16vector_type |
3194 ------------------------------+-----------------+----------------+
3195 (vector (unsigned-byte 32)) | sb32vector_type | b32vector_type |
3196 ------------------------------+-----------------+----------------+
3197 (vector character) | sstring_type | string_type |
3198 ------------------------------+-----------------+----------------+
3199 (vector t) | svector_type | vector_type |
3200 ------------------------------+-----------------+----------------+
3201 array of dimension /= 1 | -- | mdarray_type |
3202 ------------------------------+-----------------+----------------+
3203
3204 2.4.3. Other varobjects
3205
3206 Symbol has some special flags (keyword, constant, special) in the header,
3207 if possible.
3208
3209 FSUBR, Bignum, Single-Float (unless IMMEDIATE_FFLOAT), Double-Float,
3210 Long-Float, Ratio and Complex (only if SPVW_MIXED).
3211
3212 ######################## LISP-objects in general ######################## */
3213
3214 /* Other acronyms like 'oint', 'tint', 'aint', 'cint' will be used
3215 for the corresponding integer types:
3216 Integer type contains information equivalent to
3217 oint LISP object
3218 tint type code of a LISP object
3219 aint address of a LISP object
3220 cint LISP character
3221
3222 Usually sizeof(oint) = sizeof(aint) = sizeof(uintL) = 32 Bit.
3223 Under the model WIDE sizeof(oint) is > sizeof(uintL).
3224 Model WIDE_HARD stands for sizeof(aint) > sizeof(uintL).
3225 This model is to be chosen if the following holds true:
3226 sizeof(void*) > sizeof(uintL) = 32 bit. It also requires that
3227 sizeof(long) = sizeof(void*) = 64 bit, because some 64-bit numbers
3228 appear as pre-processor constants.
3229 Model WIDE_SOFT stands for sizeof(oint) = 64 bit and sizeof(aint) = 32 bit.
3230 This model can be chosen on any 32-Bit-Machine, if the
3231 compiler has 64-bit numbers (in software or hardware).
3232 You will also need to choose it, if there would not be enough space
3233 for the type-bits in a 32-bit pointer.
3234 Model HEAPCODES stands for sizeof(oint) = sizeof(aint), and only minimal
3235 type information is stored in a pointer. All heap allocated objects
3236 (except conses) must contain the complete type and a length field in the
3237 first word. The heap gets somewhat bigger by this, and type tests require
3238 more memory accesses on average, but this model is portable even to
3239 systems whose memory map looks like Swiss Cheese. */
3240
3241 %% #if notused
3242 %% #ifdef WIDE_HARD
3243 %% puts("#define WIDE_HARD");
3244 %% #endif
3245 %% #ifdef WIDE_SOFT
3246 %% puts("#define WIDE_SOFT");
3247 %% #endif
3248 %% #ifdef WIDE
3249 %% puts("#define WIDE");
3250 %% #endif
3251 %% #endif
3252
3253 /* These are the parameters for using SINGLEMAP_MEMORY. They depend heavily
3254 on the address space layout. */
3255 /* When using SINGLEMAP_MEMORY:
3256
3257 The type bits are part of the address that we send on the addressbus.
3258 Cf. macros pointable_unchecked and pointable_address_unchecked.
3259 Therefore we must consider MMAP_FIXED_ADDRESS_HIGHEST_BIT.
3260
3261 In order to respect the constraints given by
3262 MAPPABLE_ADDRESS_RANGE_START and MAPPABLE_ADDRESS_RANGE_END,
3263 we use the addresses
3264 (typecode << oint_type_shift) | SINGLEMAP_ADDRESS_BASE
3265 where typecode consists of at most 6 or 7 bits and is > 0.
3266 oint_type_shift is usually around (MMAP_FIXED_ADDRESS_HIGHEST_BIT-6).
3267 SINGLEMAP_ADDRESS_BASE is chosen so that it contains only few bits.
3268 SINGLEMAP_TYPE_MASK contains the bits that can be used as type
3269 bits (excluding the garcol_bit_o). It consists of 6 or 7 bits.
3270 It must be disjoint to SINGLEMAP_ADDRESS_BASE.
3271 So, oint_type_shift is the smallest bit set in SINGLEMAP_TYPE_MASK.
3272 Trade-offs:
3273 - On 32-bit platforms, oint_type_shift should be as large as possible.
3274 - On 64-bit platforms, for SINGLEMAP_TYPE_MASK, 7 bits is better
3275 than 6 bits. */
3276 /* Sort order: Keep this list sorted by
3277 1. word size (32-bit before 64-bit),
3278 2. operating system (Linux, *BSD, Mac OS X, proprietary Unices, Windows)
3279 3. CPU and ABI (alphabetically) */
3280 #if !defined(WIDE_HARD)
3281 /* 32-bit platforms */
3282 /* We can nowadays assume that MMAP_FIXED_ADDRESS_HIGHEST_BIT is 30. */
3283 /* On some platforms, strictly respecting the MAPPABLE_ADDRESS_RANGE
3284 would lead to a value of oint_type_shift < 24, which is unusable.
3285 Define IGNORE_MAPPABLE_ADDRESS_RANGE for these platforms. */
3286 #if defined(UNIX_LINUX) && defined(AMD64) /* Linux/x86_64 with 32-bit x32 ABI */
3287 #if 1 /* arbitrary choice */
3288 #define SINGLEMAP_ADDRESS_BASE 0x10000000UL
3289 #define SINGLEMAP_TYPE_MASK 0x6F000000UL
3290 #elif 1 /* arbitrary choice */
3291 #define SINGLEMAP_ADDRESS_BASE 0x20000000UL
3292 #define SINGLEMAP_TYPE_MASK 0x5F000000UL
3293 #else
3294 #define SINGLEMAP_ADDRESS_BASE 0x40000000UL
3295 #define SINGLEMAP_TYPE_MASK 0x3F000000UL
3296 #endif
3297 #define SINGLEMAP_oint_type_shift 24
3298 #define SINGLEMAP_WORKS 1
3299 #endif
3300 #if defined(UNIX_LINUX) && defined(ARM) /* Linux/arm */
3301 #define SINGLEMAP_ADDRESS_BASE 0x40000000UL
3302 #define SINGLEMAP_TYPE_MASK 0x3F000000UL
3303 #define SINGLEMAP_oint_type_shift 24
3304 /* This configuration allocates memory outside the MAPPABLE_ADDRESS_RANGE. */
3305 #define IGNORE_MAPPABLE_ADDRESS_RANGE
3306 #define SINGLEMAP_WORKS 0 /* does not work on build.opensuse.org machines */
3307 #endif
3308 #if defined(UNIX_LINUX) && defined(HPPA) /* Linux/hppa */
3309 #define SINGLEMAP_ADDRESS_BASE 0x08000000UL
3310 #define SINGLEMAP_TYPE_MASK 0x77000000UL
3311 #define SINGLEMAP_oint_type_shift 24
3312 #define SINGLEMAP_WORKS 1 /* but only without GENERATIONAL_GC */
3313 #endif
3314 #if defined(UNIX_LINUX) && defined(I80386) /* Linux/i386, Linux/x86_64 with 32-bit i386 ABI */
3315 #define SINGLEMAP_ADDRESS_BASE 0UL
3316 #define SINGLEMAP_TYPE_MASK 0x77000000UL
3317 #define SINGLEMAP_oint_type_shift 24
3318 /* This configuration allocates memory outside the MAPPABLE_ADDRESS_RANGE. */
3319 #define IGNORE_MAPPABLE_ADDRESS_RANGE
3320 /* Actually no such configuration works, because the CODE_ADDRESS_RANGE
3321 consumes so many bits that we have at most 1+1 bits for the typecode. */
3322 #define SINGLEMAP_WORKS 0
3323 #endif
3324 #if defined(UNIX_LINUX) && defined(M68K) /* Linux/m68k */
3325 #define SINGLEMAP_ADDRESS_BASE 0UL
3326 #define SINGLEMAP_TYPE_MASK 0x3F000000UL
3327 #define SINGLEMAP_oint_type_shift 24
3328 /* garcol_bit_o must be 30, because bit 31 is set in CODE_ADDRESS_RANGE. */
3329 #define SINGLEMAP_garcol_bit_o 30
3330 #define SINGLEMAP_WORKS 1 /* but only without GENERATIONAL_GC */
3331 #endif
3332 #if defined(UNIX_LINUX) && (defined(MIPS) || defined(MIPS64)) /* Linux/mips with o32 or n32 ABI */
3333 #if !(_MIPS_SIM == _ABIN32) /* Linux/mips with o32 ABI */
3334 #define SINGLEMAP_ADDRESS_BASE 0x40000000UL
3335 #define SINGLEMAP_TYPE_MASK 0x3F000000UL
3336 #define SINGLEMAP_oint_type_shift 24
3337 /* Actually no such configuration works, because the CODE_ADDRESS_RANGE
3338 consumes so many bits that we have at most 3+1 bits for the typecode. */
3339 #define SINGLEMAP_WORKS 0
3340 #else /* Linux/mips with n32 ABI */
3341 #define SINGLEMAP_ADDRESS_BASE 0x10000000UL
3342 #define SINGLEMAP_TYPE_MASK 0x6F000000UL
3343 #define SINGLEMAP_oint_type_shift 24
3344 /* This configuration allocates memory outside the MAPPABLE_ADDRESS_RANGE. */
3345 #define IGNORE_MAPPABLE_ADDRESS_RANGE
3346 #define SINGLEMAP_WORKS 1
3347 #endif
3348 #endif
3349 #if defined(UNIX_LINUX) && defined(POWERPC) /* Linux/powerpc64 with 32-bit ABI */
3350 #define SINGLEMAP_ADDRESS_BASE 0x10000000UL
3351 #define SINGLEMAP_TYPE_MASK 0x6F000000UL
3352 #define SINGLEMAP_oint_type_shift 24
3353 /* This configuration allocates memory outside the MAPPABLE_ADDRESS_RANGE. */
3354 #define IGNORE_MAPPABLE_ADDRESS_RANGE
3355 /* Actually no such configuration works, because the CODE_ADDRESS_RANGE
3356 consumes so many bits that we have at most 5+1 bits for the typecode. */
3357 #define SINGLEMAP_WORKS 0
3358 #endif
3359 #if defined(UNIX_LINUX) && defined(S390) /* Linux/s390x with 32-bit ABI */
3360 #define SINGLEMAP_ADDRESS_BASE 0x08000000UL
3361 #define SINGLEMAP_TYPE_MASK 0x77000000UL
3362 #define SINGLEMAP_oint_type_shift 24
3363 #define SINGLEMAP_WORKS 1
3364 #endif
3365 #if defined(UNIX_LINUX) && defined(SPARC) /* Linux/sparc64 with 32-bit ABI */
3366 #define SINGLEMAP_ADDRESS_BASE 0UL
3367 #define SINGLEMAP_TYPE_MASK 0x77000000UL
3368 #define SINGLEMAP_oint_type_shift 24
3369 /* Set garcol_bit_o to 27. */
3370 #define SINGLEMAP_garcol_bit_o 27
3371 /* Actually no such configuration works, because the CODE_ADDRESS_RANGE
3372 consumes so many bits that we have at most 4+1 bits for the typecode. */
3373 #define SINGLEMAP_WORKS 0
3374 #endif
3375 #if defined(UNIX_HURD) && defined(I80386) /* Hurd/i386 */
3376 #define SINGLEMAP_ADDRESS_BASE 0x08000000UL
3377 #define SINGLEMAP_TYPE_MASK 0x77000000UL
3378 #define SINGLEMAP_oint_type_shift 24
3379 /* This configuration allocates memory outside the MAPPABLE_ADDRESS_RANGE. */
3380 #define IGNORE_MAPPABLE_ADDRESS_RANGE
3381 /* This configuration does not work, because it conflicts with the system's
3382 use of the memory region at 0x09000000UL. */
3383 #define SINGLEMAP_WORKS 0
3384 #endif
3385 #if (defined(__FreeBSD__) || defined(UNIX_GNU_FREEBSD) || defined(__DragonFly__)) && defined(I80386) /* FreeBSD/i386, GNU/kFreeBSD/i386, DragonFly/i386 */
3386 #define SINGLEMAP_ADDRESS_BASE 0x08000000UL
3387 #define SINGLEMAP_TYPE_MASK 0x77000000UL
3388 #define SINGLEMAP_oint_type_shift 24
3389 /* This configuration allocates memory outside the MAPPABLE_ADDRESS_RANGE. */
3390 #define IGNORE_MAPPABLE_ADDRESS_RANGE
3391 /* This configuration works, but it conflicts with the system's use of
3392 the memory region at 0x28000000UL and is therefore too dangerous
3393 for general use. */
3394 #define SINGLEMAP_WORKS 0
3395 #endif
3396 #if defined(UNIX_NETBSD) && defined(I80386) /* NetBSD/i386 */
3397 #define SINGLEMAP_ADDRESS_BASE 0x08000000UL
3398 #define SINGLEMAP_TYPE_MASK 0x77000000UL
3399 #define SINGLEMAP_oint_type_shift 24
3400 /* This configuration allocates memory outside the MAPPABLE_ADDRESS_RANGE. */
3401 #define IGNORE_MAPPABLE_ADDRESS_RANGE
3402 #define SINGLEMAP_WORKS 1 /* but only without GENERATIONAL_GC */
3403 #endif
3404 #if defined(UNIX_NETBSD) && defined(SPARC) /* NetBSD/sparc */
3405 #define SINGLEMAP_ADDRESS_BASE 0UL
3406 #define SINGLEMAP_TYPE_MASK 0x5F000000UL
3407 #define SINGLEMAP_oint_type_shift 24
3408 /* This configuration allocates memory outside the MAPPABLE_ADDRESS_RANGE:
3409 from 0x01000000UL to 0x1FFFFFFFUL and from 0x44000000UL to 0x5FFFFFFFUL. */
3410 #define IGNORE_MAPPABLE_ADDRESS_RANGE
3411 #define SINGLEMAP_WORKS 1 /* but only without GENERATIONAL_GC */
3412 #endif
3413 #if defined(UNIX_OPENBSD) && defined(I80386) /* OpenBSD/i386 */
3414 #define SINGLEMAP_ADDRESS_BASE 0x40000000UL
3415 #define SINGLEMAP_TYPE_MASK 0x3F000000UL
3416 #define SINGLEMAP_oint_type_shift 24
3417 /* This configuration allocates memory outside the MAPPABLE_ADDRESS_RANGE. */
3418 #define IGNORE_MAPPABLE_ADDRESS_RANGE
3419 /* Actually no such configuration works, because the CODE_ADDRESS_RANGE
3420 consumes so many bits that we have at most 3+1 bits for the typecode. */
3421 #define SINGLEMAP_WORKS 0
3422 #endif
3423 #if defined(UNIX_MACOSX) && defined(I80386) /* Mac OS X/x86_64 with 32-bit ABI */
3424 #define SINGLEMAP_ADDRESS_BASE 0x10000000UL
3425 #define SINGLEMAP_TYPE_MASK 0x6F000000UL
3426 #define SINGLEMAP_oint_type_shift 24
3427 #define SINGLEMAP_WORKS 1
3428 #endif
3429 #if defined(UNIX_MACOSX) && defined(POWERPC) /* Mac OS X/PowerPC */
3430 #define SINGLEMAP_ADDRESS_BASE 0x10000000UL
3431 #define SINGLEMAP_TYPE_MASK 0x6F000000UL
3432 #define SINGLEMAP_oint_type_shift 24
3433 #define SINGLEMAP_WORKS 1
3434 #endif
3435 #if defined(UNIX_AIX) && defined(POWERPC) /* AIX/POWER with 32-bit ABI */
3436 #define SINGLEMAP_ADDRESS_BASE 0x40000000UL
3437 #define SINGLEMAP_TYPE_MASK 0x3F000000UL
3438 #define SINGLEMAP_oint_type_shift 24
3439 /* Actually no such configuration works, because the CODE_ADDRESS_RANGE
3440 consumes so many bits that we have at most 5+1 bits for the typecode. */
3441 #define SINGLEMAP_WORKS 0
3442 #endif
3443 #if defined(UNIX_HPUX) && defined(HPPA) /* HP-UX/hppa with 32-bit ABI */
3444 #define SINGLEMAP_ADDRESS_BASE 0UL
3445 #define SINGLEMAP_TYPE_MASK 0x3F000000UL
3446 #define SINGLEMAP_oint_type_shift 24
3447 /* This configuration allocates memory outside the MAPPABLE_ADDRESS_RANGE. */
3448 #define IGNORE_MAPPABLE_ADDRESS_RANGE
3449 /* Does not work because mmap MAP_FIXED is not supported on this platform. */
3450 #define SINGLEMAP_WORKS 0
3451 #endif
3452 #if defined(UNIX_HPUX) && defined(IA64) /* HP-UX/ia64 with 32-bit ABI */
3453 #define SINGLEMAP_ADDRESS_BASE 0x40000000UL
3454 #define SINGLEMAP_TYPE_MASK 0x3F000000UL
3455 #define SINGLEMAP_oint_type_shift 24
3456 /* Actually no such configuration works, because the CODE_ADDRESS_RANGE
3457 consumes so many bits that we have at most 1+1 bits for the typecode. */
3458 #define SINGLEMAP_WORKS 0
3459 #endif
3460 #if defined(UNIX_IRIX) && (defined(MIPS) || defined(MIPS64)) /* IRIX 6.5 with o32 or n32 ABI */
3461 #if !(_MIPS_SIM == _ABIN32) /* IRIX 6.5 with o32 ABI */
3462 #define SINGLEMAP_ADDRESS_BASE 0x10000000UL
3463 #define SINGLEMAP_TYPE_MASK 0x6F000000UL
3464 #define SINGLEMAP_oint_type_shift 24
3465 /* This configuration allocates memory outside the MAPPABLE_ADDRESS_RANGE:
3466 it conflicts with the system's use of the memory region at 0x5F800000UL.
3467 This leads to
3468 "Warning: reserving address range 0x5f000000...0x5fffffff that contains memory mappings. clisp might crash later!"
3469 Later, we see an endless loop or a crash while compiling compiler.lisp. */
3470 #define IGNORE_MAPPABLE_ADDRESS_RANGE
3471 #define SINGLEMAP_WORKS 0
3472 #else /* IRIX 6.5 with n32 ABI */
3473 #define SINGLEMAP_ADDRESS_BASE 0x10000000UL
3474 #define SINGLEMAP_TYPE_MASK 0x6F000000UL
3475 #define SINGLEMAP_oint_type_shift 24
3476 /* This configuration allocates memory outside the MAPPABLE_ADDRESS_RANGE:
3477 it conflicts with the system's use of the memory region at 0x5F800000UL.
3478 This leads to
3479 "Warning: reserving address range 0x5f000000...0x5fffffff that contains memory mappings. clisp might crash later!"
3480 Later, we see an endless loop or a crash while compiling compiler.lisp. */
3481 #define IGNORE_MAPPABLE_ADDRESS_RANGE
3482 #define SINGLEMAP_WORKS 0
3483 #endif
3484 #endif
3485 #if defined(UNIX_SUNOS5) && defined(I80386) /* Solaris/x86_64 with 32-bit ABI */
3486 #define SINGLEMAP_ADDRESS_BASE 0x08000000UL
3487 #define SINGLEMAP_TYPE_MASK 0x77000000UL
3488 #define SINGLEMAP_oint_type_shift 24
3489 /* This configuration allocates memory outside the MAPPABLE_ADDRESS_RANGE. */
3490 #define IGNORE_MAPPABLE_ADDRESS_RANGE
3491 #define SINGLEMAP_WORKS 1
3492 #endif
3493 #if defined(UNIX_SUNOS5) && defined(SPARC) /* Solaris/sparc64 with 32-bit ABI */
3494 #define SINGLEMAP_ADDRESS_BASE 0UL
3495 #define SINGLEMAP_TYPE_MASK 0x7E000000UL
3496 #define SINGLEMAP_oint_type_shift 25
3497 /* This configuration allocates memory outside the MAPPABLE_ADDRESS_RANGE. */
3498 #define IGNORE_MAPPABLE_ADDRESS_RANGE
3499 #define SINGLEMAP_WORKS 1
3500 #endif
3501 #if defined(UNIX_HAIKU) && defined(I80386) /* Haiku/i386 */
3502 #define SINGLEMAP_ADDRESS_BASE 0x40000000UL
3503 #define SINGLEMAP_TYPE_MASK 0x3F000000UL
3504 #define SINGLEMAP_oint_type_shift 24
3505 /* This configuration allocates memory outside the MAPPABLE_ADDRESS_RANGE. */
3506 #define IGNORE_MAPPABLE_ADDRESS_RANGE
3507 /* Actually no such configuration works, because the CODE_ADDRESS_RANGE
3508 consumes so many bits that we have at most 5+1 bits for the typecode. */
3509 #define SINGLEMAP_WORKS 0
3510 #endif
3511 #if defined(UNIX_MINIX) && defined(I80386) /* Minix/i386 */
3512 #define SINGLEMAP_ADDRESS_BASE 0x08000000UL
3513 #define SINGLEMAP_TYPE_MASK 0x77000000UL
3514 #define SINGLEMAP_oint_type_shift 24
3515 /* This configuration allocates memory outside the MAPPABLE_ADDRESS_RANGE. */
3516 #define IGNORE_MAPPABLE_ADDRESS_RANGE
3517 #define SINGLEMAP_WORKS 1
3518 #endif
3519 #if defined(UNIX_CYGWIN) && defined(I80386) /* Cygwin, running on Windows 10 */
3520 #define SINGLEMAP_ADDRESS_BASE 0x80000000UL
3521 #define SINGLEMAP_TYPE_MASK 0x3F000000UL
3522 #define SINGLEMAP_oint_type_shift 24
3523 /* Set garcol_bit_o to 30. */
3524 #define SINGLEMAP_garcol_bit_o 30
3525 #define SINGLEMAP_WORKS 1
3526 #endif
3527 #if defined(WIN32_NATIVE) && defined(I80386) /* mingw, running on Windows 10 */
3528 #define SINGLEMAP_ADDRESS_BASE 0x04000000UL
3529 #define SINGLEMAP_TYPE_MASK 0x7B000000UL
3530 #define SINGLEMAP_oint_type_shift 24
3531 /* This configuration allocates memory outside the MAPPABLE_ADDRESS_RANGE.
3532 It is risky to define IGNORE_MAPPABLE_ADDRESS_RANGE on this platform. */
3533 #define IGNORE_MAPPABLE_ADDRESS_RANGE
3534 #define SINGLEMAP_WORKS 1 /* but risky */
3535 #endif
3536 #ifndef SINGLEMAP_garcol_bit_o
3537 #define SINGLEMAP_garcol_bit_o 31
3538 #endif
3539 #define SINGLEMAP_oint_type_len (32-SINGLEMAP_oint_type_shift)
3540 #define SINGLEMAP_oint_type_mask (SINGLEMAP_TYPE_MASK | (1UL<<SINGLEMAP_garcol_bit_o))
3541 #else
3542 /* 64-bit platforms */
3543 #if defined(UNIX_LINUX) && defined(AMD64) /* Linux/x86_64 */
3544 #define SINGLEMAP_ADDRESS_BASE 0UL
3545 #define SINGLEMAP_TYPE_MASK 0x1F8000000000UL
3546 #define SINGLEMAP_oint_type_shift 39
3547 /* Actually no such configuration works, because the CODE_ADDRESS_RANGE
3548 consumes so many bits that we have at most 1+1 bits for the typecode. */
3549 #define SINGLEMAP_WORKS 0
3550 #endif
3551 #if defined(UNIX_LINUX) && defined(ARM64) /* Linux/arm64 */
3552 #if 1 /* arbitrary choice */
3553 #define SINGLEMAP_ADDRESS_BASE 0x002000000000UL
3554 #define SINGLEMAP_TYPE_MASK 0x005F00000000UL
3555 #else
3556 #define SINGLEMAP_ADDRESS_BASE 0x004000000000UL
3557 #define SINGLEMAP_TYPE_MASK 0x003F00000000UL
3558 #endif
3559 #define SINGLEMAP_oint_type_shift 32
3560 /* Actually no such configuration works, because the CODE_ADDRESS_RANGE
3561 consumes so many bits that we have at most 3+1 bits for the typecode. */
3562 #define SINGLEMAP_WORKS 0
3563 #endif
3564 #if defined(UNIX_LINUX) && defined(DECALPHA) /* Linux/alpha */
3565 #define SINGLEMAP_ADDRESS_BASE 0UL
3566 #define SINGLEMAP_TYPE_MASK 0x00FE00000000UL
3567 #define SINGLEMAP_oint_type_shift 33
3568 #define SINGLEMAP_WORKS 1
3569 #endif
3570 #if defined(UNIX_LINUX) && defined(IA64) /* Linux/ia64 */
3571 #define SINGLEMAP_ADDRESS_BASE 0x6000000000000000UL
3572 #define SINGLEMAP_TYPE_MASK 0x000007F000000000UL
3573 #define SINGLEMAP_oint_type_shift 36
3574 #define SINGLEMAP_WORKS 1
3575 #endif
3576 #if defined(UNIX_LINUX) && defined(MIPS64) /* Linux/mips with 64-bit ABI */
3577 #define SINGLEMAP_ADDRESS_BASE 0x008000000000UL
3578 #define SINGLEMAP_TYPE_MASK 0x007E00000000UL
3579 #define SINGLEMAP_oint_type_shift 33
3580 /* Actually no such configuration works, because the CODE_ADDRESS_RANGE
3581 consumes so many bits that we have at most 4+1 bits for the typecode. */
3582 #define SINGLEMAP_WORKS 0
3583 #endif
3584 #if defined(UNIX_LINUX) && defined(POWERPC64) /* Linux/powerpc64, Linux/powerpc64le */
3585 #define SINGLEMAP_ADDRESS_BASE 0x010000000000UL
3586 #define SINGLEMAP_TYPE_MASK 0x3E8000000000UL
3587 #define SINGLEMAP_oint_type_shift 39
3588 #define SINGLEMAP_WORKS 1
3589 #endif
3590 #if defined(UNIX_LINUX) && defined(RISCV64) /* Linux/riscv64 */
3591 #define SINGLEMAP_ADDRESS_BASE 0UL
3592 #define SINGLEMAP_TYPE_MASK 0x001F80000000UL
3593 #define SINGLEMAP_oint_type_shift 31
3594 #define SINGLEMAP_WORKS 0 /* even without GENERATIONAL_GC */
3595 #endif
3596 #if defined(UNIX_LINUX) && defined(S390_64) /* Linux/s390x */
3597 #define SINGLEMAP_ADDRESS_BASE 0UL
3598 #define SINGLEMAP_TYPE_MASK 0x01FC00000000UL
3599 #define SINGLEMAP_oint_type_shift 34
3600 #define SINGLEMAP_WORKS 1
3601 #endif
3602 #if defined(UNIX_LINUX) && defined(SPARC64) /* Linux/sparc64 */
3603 #define SINGLEMAP_ADDRESS_BASE 0x0000010000000000UL
3604 #define SINGLEMAP_TYPE_MASK 0x000006F800000000UL
3605 #define SINGLEMAP_oint_type_shift 35
3606 /* This configuration allocates memory outside the MAPPABLE_ADDRESS_RANGE. */
3607 #define IGNORE_MAPPABLE_ADDRESS_RANGE
3608 #define SINGLEMAP_WORKS 1
3609 #endif
3610 #if (defined(UNIX_FREEBSD) || defined(UNIX_GNU_FREEBSD)) && defined(AMD64) /* FreeBSD/x86_64, GNU/kFreeBSD/x86_64 */
3611 #define SINGLEMAP_ADDRESS_BASE 0UL
3612 #define SINGLEMAP_TYPE_MASK 0x7F0000000000UL
3613 #define SINGLEMAP_oint_type_shift 40
3614 #define SINGLEMAP_WORKS 1
3615 #endif
3616 #if defined(UNIX_FREEBSD) && defined(ARM64) /* FreeBSD/arm64 */
3617 #define SINGLEMAP_ADDRESS_BASE 0UL
3618 #define SINGLEMAP_TYPE_MASK 0xFE0000000000UL
3619 #define SINGLEMAP_oint_type_shift 41
3620 #define SINGLEMAP_WORKS 1
3621 #endif
3622 #if defined(UNIX_NETBSD) && defined(AMD64) /* NetBSD/x86_64 */
3623 #define SINGLEMAP_ADDRESS_BASE 0UL
3624 #define SINGLEMAP_TYPE_MASK 0x7F0000000000UL
3625 #define SINGLEMAP_oint_type_shift 40
3626 #define SINGLEMAP_WORKS 1
3627 #endif
3628 #if defined(UNIX_NETBSD) && defined(SPARC64) /* NetBSD/sparc64 */
3629 #define SINGLEMAP_ADDRESS_BASE 0UL
3630 #define SINGLEMAP_TYPE_MASK 0x07F000000000UL
3631 #define SINGLEMAP_oint_type_shift 36
3632 #define SINGLEMAP_WORKS 1
3633 #endif
3634 #if defined(UNIX_OPENBSD) && defined(AMD64) /* OpenBSD/x86_64 */
3635 #define SINGLEMAP_ADDRESS_BASE 0x200000000000UL
3636 #define SINGLEMAP_TYPE_MASK 0x5F0000000000UL
3637 #define SINGLEMAP_oint_type_shift 40
3638 /* Actually no such configuration works, because the CODE_ADDRESS_RANGE
3639 consumes so many bits that we have at most 2+1 bits for the typecode. */
3640 #define SINGLEMAP_WORKS 0
3641 #endif
3642 #if defined(UNIX_MACOSX) && defined(AMD64) /* Mac OS X/x86_64 */
3643 #define SINGLEMAP_ADDRESS_BASE 0UL
3644 #define SINGLEMAP_TYPE_MASK 0x7F0000000000UL
3645 #define SINGLEMAP_oint_type_shift 40
3646 #define SINGLEMAP_WORKS 1
3647 #endif
3648 #if defined(UNIX_AIX) && defined(POWERPC64) /* AIX/POWER with 64-bit ABI */
3649 #define SINGLEMAP_ADDRESS_BASE 0UL
3650 #define SINGLEMAP_TYPE_MASK 0x07F0000000000000UL
3651 #define SINGLEMAP_oint_type_shift 52
3652 #define SINGLEMAP_WORKS 1
3653 #endif
3654 #if defined(UNIX_HPUX) && defined(HPPA64) /* HP-UX/hppa64 */
3655 #define SINGLEMAP_ADDRESS_BASE 0x5000000000000000UL
3656 #define SINGLEMAP_TYPE_MASK 0x0FE0000000000000UL
3657 #define SINGLEMAP_oint_type_shift 53
3658 /* Set garcol_bit_o to 61. */
3659 #define SINGLEMAP_garcol_bit_o 61
3660 /* Does not work because mmap MAP_FIXED is not supported on this platform. */
3661 #define SINGLEMAP_WORKS 0
3662 #endif
3663 #if defined(UNIX_HPUX) && defined(IA64) /* HP-UX/ia64 */
3664 #define SINGLEMAP_ADDRESS_BASE 0x6000000000000000UL
3665 #define SINGLEMAP_TYPE_MASK 0x1FC0000000000000UL
3666 #define SINGLEMAP_oint_type_shift 54
3667 /* Actually no such configuration works, because the CODE_ADDRESS_RANGE
3668 consumes so many bits that we have at most 3+1 bits for the typecode. */
3669 #define SINGLEMAP_WORKS 0
3670 #endif
3671 #if defined(UNIX_SUNOS5) && defined(AMD64) /* Solaris/x86_64 */
3672 #define SINGLEMAP_ADDRESS_BASE 0UL
3673 #define SINGLEMAP_TYPE_MASK 0x00007F0000000000UL
3674 #define SINGLEMAP_oint_type_shift 40
3675 #define SINGLEMAP_WORKS 1
3676 #endif
3677 #if defined(UNIX_SUNOS5) && defined(SPARC64) /* Solaris/sparc64 */
3678 #define SINGLEMAP_ADDRESS_BASE 0UL
3679 #define SINGLEMAP_TYPE_MASK 0x00007F0000000000UL
3680 #define SINGLEMAP_oint_type_shift 40
3681 #define SINGLEMAP_WORKS 1
3682 #endif
3683 #if defined(UNIX_CYGWIN) && defined(AMD64) /* Cygwin */
3684 #define SINGLEMAP_ADDRESS_BASE 0UL
3685 #define SINGLEMAP_TYPE_MASK 0x03F800000000UL
3686 #define SINGLEMAP_oint_type_shift 35
3687 /* This configuration does not work: Compilation of compiler.lisp
3688 fails with "Cannot map memory to address 0x4800080000". */
3689 #define SINGLEMAP_WORKS 0
3690 #endif
3691 #ifndef SINGLEMAP_garcol_bit_o
3692 #define SINGLEMAP_garcol_bit_o 63
3693 #endif
3694 #define SINGLEMAP_oint_type_len (64-SINGLEMAP_oint_type_shift)
3695 #define SINGLEMAP_oint_type_mask (SINGLEMAP_TYPE_MASK | (1UL<<SINGLEMAP_garcol_bit_o))
3696 #endif
3697 #if defined(SINGLEMAP_ADDRESS_BASE) || defined(SINGLEMAP_TYPE_MASK) || defined(SINGLEMAP_WORKS)
3698 /* Verify that SINGLEMAP_ADDRESS_BASE, SINGLEMAP_TYPE_MASK, SINGLEMAP_oint_type_shift,
3699 SINGLEMAP_garcol_bit_o, SINGLEMAP_oint_type_len, SINGLEMAP_oint_type_mask
3700 are now defined. */
3701 #if !(defined(SINGLEMAP_ADDRESS_BASE) && defined(SINGLEMAP_TYPE_MASK) \
3702 && defined(SINGLEMAP_oint_type_shift) \
3703 && defined(SINGLEMAP_garcol_bit_o) \
3704 && defined(SINGLEMAP_oint_type_len) && defined(SINGLEMAP_oint_type_mask))
3705 #error SINGLEMAP_ADDRESS_BASE, SINGLEMAP_TYPE_MASK, SINGLEMAP_oint_type_shift, SINGLEMAP_garcol_bit_o, SINGLEMAP_oint_type_len, SINGLEMAP_oint_type_mask are not defined for this platform!
3706 #endif
3707 /* Verify that SINGLEMAP_ADDRESS_BASE is a multiple of 0x10000
3708 and therefore is guaranteed to be page-aligned. */
3709 #if (SINGLEMAP_ADDRESS_BASE & 0xFFFFUL) != 0
3710 #error SINGLEMAP_ADDRESS_BASE is not page-aligned!
3711 #endif
3712 /* Verify that SINGLEMAP_TYPE_MASK is disjoint to SINGLEMAP_ADDRESS_BASE. */
3713 #if (SINGLEMAP_TYPE_MASK & SINGLEMAP_ADDRESS_BASE) != 0
3714 #error SINGLEMAP_TYPE_MASK is not disjoint to SINGLEMAP_ADDRESS_BASE!
3715 #endif
3716 /* Verify that SINGLEMAP_TYPE_MASK contains only bits >= SINGLEMAP_oint_type_shift. */
3717 #if (SINGLEMAP_TYPE_MASK & ((1UL<<(SINGLEMAP_oint_type_shift))-1UL)) != 0
3718 #error SINGLEMAP_TYPE_MASK contains bits < SINGLEMAP_oint_type_shift!
3719 #endif
3720 /* Verify that SINGLEMAP_TYPE_MASK contains the bit SINGLEMAP_oint_type_shift. */
3721 #if (SINGLEMAP_TYPE_MASK & (1UL<<(SINGLEMAP_oint_type_shift))) == 0
3722 #error You can increase SINGLEMAP_oint_type_shift!
3723 #endif
3724 #endif
3725
3726 /* Verify the flags that determine the object representation that were defined
3727 by the user. */
3728
3729 #if defined(SINGLEMAP_MEMORY)
3730 /* SINGLEMAP_MEMORY implies TYPECODES. */
3731 #ifndef TYPECODES
3732 #define TYPECODES
3733 #endif
3734 #endif
3735
3736 #if defined(KERNELVOID32A_HEAPCODES) || defined(KERNELVOID32B_HEAPCODES)
3737 #ifndef KERNELVOID32_HEAPCODES
3738 #define KERNELVOID32_HEAPCODES
3739 #endif
3740 #endif
3741
3742 #if defined(GENERIC64A_HEAPCODES) || defined(GENERIC64B_HEAPCODES) || defined(GENERIC64C_HEAPCODES)
3743 #ifndef GENERIC64_HEAPCODES
3744 #define GENERIC64_HEAPCODES
3745 #endif
3746 #endif
3747
3748 #if defined(ONE_FREE_BIT_HEAPCODES) || defined(KERNELVOID32_HEAPCODES) || defined(GENERIC64_HEAPCODES)
3749 #ifndef HEAPCODES
3750 #define HEAPCODES
3751 #endif
3752 #endif
3753
3754 #if defined(WIDE_SOFT) && defined(HEAPCODES)
3755 #error WIDE_SOFT and HEAPCODES make no sense together, no need for WIDE_SOFT
3756 #endif
3757
3758 #if defined(TYPECODES) && defined(HEAPCODES)
3759 #error TYPECODES and HEAPCODES make no sense together
3760 #endif
3761
3762 /* Determine early whether to use SINGLEMAP_MEMORY, because the OS has
3763 restrictions on the mmapable addresses, and these restrictions have
3764 an influence on oint_type_shift and oint_type_len. */
3765 #if !defined(HEAPCODES) \
3766 && !defined(WIDE_SOFT) \
3767 && (defined(HAVE_MMAP_ANON) || defined(HAVE_MMAP_DEVZERO) \
3768 || defined(HAVE_MACH_VM) || defined(HAVE_WIN32_VM)) \
3769 && !defined(NO_ADDRESS_SPACE_ASSUMPTIONS) \
3770 && !defined(ADDRESS_RANGE_RANDOMIZED) \
3771 && defined(WIDE_HARD) \
3772 && defined(SINGLEMAP_WORKS) && SINGLEMAP_WORKS \
3773 && !defined(NO_SINGLEMAP)
3774 /* If we have not already excluded TYPECODES, and not WIDE_SOFT,
3775 and the OS has support for mmap or equivalent,
3776 and the OS does not use address space layout randomization [1]
3777 and we are on a 64-bit platform [2]
3778 and SINGLEMAP_MEMORY has been verified to work [3],
3779 then pick SINGLEMAP_MEMORY.
3780 [1] It does not work reliably when address space layout randomization
3781 is in effect: SINGLEMAP_MEMORY assumes that one can extend an existing
3782 memory region by mmapping the pages after it; but this might overwrite
3783 some small malloc regions that have been put there by the system.
3784 [2] On 32-bit platforms the resulting limit of 16 MB objects for each type
3785 is ridiculous today.
3786 [3] This is best tested by running one of
3787 make -f Makefile.devel build-porting64-gcc-spvw_pure_blocks
3788 make -f Makefile.devel build-porting64-cc-spvw_pure_blocks
3789 */
3790 /* Access to LISP-objects is made easier by putting each LISP-object
3791 to an address that already contains its type information. */
3792 #ifndef SINGLEMAP_MEMORY
3793 #define SINGLEMAP_MEMORY
3794 #endif
3795 /* SINGLEMAP_MEMORY implies TYPECODES. */
3796 #ifndef TYPECODES
3797 #define TYPECODES
3798 #endif
3799 #endif
3800
3801 /* Determine early whether to use TRIVIALMAP_MEMORY, because TRIVIALMAP_MEMORY
3802 (and, with it, TRIVIALMAP_MEMORY_STACK) constrain the addresses used for
3803 heap objects and for the stack and thus give more freedom for choosing
3804 oint_type_shift and oint_type_len. */
3805 #if (defined(HAVE_MMAP_ANON) || defined(HAVE_MMAP_DEVZERO) \
3806 || defined(HAVE_MACH_VM) || defined(HAVE_WIN32_VM)) \
3807 && !defined(SINGLEMAP_MEMORY) \
3808 && defined(MAPPABLE_ADDRESS_RANGE_START) \
3809 && defined(MAPPABLE_ADDRESS_RANGE_END) \
3810 && !defined(NO_ADDRESS_SPACE_ASSUMPTIONS) \
3811 && !(defined(UNIX_LINUX) && defined(M68K) && (defined(HEAPCODES) || defined(ONE_FREE_BIT_HEAPCODES))) \
3812 && !defined(UNIX_HAIKU) \
3813 && !defined(UNIX_CYGWIN) \
3814 && !defined(NO_TRIVIALMAP)
3815 /* mmap() allows for a more flexible way of memory management than malloc().
3816 It's not really memory-mapping, but a more comfortable way to manage two
3817 large memory blocks.
3818 But it requires that we know where to map the large memory blocks in the
3819 address range. It does not work reliably when address space layout
3820 randomization across the *entire* address space is in effect:
3821 TRIVIALMAP_MEMORY assumes that one can extend an existing memory region
3822 by mmapping the pages after it; but this might overwrite some small malloc
3823 regions that have been put there by the system.
3824 Also, it does not work on Linux/m68k when HEAPCODES is requested.
3825 Also, it does not work well on Haiku, where it sometimes produces messages
3826 such as "Cannot map memory to address 0x202a8000 ... Invalid Argument".
3827 Also, it does not work well on Cygwin, where it sometimes produces messages
3828 "Cannot map memory to address ...". */
3829 #ifndef TRIVIALMAP_MEMORY
3830 #define TRIVIALMAP_MEMORY
3831 #endif
3832 #endif
3833
3834
3835 #if !(defined(TYPECODES) || defined(HEAPCODES))
3836 /* Heuristic for choosing TYPECODES or HEAPCODES.
3837 The SINGLEMAP_MEMORY case is already handled above. */
3838 #if defined(WIDE_SOFT)
3839 #define TYPECODES
3840 #else
3841 #if !defined(WIDE_HARD)
3842 /* On 32-bit platforms:
3843 - TYPECODES: the resulting limit of 16 MB objects for each type,
3844 especially for conses, is ridiculous today.
3845 - HEAPCODES: a per-platform decision whether to use
3846 ONE_FREE_BIT_HEAPCODES or KERNELVOID32_HEAPCODES can be made
3847 (below).
3848 - Except that on ARM in -mthumb mode HEAPCODES produces the error
3849 "PSEUDOCODE_ALIGNMENT is not fulfilled". (-falign-functions has no
3850 effect on ARM.)
3851 - On Linux/m68k (with gcc-5.4), nearly all HEAPCODES variants crash.
3852 Choose HEAPCODES whenever it will work. */
3853 #if (defined(ARM) && defined(__thumb__)) \
3854 || (defined(UNIX_LINUX) && defined(M68K))
3855 /* On these platforms, HEAPCODES does not work. */
3856 #define TYPECODES
3857 #else
3858 #define HEAPCODES
3859 #endif
3860 #else
3861 /* On 64-bit platforms:
3862 - TYPECODES: There's enough room for type bits, unless the OS allocates
3863 memory at addresses >= 0x0100000000000000. This correlates with the
3864 expression MMAP_FIXED_ADDRESS_HIGHEST_BIT <= 55. In fact, the highest
3865 value of MMAP_FIXED_ADDRESS_HIGHEST_BIT seen so far is 52.
3866 - HEAPCODES: Both ONE_FREE_BIT_HEAPCODES and GENERIC64_HEAPCODES have
3867 alignment restrictions:
3868 ONE_FREE_BIT_HEAPCODES will normally not work if
3869 alignof(subr_t) = alignof(long) < 4, but with GCC we can force
3870 alignof(subr_t) = 4.
3871 GENERIC64_HEAPCODES likewise with alignment 8.
3872 Additionally some C functions must be aligned as well, see
3873 PSEUDOCODE_ALIGNMENT; this can be harder to achieve.
3874 TYPECODES is typically a few percent slower than HEAPCODES.
3875 So, use the following choice:
3876 - On platforms where compilers other than GCC (or clang, which is like
3877 GCC here) may be used, it is hard to fulfil the alignment constraint
3878 needed by HEAPCODES. Therefore favour TYPECODES on these platforms.
3879 Except where TYPECODES does not work, namely on AIX, HP-UX/hppa64,
3880 HP-UX/ia64, Solaris/x86_64 with cc, and Solaris/sparc64.
3881 - On platforms where we can assume GCC, both ONE_FREE_BIT_HEAPCODES and
3882 GENERIC64_HEAPCODES generally work well, with few exception. The
3883 choice between these two is done below. */
3884 #if defined(UNIX_AIX) || defined(UNIX_HPUX) || defined(UNIX_IRIX) || defined(UNIX_SUNOS5)
3885 /* A compiler other than GCC may be used. */
3886 #if (defined(UNIX_AIX) && defined(POWERPC64)) || (defined(UNIX_HPUX) && defined(HPPA64)) || (defined(UNIX_HPUX) && defined(IA64)) || (defined(UNIX_SUNOS5) && defined(AMD64) && !defined(GNU)) || (defined(UNIX_SUNOS5) && defined(SPARC64))
3887 /* On these platforms, TYPECODES (without SINGLEMAP_MEMORY) does not work. */
3888 #define HEAPCODES
3889 #else
3890 #define TYPECODES
3891 #endif
3892 #else
3893 #define HEAPCODES
3894 #endif
3895 #endif
3896 #endif
3897 #endif
3898 %% #ifdef HEAPCODES
3899 %% puts("#define HEAPCODES");
3900 %% #endif
3901
3902 #ifdef WIDE_SOFT
3903 #if defined(GNU) && !defined(WIDE_SOFT_LARGEFIXNUM)
3904 /* Use the GNU-C extensions, to regard the wide oints as structs. */
3905 #define WIDE_STRUCT
3906 #endif
3907 /* defines the arrangement of an oint's elements: */
3908 #define WIDE_ENDIANNESS true /* more efficient this way */
3909 #endif
3910
3911 #if defined(GNU) && (SAFETY >= 3)
3912 /* Typechecking by the C-compiler */
3913 #define OBJECT_STRUCT
3914 #if !(defined(M68K) || defined(ARM)) && !(defined(__GNUG__) && (__GNUC__ == 3) && (__GNUC_MINOR__ == 3)) /* only if struct_alignment==1, and not with g++ 3.3 */
3915 #define CHART_STRUCT
3916 #endif
3917 #endif
3918
3919 #if defined(DEBUG_GCSAFETY)
3920 #ifndef __cplusplus
3921 #error DEBUG_GCSAFETY works only with a C++ compiler! Reconfigure with CC=g++.
3922 #endif
3923 #if defined(WIDE_SOFT)
3924 #error DEBUG_GCSAFETY cannot be used together with WIDE_SOFT (not yet implemented)!
3925 #endif
3926 /* The 'gcv_object_t' and 'object' types share the major part of their innards. */
3927 #ifndef OBJECT_STRUCT
3928 #define OBJECT_STRUCT
3929 #endif
3930 #endif
3931
3932 /* The type 'object' denotes an object in registers or in memory that is
3933 not seen by the GC.
3934
3935 The type `gcv_object_t' denotes a GC visible object, i.e. a slot inside
3936 a heap-allocated object or a STACK slot. If its value is not an immediate
3937 object, any call that can trigger GC can modify the pointer value.
3938 NEVER write "var gcv_object_t foo;" - this is forbidden!
3939 You can write "var gcunsafe_object_t foo;" instead - but then you must not
3940 trigger GC during the entire lifetime of the variable 'foo'! */
3941
3942 %% #if (defined(OBJECT_STRUCT) || defined(WIDE_STRUCT)) && defined(WIDE) && !defined(WIDE_HARD) && defined(GENERATIONAL_GC)
3943 %% #define attribute_aligned_object " __attribute__ ((aligned(8)))"
3944 %% #else
3945 %% #define attribute_aligned_object ""
3946 %% #endif
3947
3948 #if !defined(WIDE_SOFT)
3949
3950 #if defined(OBJECT_STRUCT)
3951 #define INNARDS_OF_GCV_OBJECT \
3952 uintP one_o;
3953 #else
3954 typedef void * gcv_object_t;
3955 #endif
3956 /* There is an address and type bits in the representation. */
3957
3958 typedef uintP oint;
3959 typedef sintP soint;
3960
3961 #else /* defined(WIDE_SOFT) */
3962
3963 /* An object consists of a separated 32 bit address and a 32 bit type info. */
3964 typedef uint64 oint;
3965 typedef sint64 soint;
3966 #ifdef WIDE_STRUCT
3967 /* The struct around the union is needed to work around a gcc-2.95 bug. */
3968 #if BIG_ENDIAN_P==WIDE_ENDIANNESS
3969 #define INNARDS_OF_GCV_OBJECT \
3970 union { \
3971 struct { /* tint */ uintL type; /* aint */ uintL addr; } both; \
3972 oint one_u _attribute_aligned_object_; \
3973 } u _attribute_aligned_object_;
3974 #else
3975 #define INNARDS_OF_GCV_OBJECT \
3976 union { \
3977 struct { /* aint */ uintL addr; /* tint */ uintL type; } both; \
3978 oint one_u _attribute_aligned_object_; \
3979 } u _attribute_aligned_object_;
3980 #endif
3981 #define one_o u.one_u
3982 #else
3983 typedef oint gcv_object_t;
3984 #endif
3985
3986 #endif
3987
3988 /* sizeof(gcv_object_t) = sizeof(oint) must hold true! */
3989
3990 %% #if !defined(WIDE_SOFT)
3991 %% #if defined(OBJECT_STRUCT)
3992 %% #ifdef DEBUG_GCSAFETY
3993 %% puts("struct object { uintP one_o; uintL allocstamp; };");
3994 %% puts("struct gcv_object_t { uintP one_o; operator object () const; gcv_object_t (object obj); gcv_object_t (struct fake_gcv_object obj); gcv_object_t (); };");
3995 %% #else
3996 %% emit_typedef("struct { uintP one_o; }","gcv_object_t");
3997 %% #endif
3998 %% #else
3999 %% emit_typedef("void *","gcv_object_t");
4000 %% #endif
4001 %% emit_typedef("uintP","oint");
4002 %% emit_typedef("sintP","soint");
4003 %% #else
4004 %% emit_typedef("uint64","oint");
4005 %% emit_typedef("sint64","soint");
4006 %% #ifdef WIDE_STRUCT
4007 %% strcpy(buf,"struct { union {\n");
4008 %% #if BIG_ENDIAN_P==WIDE_ENDIANNESS
4009 %% strcat(buf," struct { /*tint*/ uintL type; /*aint*/ uintL addr; } both;\n");
4010 %% #else
4011 %% strcat(buf," struct { /*aint*/ uintL addr; /*tint*/ uintL type; } both;\n");
4012 %% #endif
4013 %% strcat(buf," oint one_u");
4014 %% strcat(buf,attribute_aligned_object);
4015 %% strcat(buf,"; } u");
4016 %% strcat(buf,attribute_aligned_object);
4017 %% strcat(buf,"; }");
4018 %% emit_typedef(buf,"gcv_object_t");
4019 %% emit_define("one_o","u.one_u");
4020 %% #else
4021 %% emit_typedef("oint","gcv_object_t");
4022 %% #endif
4023 %% #endif
4024
4025 /* conversion between gcv_object_t/object and oint:
4026 as_oint(expr) gcv_object_t/object --> oint
4027 as_object(x) oint --> gcv_object_t
4028 The conversion gcv_object_t --> object
4029 is implicit. */
4030 #if defined(WIDE_STRUCT) || defined(OBJECT_STRUCT)
4031 #define as_oint(expr) ((expr).one_o)
4032 #if defined(WIDE_STRUCT)
4033 #define as_object(o) ((object){designated_init(u,{designated_init(one_u,(o))})INIT_ALLOCSTAMP})
4034 #elif defined(OBJECT_STRUCT)
4035 #define as_object(o) ((object){designated_init(one_o,(o))INIT_ALLOCSTAMP})
4036 #else
4037 extern __inline__ object as_object (register oint o)
4038 { register object obj; obj.one_o = o; return obj; }
4039 #endif
4040 #else
4041 #define as_oint(expr) (oint)(expr)
4042 #define as_object(o) (gcv_object_t)(o)
4043 #endif
4044 %% export_def(as_oint(expr));
4045 %% export_def(as_object(o));
4046
4047 /* Separation of an oint in type bits and address:
4048 oint_type_mask is always subset of (2^oint_type_len-1)<<oint_type_shift
4049 and
4050 oint_addr_mask is a superset of (2^oint_addr_len-1)<<oint_addr_shift . */
4051 #if !defined(TYPECODES)
4052 /* HEAPCODES model:
4053 For pointers, the address takes the full word (with type info in the
4054 lowest two bits). For immediate objects, we use 24 bits for the data
4055 (but exclude the highest available bit, which is the garcol_bit). */
4056 #if !(defined(ONE_FREE_BIT_HEAPCODES) || defined(KERNELVOID32_HEAPCODES) || defined(GENERIC64_HEAPCODES))
4057 /* Choose the appropriate HEAPCODES variant for the machine.
4058 On 32-bit platforms:
4059 - On platforms where compilers other than GCC (or clang, which is like
4060 GCC here) may be used, it is hard to fulfil the 8-byte alignment
4061 constraint needed for KERNELVOID32_HEAPCODES. Therefore favour
4062 ONE_FREE_BIT_HEAPCODES on these platforms.
4063 - On platforms where we can assume GCC, KERNELVOID32_HEAPCODES generally
4064 works well. There are few exceptions to this rule. (Whereas there are
4065 more platforms where ONE_FREE_BIT_HEAPCODES does not work, especially
4066 when not using TRIVIALMAP_MEMORY.)
4067 On 64-bit platforms:
4068 On most platforms, ONE_FREE_BIT_HEAPCODES and GENERIC64_HEAPCODES
4069 work equally well. I prefer ONE_FREE_BIT_HEAPCODES because it
4070 does not impose alignment restrictions on pointers.
4071 The exception are special cases where ONE_FREE_BIT_HEAPCODES is
4072 known to not work. */
4073 #if !defined(WIDE_HARD)
4074 /* 32-bit platforms */
4075 #if defined(UNIX_AIX) || defined(UNIX_HPUX) || defined(UNIX_IRIX) || defined(UNIX_SUNOS5)
4076 /* A compiler other than GCC may be used. */
4077 #define ONE_FREE_BIT_HEAPCODES
4078 #elif (defined(UNIX_CYGWIN) && defined(I80386))
4079 /* On these platforms, KERNELVOID32_HEAPCODES does not work. */
4080 #define ONE_FREE_BIT_HEAPCODES
4081 #else
4082 #define KERNELVOID32_HEAPCODES
4083 #endif
4084 #else
4085 /* 64-bit platforms */
4086 #if defined(NO_ADDRESS_SPACE_ASSUMPTIONS)
4087 /* With GENERIC64_HEAPCODES we don't need to make assumptions about the
4088 address range. */
4089 #define GENERIC64_HEAPCODES
4090 #elif (defined(UNIX_LINUX) && defined(S390_64))
4091 /* On these platforms, ONE_FREE_BIT_HEAPCODES does not generally work. */
4092 #define GENERIC64_HEAPCODES
4093 #else
4094 /* The general case. */
4095 #define ONE_FREE_BIT_HEAPCODES
4096 #endif
4097 #endif
4098 #endif
4099 #ifdef ONE_FREE_BIT_HEAPCODES
4100 /* The portable case. Assumes only that the GC bit can be chosen. */
4101 /* To determine HEAPCODES1BIT_WITH_TRIVIALMAP_WORKS, run one of
4102 make -f Makefile.devel build-porting32-gcc-one_free_bit_heapcodes-trivialmap
4103 make -f Makefile.devel build-porting32-cc-one_free_bit_heapcodes-trivialmap
4104 make -f Makefile.devel build-porting64-gcc-one_free_bit_heapcodes-trivialmap
4105 make -f Makefile.devel build-porting64-cc-one_free_bit_heapcodes-trivialmap
4106 To determine HEAPCODES1BIT_WITH_MALLOC_WORKS, run one of
4107 make -f Makefile.devel build-porting32-gcc-one_free_bit_heapcodes-malloc
4108 make -f Makefile.devel build-porting32-cc-one_free_bit_heapcodes-malloc
4109 make -f Makefile.devel build-porting64-gcc-one_free_bit_heapcodes-malloc
4110 make -f Makefile.devel build-porting64-cc-one_free_bit_heapcodes-malloc
4111 */
4112 #if !defined(WIDE_HARD)
4113 /* 32-bit platforms */
4114 #if defined(UNIX_LINUX) && defined(AMD64) /* Linux/x86_64 with 32-bit x32 ABI */
4115 #define HEAPCODES1BIT_WITH_TRIVIALMAP_WORKS 1
4116 #if !defined(TRIVIALMAP_MEMORY)
4117 /* Avoid error
4118 "STACK range (around 0xf6a94080) contains the bit used to identify frames". */
4119 #define garcol_bit_o 27
4120 #endif
4121 #define HEAPCODES1BIT_WITH_MALLOC_WORKS 1
4122 #endif
4123 #if defined(UNIX_LINUX) && defined(ARM) /* Linux/arm */
4124 #define HEAPCODES1BIT_WITH_TRIVIALMAP_WORKS 1
4125 #if !defined(TRIVIALMAP_MEMORY)
4126 /* Avoid error
4127 "STACK range (around 0xb6c8a040) contains the bit used to identify frames". */
4128 #define garcol_bit_o 27
4129 #endif
4130 #define HEAPCODES1BIT_WITH_MALLOC_WORKS 1
4131 #endif
4132 #if defined(UNIX_LINUX) && defined(HPPA) /* Linux/hppa */
4133 #define HEAPCODES1BIT_WITH_TRIVIALMAP_WORKS 1 /* but only without GENERATIONAL_GC */
4134 #if !defined(TRIVIALMAP_MEMORY)
4135 /* Avoid error
4136 "STACK range (around 0xf65ff080) contains the bit used to identify frames". */
4137 #define garcol_bit_o 27
4138 #endif
4139 #define HEAPCODES1BIT_WITH_MALLOC_WORKS 1
4140 #endif
4141 #if defined(UNIX_LINUX) && defined(I80386) /* Linux/i386, Linux/x86_64 with 32-bit i386 ABI */
4142 #define HEAPCODES1BIT_WITH_TRIVIALMAP_WORKS 1
4143 #if !defined(TRIVIALMAP_MEMORY)
4144 /* We get the error
4145 "STACK range (around 0xf71b2040) contains the bit used to identify frames"
4146 or warnings
4147 "Return value of malloc() = f71fe008 is not compatible with the choice of garcol_bit_o."
4148 The only way to avoid it would be to #define garcol_bit_o 27,
4149 but that conflicts with CODE_ADDRESS_RANGE. */
4150 #endif
4151 #define HEAPCODES1BIT_WITH_MALLOC_WORKS 0 /* sometimes 0, sometimes 1 */
4152 #endif
4153 #if defined(UNIX_LINUX) && defined(M68K) /* Linux/m68k */
4154 /* Crashes, regardless of garcol_bit_o and imm_type_shift values. */
4155 #define HEAPCODES1BIT_WITH_TRIVIALMAP_WORKS 0 /* even without GENERATIONAL_GC */
4156 #if !defined(TRIVIALMAP_MEMORY)
4157 /* Avoid error
4158 "STACK range (around 0xf65ff040) contains the bit used to identify frames". */
4159 #define garcol_bit_o 27
4160 #endif
4161 #define HEAPCODES1BIT_WITH_MALLOC_WORKS 1
4162 #endif
4163 #if defined(UNIX_LINUX) && (defined(MIPS) || defined(MIPS64)) /* Linux/mips with o32 or n32 ABI */
4164 #if !(_MIPS_SIM == _ABIN32) /* Linux/mips with o32 ABI */
4165 #define HEAPCODES1BIT_WITH_TRIVIALMAP_WORKS 1
4166 #define HEAPCODES1BIT_WITH_MALLOC_WORKS 1
4167 #else /* Linux/mips with n32 ABI */
4168 #define HEAPCODES1BIT_WITH_TRIVIALMAP_WORKS 1
4169 #define HEAPCODES1BIT_WITH_MALLOC_WORKS 1
4170 #endif
4171 #endif
4172 #if defined(UNIX_LINUX) && defined(POWERPC) /* Linux/powerpc64 with 32-bit ABI */
4173 #define HEAPCODES1BIT_WITH_TRIVIALMAP_WORKS 1
4174 #if !defined(TRIVIALMAP_MEMORY)
4175 /* Avoid error
4176 "STACK range (around 0xf7860040) contains the bit used to identify frames". */
4177 #define garcol_bit_o 27
4178 #endif
4179 #define HEAPCODES1BIT_WITH_MALLOC_WORKS 1
4180 #endif
4181 #if defined(UNIX_LINUX) && defined(S390) /* Linux/s390x with 32-bit ABI */
4182 #define HEAPCODES1BIT_WITH_TRIVIALMAP_WORKS 1
4183 #define HEAPCODES1BIT_WITH_MALLOC_WORKS 1
4184 #endif
4185 #if defined(UNIX_LINUX) && defined(SPARC) /* Linux/sparc64 with 32-bit ABI */
4186 #define HEAPCODES1BIT_WITH_TRIVIALMAP_WORKS 1
4187 #if !defined(TRIVIALMAP_MEMORY)
4188 /* Avoid error
4189 "STACK range (around 0xf7a9a080) contains the bit used to identify frames" */
4190 #define garcol_bit_o 27
4191 #endif
4192 #define HEAPCODES1BIT_WITH_MALLOC_WORKS 1
4193 #endif
4194 #if defined(UNIX_HURD) && defined(I80386) /* Hurd/i386 */
4195 #define HEAPCODES1BIT_WITH_TRIVIALMAP_WORKS 1
4196 #define HEAPCODES1BIT_WITH_MALLOC_WORKS 1
4197 #endif
4198 #if (defined(__FreeBSD__) || defined(UNIX_GNU_FREEBSD) || defined(__DragonFly__)) && defined(I80386) /* FreeBSD/i386, GNU/kFreeBSD/i386, DragonFly/i386 */
4199 #define HEAPCODES1BIT_WITH_TRIVIALMAP_WORKS 1
4200 #define HEAPCODES1BIT_WITH_MALLOC_WORKS 1
4201 #endif
4202 #if defined(UNIX_NETBSD) && defined(I80386) /* NetBSD/i386 */
4203 #define HEAPCODES1BIT_WITH_TRIVIALMAP_WORKS 1 /* but only without GENERATIONAL_GC */
4204 #if !defined(TRIVIALMAP_MEMORY)
4205 /* Avoid error
4206 "STACK range (around 0xbb800000) contains the bit used to identify frames". */
4207 #define garcol_bit_o 30
4208 #endif
4209 #define HEAPCODES1BIT_WITH_MALLOC_WORKS 1
4210 #endif
4211 #if defined(UNIX_NETBSD) && defined(SPARC) /* NetBSD/sparc */
4212 #define HEAPCODES1BIT_WITH_TRIVIALMAP_WORKS 1 /* but only without GENERATIONAL_GC */
4213 #if !defined(TRIVIALMAP_MEMORY)
4214 /* Avoid error
4215 "STACK range (around 0xedb00000) contains the bit used to identify frames". */
4216 #define garcol_bit_o 28
4217 #endif
4218 #define HEAPCODES1BIT_WITH_MALLOC_WORKS 1
4219 #endif
4220 #if defined(UNIX_OPENBSD) && defined(I80386) /* OpenBSD/i386 */
4221 #define HEAPCODES1BIT_WITH_TRIVIALMAP_WORKS 1 /* but only without GENERATIONAL_GC */
4222 #define HEAPCODES1BIT_WITH_MALLOC_WORKS 0
4223 #endif
4224 #if defined(UNIX_MACOSX) && defined(I80386) /* Mac OS X/x86_64 with 32-bit ABI */
4225 #define HEAPCODES1BIT_WITH_TRIVIALMAP_WORKS 1
4226 #define HEAPCODES1BIT_WITH_MALLOC_WORKS 1
4227 #endif
4228 #if defined(UNIX_MACOSX) && defined(POWERPC) /* Mac OS X/PowerPC */
4229 #define HEAPCODES1BIT_WITH_TRIVIALMAP_WORKS 1
4230 #define HEAPCODES1BIT_WITH_MALLOC_WORKS 1
4231 #endif
4232 #if defined(UNIX_AIX) && defined(POWERPC) /* AIX/POWER with 32-bit ABI */
4233 #define HEAPCODES1BIT_WITH_TRIVIALMAP_WORKS 1
4234 #define HEAPCODES1BIT_WITH_MALLOC_WORKS 1
4235 #endif
4236 #if defined(UNIX_HPUX) && defined(HPPA) /* HP-UX/hppa with 32-bit ABI */
4237 /* Does not work because mmap MAP_FIXED is not supported on this platform. */
4238 #define HEAPCODES1BIT_WITH_TRIVIALMAP_WORKS 0
4239 #define HEAPCODES1BIT_WITH_MALLOC_WORKS 1
4240 #endif
4241 #if defined(UNIX_HPUX) && defined(IA64) /* HP-UX/ia64 with 32-bit ABI */
4242 /* Does not work because mmap MAP_FIXED is not supported on this platform. */
4243 #define HEAPCODES1BIT_WITH_TRIVIALMAP_WORKS 0
4244 #define HEAPCODES1BIT_WITH_MALLOC_WORKS 1
4245 #endif
4246 #if defined(UNIX_IRIX) && (defined(MIPS) || defined(MIPS64)) /* IRIX 6.5 with o32 or n32 ABI */
4247 #if !(_MIPS_SIM == _ABIN32) /* IRIX 6.5 with o32 ABI */
4248 #define HEAPCODES1BIT_WITH_TRIVIALMAP_WORKS 1
4249 #define HEAPCODES1BIT_WITH_MALLOC_WORKS 1
4250 #else /* IRIX 6.5 with n32 ABI */
4251 #define HEAPCODES1BIT_WITH_TRIVIALMAP_WORKS 1
4252 #define HEAPCODES1BIT_WITH_MALLOC_WORKS 1
4253 #endif
4254 #endif
4255 #if defined(UNIX_SUNOS5) && defined(I80386) /* Solaris/x86_64 with 32-bit ABI */
4256 #define HEAPCODES1BIT_WITH_TRIVIALMAP_WORKS 1
4257 #define HEAPCODES1BIT_WITH_MALLOC_WORKS 1
4258 #endif
4259 #if defined(UNIX_SUNOS5) && defined(SPARC) /* Solaris/sparc64 with 32-bit ABI */
4260 #define HEAPCODES1BIT_WITH_TRIVIALMAP_WORKS 1
4261 #define HEAPCODES1BIT_WITH_MALLOC_WORKS 1
4262 #endif
4263 #if defined(UNIX_HAIKU) && defined(I80386) /* Haiku/i386 */
4264 /* Sometimes we get repeated messages such as
4265 "Cannot map memory to address 0x202a8000 ... Invalid Argument" */
4266 #define HEAPCODES1BIT_WITH_TRIVIALMAP_WORKS 0
4267 #define HEAPCODES1BIT_WITH_MALLOC_WORKS 1
4268 #endif
4269 #if defined(UNIX_MINIX) && defined(I80386) /* Minix/i386 */
4270 #define HEAPCODES1BIT_WITH_TRIVIALMAP_WORKS 1
4271 #define HEAPCODES1BIT_WITH_MALLOC_WORKS 1
4272 #endif
4273 #if defined(UNIX_CYGWIN) && defined(I80386) /* Cygwin, running on Windows 10 */
4274 /* Warns "clisp might crash later" and
4275 produces messages "Cannot map memory to address". */
4276 #define HEAPCODES1BIT_WITH_TRIVIALMAP_WORKS 0
4277 #define HEAPCODES1BIT_WITH_MALLOC_WORKS 1
4278 #endif
4279 #if defined(WIN32_NATIVE) && defined(I80386) /* mingw, running on Windows 10 */
4280 #define HEAPCODES1BIT_WITH_TRIVIALMAP_WORKS 1
4281 #define HEAPCODES1BIT_WITH_MALLOC_WORKS 1
4282 #endif
4283 #ifndef garcol_bit_o
4284 #define garcol_bit_o 31
4285 #endif
4286 /* Choose imm_type_shift depending on garcol_bit_o. */
4287 #if garcol_bit_o >= 30
4288 #define imm_type_shift 3
4289 #elif garcol_bit_o >= 27 && garcol_bit_o <= 28
4290 #define imm_type_shift (garcol_bit_o+1)
4291 #else
4292 #error No way to define imm_type_shift, satisfying the constraints!
4293 #endif
4294 #else
4295 /* 64-bit platforms */
4296 #if defined(UNIX_LINUX) && defined(AMD64) /* Linux/x86_64 */
4297 #define HEAPCODES1BIT_WITH_TRIVIALMAP_WORKS 1
4298 #define HEAPCODES1BIT_WITH_MALLOC_WORKS 1
4299 #endif
4300 #if defined(UNIX_LINUX) && defined(ARM64) /* Linux/arm64 */
4301 #define HEAPCODES1BIT_WITH_TRIVIALMAP_WORKS 1
4302 #define HEAPCODES1BIT_WITH_MALLOC_WORKS 1
4303 #endif
4304 #if defined(UNIX_LINUX) && defined(DECALPHA) /* Linux/alpha */
4305 #define HEAPCODES1BIT_WITH_TRIVIALMAP_WORKS 1
4306 #define HEAPCODES1BIT_WITH_MALLOC_WORKS 1
4307 #endif
4308 #if defined(UNIX_LINUX) && defined(IA64) /* Linux/ia64 */
4309 #define HEAPCODES1BIT_WITH_TRIVIALMAP_WORKS 1
4310 #define HEAPCODES1BIT_WITH_MALLOC_WORKS 1
4311 #endif
4312 #if defined(UNIX_LINUX) && defined(MIPS64) /* Linux/mips with 64-bit ABI */
4313 #define HEAPCODES1BIT_WITH_TRIVIALMAP_WORKS 1
4314 #define HEAPCODES1BIT_WITH_MALLOC_WORKS 1
4315 #endif
4316 #if defined(UNIX_LINUX) && defined(POWERPC64) /* Linux/powerpc64, Linux/powerpc64le */
4317 #define HEAPCODES1BIT_WITH_TRIVIALMAP_WORKS 1
4318 #define HEAPCODES1BIT_WITH_MALLOC_WORKS 1
4319 #endif
4320 #if defined(UNIX_LINUX) && defined(RISCV64) /* Linux/riscv64 */
4321 #define HEAPCODES1BIT_WITH_TRIVIALMAP_WORKS 1
4322 #define HEAPCODES1BIT_WITH_MALLOC_WORKS 1
4323 #endif
4324 #if defined(UNIX_LINUX) && defined(S390_64) /* Linux/s390x */
4325 #define HEAPCODES1BIT_WITH_TRIVIALMAP_WORKS 1 /* but only with(!) GENERATIONAL_GC */
4326 #define HEAPCODES1BIT_WITH_MALLOC_WORKS 0
4327 #endif
4328 #if defined(UNIX_LINUX) && defined(SPARC64) /* Linux/sparc64 */
4329 #define HEAPCODES1BIT_WITH_TRIVIALMAP_WORKS 1
4330 #if !defined(TRIVIALMAP_MEMORY)
4331 /* Avoid error
4332 "STACK range (around 0xfff800010098c080) contains the bit used to identify frames"
4333 or
4334 "STACK range (around 0xfffff8010049a080) contains the bit used to identify frames". */
4335 #define garcol_bit_o 42
4336 #define imm_type_shift 3
4337 #define oint_data_len 36
4338 #endif
4339 #define HEAPCODES1BIT_WITH_MALLOC_WORKS 1
4340 #endif
4341 #if (defined(UNIX_FREEBSD) || defined(UNIX_GNU_FREEBSD)) && defined(AMD64) /* FreeBSD/x86_64, GNU/kFreeBSD/x86_64 */
4342 #define HEAPCODES1BIT_WITH_TRIVIALMAP_WORKS 1
4343 #define HEAPCODES1BIT_WITH_MALLOC_WORKS 1
4344 #endif
4345 #if defined(UNIX_FREEBSD) && defined(ARM64) /* FreeBSD/arm64 */
4346 #define HEAPCODES1BIT_WITH_TRIVIALMAP_WORKS 1
4347 #define HEAPCODES1BIT_WITH_MALLOC_WORKS 1
4348 #endif
4349 #if defined(UNIX_NETBSD) && defined(AMD64) /* NetBSD/x86_64 */
4350 #define HEAPCODES1BIT_WITH_TRIVIALMAP_WORKS 1
4351 #define HEAPCODES1BIT_WITH_MALLOC_WORKS 1
4352 #endif
4353 #if defined(UNIX_NETBSD) && defined(SPARC64) /* NetBSD/sparc64 */
4354 #define HEAPCODES1BIT_WITH_TRIVIALMAP_WORKS ?
4355 #define HEAPCODES1BIT_WITH_MALLOC_WORKS ?
4356 #endif
4357 #if defined(UNIX_OPENBSD) && defined(AMD64) /* OpenBSD/x86_64 */
4358 #define HEAPCODES1BIT_WITH_TRIVIALMAP_WORKS 1
4359 #define HEAPCODES1BIT_WITH_MALLOC_WORKS 1
4360 #endif
4361 #if defined(UNIX_MACOSX) && defined(AMD64) /* Mac OS X/x86_64 */
4362 #define HEAPCODES1BIT_WITH_TRIVIALMAP_WORKS 1
4363 #define HEAPCODES1BIT_WITH_MALLOC_WORKS 1
4364 #endif
4365 #if defined(UNIX_AIX) && defined(POWERPC64) /* AIX/POWER with 64-bit ABI */
4366 #define HEAPCODES1BIT_WITH_TRIVIALMAP_WORKS 1
4367 #define HEAPCODES1BIT_WITH_MALLOC_WORKS 1
4368 #endif
4369 #if defined(UNIX_HPUX) && defined(HPPA64) /* HP-UX/hppa64 */
4370 /* Does not work because mmap MAP_FIXED is not supported on this platform. */
4371 #define HEAPCODES1BIT_WITH_TRIVIALMAP_WORKS 0
4372 #if !defined(TRIVIALMAP_MEMORY)
4373 /* Avoid error
4374 "STACK range (around 0x8000000100060980) contains the bit used to identify frames"
4375 and error
4376 "Wrong choice of garcol_bit_o: it conflicts with CODE_ADDRESS_RANGE!" */
4377 #define garcol_bit_o 61
4378 #endif
4379 #define HEAPCODES1BIT_WITH_MALLOC_WORKS 1
4380 #endif
4381 #if defined(UNIX_HPUX) && defined(IA64) /* HP-UX/ia64 */
4382 /* Does not work because mmap MAP_FIXED is not supported on this platform. */
4383 #define HEAPCODES1BIT_WITH_TRIVIALMAP_WORKS 0
4384 #if !defined(TRIVIALMAP_MEMORY)
4385 /* Avoid error
4386 "Return value of malloc() = 6000000000069490 is not compatible with the choice of garcol_bit_o." */
4387 #define garcol_bit_o 60
4388 #endif
4389 #define HEAPCODES1BIT_WITH_MALLOC_WORKS 1
4390 #endif
4391 #if defined(UNIX_SUNOS5) && defined(AMD64) /* Solaris/x86_64 */
4392 #define HEAPCODES1BIT_WITH_TRIVIALMAP_WORKS 1
4393 #define HEAPCODES1BIT_WITH_MALLOC_WORKS 1
4394 #endif
4395 #if defined(UNIX_SUNOS5) && defined(SPARC64) /* Solaris/sparc64 */
4396 #define HEAPCODES1BIT_WITH_TRIVIALMAP_WORKS 1
4397 #define HEAPCODES1BIT_WITH_MALLOC_WORKS 1
4398 #endif
4399 #if defined(UNIX_CYGWIN) && defined(AMD64) /* Cygwin */
4400 /* Produces messages "Cannot map memory to address". */
4401 #define HEAPCODES1BIT_WITH_TRIVIALMAP_WORKS 0
4402 /* Crashes. */
4403 #define HEAPCODES1BIT_WITH_MALLOC_WORKS 0
4404 #endif
4405 #ifndef garcol_bit_o
4406 #define garcol_bit_o 63
4407 #endif
4408 #endif
4409 #if 0 /* old */
4410 #if (defined(M68K) && defined(UNIX_LINUX)) || (defined(SPARC) && defined(UNIX_LINUX) && (__GLIBC__ < 2 || (__GLIBC__ == 2 && __GLIBC_MINOR__ < 2)))
4411 /* On Sparc-Linux with glibc 2.1 and older:
4412 malloc()ed addresses are of the form 0x0....... or 0xe........
4413 Bits 31..29 are therefore part of an address and cannot
4414 be used as garcol_bit. We therefore choose bit 28 as garcol_bit.
4415 Now, the 24 data bits of an immediate value must not intersect the
4416 garcol_bit, so we use bits 27..4 for that (we could use bits 26..3
4417 as well).
4418 On m68k-Linux, malloc()ed addresses are of the form 0x80...... or
4419 0xc0....... Bits 31..30 are therefore part of an address and cannot
4420 be used as garcol_bit. We therefore have three choices:
4421 data bits: bits 26..3, garcol_bit_o = 28/27
4422 data bits: bits 27..4, garcol_bit_o = 28/3
4423 data bits: bits 28..5, garcol_bit_o = 4/3 */
4424 #define garcol_bit_o 28
4425 #define imm_type_shift 29
4426 #endif
4427 #endif
4428 /* The first type field consists of bits 2,1,0. */
4429 #define oint_type_shift 0
4430 /* Immediate objects have a second type field,
4431 consisting of the bits imm_type_shift+2,...,imm_type_shift. */
4432 #ifndef imm_type_shift
4433 #define imm_type_shift 3
4434 #endif
4435 #if !((imm_type_shift >= 3) && (imm_type_shift+3 <= pointer_bitsize))
4436 #error Wrong choice of imm_type_shift!
4437 #endif
4438 /* Which bits to use for the type of an object. */
4439 #if (imm_type_shift == 3)
4440 #define oint_type_len 8
4441 #define oint_type_mask (bit(6)-1)
4442 #else
4443 #define oint_type_len pointer_bitsize
4444 #define oint_type_mask ((7UL << imm_type_shift) | 7UL)
4445 #endif
4446 /* Which bits to use for the data of an immediate object. */
4447 #ifndef oint_data_len
4448 #if (pointer_bitsize==64)
4449 #define oint_data_len 48
4450 #else
4451 #define oint_data_len 24
4452 #endif
4453 #endif
4454 #if (imm_type_shift == 3)
4455 #define oint_data_shift 6 /* or 7 */
4456 #else
4457 #define oint_data_shift 3
4458 #endif
4459 #define oint_data_mask (bit(oint_data_len+oint_data_shift)-bit(oint_data_shift))
4460 /* Some basic checks, */
4461 #if !(garcol_bit_o >= oint_data_len+oint_data_shift)
4462 #error Incompatible choices of garcol_bit_o and oint_data_len, oint_data_shift!
4463 #endif
4464 #if !((garcol_bit_o < imm_type_shift) || (garcol_bit_o >= imm_type_shift+3))
4465 #error Incompatible choices of garcol_bit_o and imm_type_shift!
4466 #endif
4467 #if !((oint_data_len+oint_data_shift <= imm_type_shift) || (oint_data_shift >= imm_type_shift+3))
4468 #error Incompatible choices of oint_data_shift and imm_type_shift!
4469 #endif
4470 /* subr_tab (= subr_tab_data) and symbol_tab (= symbol_tab_data) must be at
4471 addresses that don't contain the garcol_bit_o, otherwise the GC mark
4472 phase crashes because of the GCself pointers in the subrs and symbols. */
4473 #if ((CODE_ADDRESS_RANGE >> garcol_bit_o) & 1) != 0
4474 #error Wrong choice of garcol_bit_o: it conflicts with CODE_ADDRESS_RANGE!
4475 #endif
4476 #endif /* ONE_FREE_BIT_HEAPCODES */
4477 #ifdef KERNELVOID32_HEAPCODES
4478 #if !(defined(KERNELVOID32A_HEAPCODES) || defined(KERNELVOID32B_HEAPCODES))
4479 #if (defined(UNIX_LINUX) && defined(ARM)) \
4480 || (defined(UNIX_LINUX) && defined(I80386)) \
4481 || (defined(UNIX_SUNOS5) && defined(I80386))
4482 /* On these platforms, STACK_ADDRESS_RANGE is not always in the same
4483 area. But it's always either < 0xC0000000UL or >= 0xE0000000UL. */
4484 #define KERNELVOID32A_HEAPCODES
4485 #else
4486 /* On all other platforms, STACK_ADDRESS_RANGE is always in the same
4487 area. */
4488 #if STACK_ADDRESS_RANGE < 0xC0000000UL || STACK_ADDRESS_RANGE >= 0xE0000000UL
4489 #define KERNELVOID32A_HEAPCODES
4490 #else
4491 #define KERNELVOID32B_HEAPCODES
4492 #endif
4493 #endif
4494 #endif
4495 #if defined(KERNELVOID32A_HEAPCODES) || defined(KERNELVOID32B_HEAPCODES)
4496 /* KERNELVOID32A_HEAPCODES:
4497 The Linux/32-bit case. Assumes
4498 1. that the virtual memory addresses end at 0xC0000000, or at least
4499 that we can put a black hole on the range 0xC0000000..0xDFFFFFFF,
4500 2. that the compiler and linker can enforce an 8-byte alignment of
4501 symbol_tab and subr_tab.
4502 Only bit 0 or 1 can be used as GC-bit.
4503 KERNELVOID32B_HEAPCODES:
4504 The OpenBSD/i386 case. Assumes
4505 1. that the virtual memory addresses end at 0xE0000000, or at least
4506 that we can put a black hole on the range 0xE0000000..0xFFFFFFFF,
4507 2. that the compiler and linker can enforce an 8-byte alignment of
4508 symbol_tab and subr_tab.
4509 Only bit 0 or 1 can be used as GC-bit. */
4510 #define oint_type_shift 0
4511 #define oint_type_len 32
4512 #define oint_type_mask 0xE000001FUL
4513 #define oint_data_shift 5
4514 #define oint_data_len 24
4515 #define oint_data_mask 0x1FFFFFE0UL
4516 #define garcol_bit_o 0
4517 #endif
4518 /* Here we note whether KERNELVOID32_HEAPCODES actually works,
4519 for each 32-bit platform.
4520 To determine KERNELVOID32_HEAPCODES_WORKS, run one of
4521 make -f Makefile.devel build-porting32-gcc-kernelvoid32_heapcodes
4522 make -f Makefile.devel build-porting32-cc-kernelvoid32_heapcodes
4523 */
4524 #if defined(UNIX_LINUX) && defined(AMD64) /* Linux/x86_64 with 32-bit x32 ABI */
4525 #define KERNELVOID32_HEAPCODES_WORKS 1
4526 #endif
4527 #if defined(UNIX_LINUX) && defined(ARM) /* Linux/arm */
4528 #define KERNELVOID32_HEAPCODES_WORKS 1
4529 #endif
4530 #if defined(UNIX_LINUX) && defined(HPPA) /* Linux/hppa */
4531 #define KERNELVOID32_HEAPCODES_WORKS 1 /* without GENERATIONAL_GC */
4532 #endif
4533 #if defined(UNIX_LINUX) && defined(I80386) /* Linux/i386, Linux/x86_64 with 32-bit i386 ABI */
4534 #define KERNELVOID32_HEAPCODES_WORKS 1
4535 #endif
4536 #if defined(UNIX_LINUX) && defined(M68K) /* Linux/m68k */
4537 #define KERNELVOID32_HEAPCODES_WORKS 1 /* without GENERATIONAL_GC */
4538 #endif
4539 #if defined(UNIX_LINUX) && (defined(MIPS) || defined(MIPS64)) /* Linux/mips with o32 or n32 ABI */
4540 #if !(_MIPS_SIM == _ABIN32) /* Linux/mips with o32 ABI */
4541 #define KERNELVOID32_HEAPCODES_WORKS 1
4542 #else /* Linux/mips with n32 ABI */
4543 #define KERNELVOID32_HEAPCODES_WORKS 1
4544 #endif
4545 #endif
4546 #if defined(UNIX_LINUX) && defined(POWERPC) /* Linux/powerpc64 with 32-bit ABI */
4547 #define KERNELVOID32_HEAPCODES_WORKS 1
4548 #endif
4549 #if defined(UNIX_LINUX) && defined(S390) /* Linux/s390x with 32-bit ABI */
4550 #define KERNELVOID32_HEAPCODES_WORKS 1
4551 #endif
4552 #if defined(UNIX_LINUX) && defined(SPARC) /* Linux/sparc64 with 32-bit ABI */
4553 #define KERNELVOID32_HEAPCODES_WORKS 1
4554 #endif
4555 #if defined(UNIX_HURD) && defined(I80386) /* Hurd/i386 */
4556 #define KERNELVOID32_HEAPCODES_WORKS 1
4557 #endif
4558 #if (defined(__FreeBSD__) || defined(UNIX_GNU_FREEBSD) || defined(__DragonFly__)) && defined(I80386) /* FreeBSD/i386, GNU/kFreeBSD/i386, DragonFly/i386 */
4559 #define KERNELVOID32_HEAPCODES_WORKS 1
4560 #endif
4561 #if defined(UNIX_NETBSD) && defined(I80386) /* NetBSD/i386 */
4562 #define KERNELVOID32_HEAPCODES_WORKS 1
4563 #endif
4564 #if defined(UNIX_NETBSD) && defined(SPARC) /* NetBSD/sparc */
4565 #define KERNELVOID32_HEAPCODES_WORKS 1 /* without GENERATIONAL_GC */
4566 #endif
4567 #if defined(UNIX_OPENBSD) && defined(I80386) /* OpenBSD/i386 */
4568 #define KERNELVOID32_HEAPCODES_WORKS 1
4569 #endif
4570 #if defined(UNIX_MACOSX) && defined(I80386) /* Mac OS X/x86_64 with 32-bit ABI */
4571 #define KERNELVOID32_HEAPCODES_WORKS 1
4572 #endif
4573 #if defined(UNIX_MACOSX) && defined(POWERPC) /* Mac OS X/PowerPC */
4574 #define KERNELVOID32_HEAPCODES_WORKS 1
4575 #endif
4576 #if defined(UNIX_AIX) && defined(POWERPC) /* AIX/POWER with 32-bit ABI */
4577 #define KERNELVOID32_HEAPCODES_WORKS 1 /* 1 with gcc, 0 with xlc */
4578 #endif
4579 #if defined(UNIX_HPUX) && defined(HPPA) /* HP-UX/hppa with 32-bit ABI */
4580 #define KERNELVOID32_HEAPCODES_WORKS 1
4581 #endif
4582 #if defined(UNIX_HPUX) && defined(IA64) /* HP-UX/ia64 with 32-bit ABI */
4583 /* The 64-bit alignment of the 'uint64' and 'double' types causes
4584 alignment issues within strm_buffered_extrafields_t and Dfloat,
4585 which lead to SIGBUS. */
4586 #define KERNELVOID32_HEAPCODES_WORKS 0
4587 #endif
4588 #if defined(UNIX_IRIX) && (defined(MIPS) || defined(MIPS64)) /* IRIX 6.5 with o32 or n32 ABI */
4589 #if !(_MIPS_SIM == _ABIN32) /* IRIX 6.5 with o32 ABI */
4590 #define KERNELVOID32_HEAPCODES_WORKS 0
4591 #else /* IRIX 6.5 with n32 ABI */
4592 #define KERNELVOID32_HEAPCODES_WORKS 0
4593 #endif
4594 #endif
4595 #if defined(UNIX_SUNOS5) && defined(I80386) /* Solaris/x86_64 with 32-bit ABI */
4596 #define KERNELVOID32_HEAPCODES_WORKS 1
4597 #endif
4598 #if defined(UNIX_SUNOS5) && defined(SPARC) /* Solaris/sparc64 with 32-bit ABI */
4599 #define KERNELVOID32_HEAPCODES_WORKS 0 /* 1 with gcc, 0 with cc */
4600 #endif
4601 #if defined(UNIX_HAIKU) && defined(I80386) /* Haiku/i386 */
4602 /* Works fine without TRIVIALMAP_MEMORY.
4603 With TRIVIALMAP_MEMORY, sometimes we get repeated messages such as
4604 "Cannot map memory to address 0x202a8000 ... Invalid Argument" */
4605 #define KERNELVOID32_HEAPCODES_WORKS 1
4606 #endif
4607 #if defined(UNIX_MINIX) && defined(I80386) /* Minix/i386 */
4608 #define KERNELVOID32_HEAPCODES_WORKS 1
4609 #endif
4610 #if defined(UNIX_CYGWIN) && defined(I80386) /* Cygwin, running on Windows 10 */
4611 /* Warns "clisp might crash later" and
4612 produces messages "Cannot map memory to address". */
4613 #define KERNELVOID32_HEAPCODES_WORKS 0
4614 #endif
4615 #if defined(WIN32_NATIVE) && defined(I80386) /* mingw, running on Windows 10 */
4616 #define KERNELVOID32_HEAPCODES_WORKS 1
4617 #endif
4618 #endif /* KERNELVOID32_HEAPCODES */
4619 #ifdef GENERIC64_HEAPCODES
4620 /* GENERIC64A_HEAPCODES is closely modeled on KERNELVOID32A_HEAPCODES.
4621 GENERIC64B_HEAPCODES shifts the immediate values by one more bit.
4622 GENERIC64C_HEAPCODES drops the necessity of an address range hole. */
4623 #if !(defined(GENERIC64A_HEAPCODES) || defined(GENERIC64B_HEAPCODES) || defined(GENERIC64C_HEAPCODES))
4624 #if (defined(UNIX_FREEBSD) && defined(ARM64) && defined(__clang__)) \
4625 || (defined(UNIX_SUNOS5) && defined(SPARC64) && !defined(GNU))
4626 /* On FreeBSD/arm64 with clang and on Solaris/sparc64 with Sun C,
4627 GENERIC64C_HEAPCODES leads to "PSEUDOCODE_ALIGNMENT is not fulfilled.",
4628 but GENERIC64B_HEAPCODES works. So choose that, even if
4629 NO_ADDRESS_SPACE_ASSUMPTIONS is defined; we wouldn't be able
4630 to fully honor NO_ADDRESS_SPACE_ASSUMPTIONS in these cases. */
4631 #define GENERIC64B_HEAPCODES
4632 #else
4633 #define GENERIC64C_HEAPCODES
4634 #endif
4635 #endif
4636 #ifdef GENERIC64A_HEAPCODES
4637 /* The generic 64-bit case, variant A.
4638 Assumes 1. that the virtual memory addresses end at 0xC000000000000000,
4639 or at least that we can put a black hole on the range
4640 0xC000000000000000..0xDFFFFFFFFFFFFFFF,
4641 2. an 8-byte alignment for symbol_tab, subr_tab,
4642 3. a 4-byte alignment for any pointer in memory.
4643 Only bit 0 or 1 or 2 can be used as GC-bit. */
4644 #define oint_type_shift 0
4645 #define oint_type_len 64
4646 #define oint_type_mask 0xE00000000000001FUL
4647 #define oint_data_shift 5
4648 #define oint_data_len 56
4649 #define oint_data_mask 0x1FFFFFFFFFFFFFE0UL
4650 #define garcol_bit_o 0
4651 #endif /* GENERIC64A_HEAPCODES */
4652 #ifdef GENERIC64B_HEAPCODES
4653 /* The generic 64-bit case, variant B.
4654 Assumes 1. that the virtual memory addresses end at 0xC000000000000000,
4655 or at least that we can put a black hole on the range
4656 0xC000000000000000..0xDFFFFFFFFFFFFFFF,
4657 2. an 8-byte alignment for symbol_tab, subr_tab,
4658 3. a 4-byte alignment for any pointer in memory.
4659 Only bit 0 or 1 or 2 can be used as GC-bit. */
4660 #define oint_type_shift 0
4661 #define oint_type_len 64
4662 #define oint_type_mask 0xE00000000000003FUL
4663 #define oint_data_shift 6
4664 #define oint_data_len 55
4665 #define oint_data_mask 0x1FFFFFFFFFFFFFC0UL
4666 #define garcol_bit_o 0
4667 #endif /* GENERIC64B_HEAPCODES */
4668 #ifdef GENERIC64C_HEAPCODES
4669 /* The generic 64-bit case, variant C.
4670 Assumes nothing about the virtual memory addresses.
4671 But assumes an 8-byte alignment for symbol_tab, subr_tab, and more
4672 generally any pointer in memory.
4673 Only bit 0 or 1 or 2 can be used as GC-bit. */
4674 #define oint_type_shift 0
4675 #define oint_type_len 64
4676 #define oint_type_mask 0x000000000000003FUL
4677 #define oint_data_shift 6
4678 #define oint_data_len 58
4679 #define oint_data_mask 0xFFFFFFFFFFFFFFC0UL
4680 #define garcol_bit_o 0
4681 #endif /* GENERIC64C_HEAPCODES */
4682 /* Here we note whether GENERIC64C_HEAPCODES actually works,
4683 for each 64-bit platform.
4684 To determine GENERIC64C_HEAPCODES_WORKS, run one of
4685 make -f Makefile.devel build-porting64-gcc-generic64_heapcodes
4686 make -f Makefile.devel build-porting64-cc-generic64_heapcodes
4687 */
4688 #if defined(UNIX_LINUX) && defined(AMD64) /* Linux/x86_64 */
4689 #define GENERIC64C_HEAPCODES_WORKS 1
4690 #endif
4691 #if defined(UNIX_LINUX) && defined(ARM64) /* Linux/arm64 */
4692 #define GENERIC64C_HEAPCODES_WORKS 1
4693 #endif
4694 #if defined(UNIX_LINUX) && defined(DECALPHA) /* Linux/alpha */
4695 #define GENERIC64C_HEAPCODES_WORKS 1
4696 #endif
4697 #if defined(UNIX_LINUX) && defined(IA64) /* Linux/ia64 */
4698 #define GENERIC64C_HEAPCODES_WORKS 1
4699 #endif
4700 #if defined(UNIX_LINUX) && defined(MIPS64) /* Linux/mips with 64-bit ABI */
4701 #define GENERIC64C_HEAPCODES_WORKS 1
4702 #endif
4703 #if defined(UNIX_LINUX) && defined(POWERPC64) /* Linux/powerpc64, Linux/powerpc64le */
4704 #define GENERIC64C_HEAPCODES_WORKS 1
4705 #endif
4706 #if defined(UNIX_LINUX) && defined(RISCV64) /* Linux/riscv64 */
4707 #define GENERIC64C_HEAPCODES_WORKS 1
4708 #endif
4709 #if defined(UNIX_LINUX) && defined(S390_64) /* Linux/s390x */
4710 #define GENERIC64C_HEAPCODES_WORKS 1
4711 #endif
4712 #if defined(UNIX_LINUX) && defined(SPARC64) /* Linux/sparc64 */
4713 #define GENERIC64C_HEAPCODES_WORKS 1
4714 #endif
4715 #if (defined(UNIX_FREEBSD) || defined(UNIX_GNU_FREEBSD)) && defined(AMD64) /* FreeBSD/x86_64, GNU/kFreeBSD/x86_64 */
4716 #define GENERIC64C_HEAPCODES_WORKS 1
4717 #endif
4718 #if defined(UNIX_FREEBSD) && defined(ARM64) /* FreeBSD/arm64 */
4719 #define GENERIC64C_HEAPCODES_WORKS 0
4720 #define GENERIC64B_HEAPCODES_WORKS 1
4721 #endif
4722 #if defined(UNIX_NETBSD) && defined(AMD64) /* NetBSD/x86_64 */
4723 #define GENERIC64C_HEAPCODES_WORKS 1
4724 #endif
4725 #if defined(UNIX_NETBSD) && defined(SPARC64) /* NetBSD/sparc64 */
4726 #define GENERIC64C_HEAPCODES_WORKS ?
4727 #endif
4728 #if defined(UNIX_OPENBSD) && defined(AMD64) /* OpenBSD/x86_64 */
4729 #define GENERIC64C_HEAPCODES_WORKS 1
4730 #endif
4731 #if defined(UNIX_MACOSX) && defined(AMD64) /* Mac OS X/x86_64 */
4732 #define GENERIC64C_HEAPCODES_WORKS 1
4733 #endif
4734 #if defined(UNIX_AIX) && defined(POWERPC64) /* AIX/POWER with 64-bit ABI */
4735 #define GENERIC64C_HEAPCODES_WORKS 1
4736 #endif
4737 #if defined(UNIX_HPUX) && defined(HPPA64) /* HP-UX/hppa64 */
4738 #define GENERIC64C_HEAPCODES_WORKS 1
4739 #endif
4740 #if defined(UNIX_HPUX) && defined(IA64) /* HP-UX/ia64 */
4741 #define GENERIC64C_HEAPCODES_WORKS 1
4742 #endif
4743 #if defined(UNIX_SUNOS5) && defined(AMD64) /* Solaris/x86_64 */
4744 #define GENERIC64C_HEAPCODES_WORKS 1 /* 1 with gcc, 0 with cc */
4745 #define GENERIC64B_HEAPCODES_WORKS 1
4746 #endif
4747 #if defined(UNIX_SUNOS5) && defined(SPARC64) /* Solaris/sparc64 */
4748 #define GENERIC64C_HEAPCODES_WORKS 1
4749 #endif
4750 #if defined(UNIX_CYGWIN) && defined(AMD64) /* Cygwin */
4751 /* Produces messages "Cannot map memory to address". */
4752 #define GENERIC64C_HEAPCODES_WORKS 0
4753 #endif
4754 #endif /* GENERIC64_HEAPCODES */
4755 #if defined(WIDE_HARD)
4756 #define oint_addr_shift 0
4757 #define oint_addr_len 64
4758 #define oint_addr_mask 0xFFFFFFFFFFFFFFFFUL
4759 #else
4760 #define oint_addr_shift 0
4761 #define oint_addr_len 32
4762 #define oint_addr_mask 0xFFFFFFFFUL
4763 #endif
4764 #else /* TYPECODES */
4765 /* Now come the platforms with TYPECODES. oint_type_len should be >= 8,
4766 and oint_type_mask should have at least 8 bits set and at most one bit in
4767 common with oint_addr_mask. */
4768 #if defined(WIDE_SOFT)
4769 /* Separate 32-bit words for typecode and address. */
4770 #if defined(WIDE_SOFT_LARGEFIXNUM)
4771 /* Used to test large fixnums on 32-bit platforms.
4772 Bits 63..48 = type code, Bits 47..32 = zero, Bits 31..0 = address */
4773 #define oint_type_shift 48
4774 #define oint_type_len 16
4775 #define oint_type_mask ULL(0xFFFF000000000000)
4776 #define oint_addr_shift 0
4777 #define oint_addr_len 48
4778 #define oint_addr_mask ULL(0x0000FFFFFFFFFFFF)
4779 #elif WIDE_ENDIANNESS
4780 /* Bits 63..32 = type code, Bits 31..0 = address */
4781 #define oint_type_shift 32
4782 #define oint_type_len 32
4783 #define oint_type_mask ULL(0xFFFFFFFF00000000)
4784 #define oint_addr_shift 0
4785 #define oint_addr_len 32
4786 #define oint_addr_mask ULL(0x00000000FFFFFFFF)
4787 #else /* conversely it is a little slower: */
4788 /* Bits 63..32 = address, Bits 31..0 = type code */
4789 #define oint_type_shift 0
4790 #define oint_type_len 32
4791 #define oint_type_mask ULL(0x00000000FFFFFFFF)
4792 #define oint_addr_shift 32
4793 #define oint_addr_len 32
4794 #define oint_addr_mask ULL(0xFFFFFFFF00000000)
4795 #endif
4796 #else
4797 /* oint == uintP.
4798 Type code and address are in the same word. */
4799 #if defined(SINGLEMAP_MEMORY)
4800 /* The parameters are already determined above. */
4801 /* Verify that SINGLEMAP_ADDRESS_BASE, SINGLEMAP_TYPE_MASK, SINGLEMAP_oint_type_shift,
4802 SINGLEMAP_garcol_bit_o, SINGLEMAP_oint_type_len, SINGLEMAP_oint_type_mask
4803 are defined. */
4804 #if !(defined(SINGLEMAP_ADDRESS_BASE) && defined(SINGLEMAP_TYPE_MASK) \
4805 && defined(SINGLEMAP_oint_type_shift) \
4806 && defined(SINGLEMAP_garcol_bit_o) \
4807 && defined(SINGLEMAP_oint_type_len) && defined(SINGLEMAP_oint_type_mask))
4808 #error SINGLEMAP_ADDRESS_BASE, SINGLEMAP_TYPE_MASK, SINGLEMAP_oint_type_shift, SINGLEMAP_garcol_bit_o, SINGLEMAP_oint_type_len, SINGLEMAP_oint_type_mask are not defined for this platform!
4809 #endif
4810 #if !defined(WIDE_HARD)
4811 /* 32-bit platforms */
4812 /* Verify the assumption that MMAP_FIXED_ADDRESS_HIGHEST_BIT is 30. */
4813 #if defined(HAVE_WIN32_VM)
4814 #undef MMAP_FIXED_ADDRESS_HIGHEST_BIT
4815 #define MMAP_FIXED_ADDRESS_HIGHEST_BIT 30
4816 #else
4817 #if defined(MMAP_FIXED_ADDRESS_HIGHEST_BIT)
4818 #if !(MMAP_FIXED_ADDRESS_HIGHEST_BIT == 30)
4819 #error Unexpected value of MMAP_FIXED_ADDRESS_HIGHEST_BIT on 32-bit platform!
4820 #endif
4821 #else
4822 #define MMAP_FIXED_ADDRESS_HIGHEST_BIT 30
4823 #endif
4824 #endif
4825 #endif
4826 #define oint_type_shift SINGLEMAP_oint_type_shift
4827 #define garcol_bit_o SINGLEMAP_garcol_bit_o
4828 #define oint_type_len SINGLEMAP_oint_type_len
4829 #define oint_type_mask SINGLEMAP_oint_type_mask
4830 #define oint_addr_shift 0
4831 #define oint_addr_len oint_type_shift
4832 /* Not just ~oint_type_mask, because evaluation in preprocessor directives uses intmax_t. */
4833 #define oint_addr_mask ((bitm(pointer_bitsize)-1) & ~oint_type_mask)
4834 #define oint_data_shift oint_addr_shift
4835 #define oint_data_len oint_addr_len
4836 #define oint_data_mask ((1UL<<oint_data_len)-1)
4837 #if oint_data_len < 24
4838 #error oint_data_len is too small, short-floats need at least 24 data bits!
4839 #endif
4840 #else
4841 #if defined(TRIVIALMAP_MEMORY)
4842 /* Due to TRIVIALMAP_MEMORY, heap object and STACK addresses are in
4843 [MAPPABLE_ADDRESS_RANGE_START, MAPPABLE_ADDRESS_RANGE_END].
4844 CODE_ADDRESS_RANGE matters here. */
4845 /* To determine TYPECODES_WITH_TRIVIALMAP_WORKS, run one of
4846 make -f Makefile.devel build-porting32-gcc-typecodes-spvw_mixed_blocks-trivialmap
4847 make -f Makefile.devel build-porting32-cc-typecodes-spvw_mixed_blocks-trivialmap
4848 make -f Makefile.devel build-porting64-gcc-typecodes-spvw_mixed_blocks-trivialmap
4849 make -f Makefile.devel build-porting64-cc-typecodes-spvw_mixed_blocks-trivialmap
4850 */
4851 #if !defined(WIDE_HARD)
4852 /* 32-bit platforms */
4853 /* Try to accommodate 7 or 8 type bits.
4854 But a value of oint_type_shift < 24 is unusable. */
4855 #undef MAPPABLE_ADDRESS_RANGE_START
4856 #undef MAPPABLE_ADDRESS_RANGE_END
4857 #if CODE_ADDRESS_RANGE != 0
4858 #if MALLOC_ADDRESS_RANGE != 0 && SHLIB_ADDRESS_RANGE != 0
4859 #define MAPPABLE_ADDRESS_RANGE_START 0x00010000UL
4860 #else
4861 /* If we use 0x00xxxxxxUL, there is a collision with malloc or shlibs.
4862 If we use CODE_ADDRESS_RANGE + 0x00xxxxxxUL, there is a collision with code.
4863 If we use another location, there is room for at most 5+1 type bits, i.e. we
4864 run into "Bogus oint_type_mask -- oint_type_mask has more than one extraneous bit!!" */
4865 #error No way to accommodate 7 type bits, because of CODE_ADDRESS_RANGE.
4866 #endif
4867 #endif
4868 #if defined(UNIX_LINUX) && defined(AMD64) /* Linux/x86_64 with 32-bit x32 ABI */
4869 #define MAPPABLE_ADDRESS_RANGE_START 0x04000000UL /* 0x04000000UL or 0x08000000UL or 0x10000000UL or 0x20000000UL or 0x40000000UL */
4870 #define TYPECODES_WITH_TRIVIALMAP_WORKS 1 /* but only without GENERATIONAL_GC */
4871 #endif
4872 #if defined(UNIX_LINUX) && defined(ARM) /* Linux/arm */
4873 #define MAPPABLE_ADDRESS_RANGE_START 0x08000000UL /* or 0x04000000UL or 0x10000000UL or 0x20000000UL */
4874 #define TYPECODES_WITH_TRIVIALMAP_WORKS 0 /* works on some machines but not on others */
4875 #endif
4876 #if defined(UNIX_LINUX) && defined(HPPA) /* Linux/hppa */
4877 #define MAPPABLE_ADDRESS_RANGE_START 0x08000000UL /* or 0x01000000UL or 0x02000000UL or 0x04000000UL or 0x10000000UL or 0x20000000UL or 0x40000000UL */
4878 #define TYPECODES_WITH_TRIVIALMAP_WORKS 1 /* but only without GENERATIONAL_GC */
4879 #endif
4880 #if defined(UNIX_LINUX) && defined(I80386) /* Linux/i386, Linux/x86_64 with 32-bit i386 ABI */
4881 #define MAPPABLE_ADDRESS_RANGE_START 0x00010000UL
4882 #error No way to accommodate 7 type bits, because of CODE_ADDRESS_RANGE.
4883 #endif
4884 #if defined(UNIX_LINUX) && defined(M68K) /* Linux/m68k */
4885 #define TYPECODES_WITH_TRIVIALMAP_WORKS 1 /* but only without GENERATIONAL_GC */
4886 #endif
4887 #if defined(UNIX_LINUX) && (defined(MIPS) || defined(MIPS64)) /* Linux/mips with o32 or n32 ABI */
4888 #if !(_MIPS_SIM == _ABIN32) /* Linux/mips with o32 ABI */
4889 #define MAPPABLE_ADDRESS_RANGE_START 0x01000000UL /* or 0x02000000UL or 0x04000000UL or 0x08000000UL or 0x10000000UL or 0x20000000UL or 0x40000000UL */
4890 #define TYPECODES_WITH_TRIVIALMAP_WORKS 0
4891 #else /* Linux/mips with n32 ABI */
4892 #undef MAPPABLE_ADDRESS_RANGE_START
4893 #define MAPPABLE_ADDRESS_RANGE_START 0x01000000UL /* or 0x02000000UL or 0x04000000UL or 0x08000000UL or 0x10000000UL or 0x20000000UL or 0x40000000UL */
4894 #define TYPECODES_WITH_TRIVIALMAP_WORKS 0
4895 #endif
4896 #endif
4897 #if defined(UNIX_LINUX) && defined(POWERPC) /* Linux/powerpc64 with 32-bit ABI */
4898 #define TYPECODES_WITH_TRIVIALMAP_WORKS 0
4899 #endif
4900 #if defined(UNIX_LINUX) && defined(S390) /* Linux/s390x with 32-bit ABI */
4901 #define MAPPABLE_ADDRESS_RANGE_START 0x01000000UL /* or 0x02000000UL or 0x04000000UL or 0x08000000UL or 0x10000000UL or 0x20000000UL or 0x40000000UL */
4902 #define TYPECODES_WITH_TRIVIALMAP_WORKS 0
4903 #endif
4904 #if defined(UNIX_LINUX) && defined(SPARC) /* Linux/sparc64 with 32-bit ABI */
4905 #define MAPPABLE_ADDRESS_RANGE_START 0x00010000UL
4906 #error No way to accommodate 7 type bits, because of CODE_ADDRESS_RANGE.
4907 #endif
4908 #if defined(UNIX_HURD) && defined(I80386) /* Hurd/i386 */
4909 #define TYPECODES_WITH_TRIVIALMAP_WORKS 0
4910 #endif
4911 #if (defined(__FreeBSD__) || defined(UNIX_GNU_FREEBSD) || defined(__DragonFly__)) && defined(I80386) /* FreeBSD/i386, GNU/kFreeBSD/i386, DragonFly/i386 */
4912 #define TYPECODES_WITH_TRIVIALMAP_WORKS 0
4913 #endif
4914 #if defined(UNIX_NETBSD) && defined(I80386) /* NetBSD/i386 */
4915 #define TYPECODES_WITH_TRIVIALMAP_WORKS 1 /* but only without GENERATIONAL_GC */
4916 #endif
4917 #if defined(UNIX_NETBSD) && defined(SPARC) /* NetBSD/sparc */
4918 #define MAPPABLE_ADDRESS_RANGE_START 0x10000000UL /* or 0x01000000UL or 0x02000000UL or 0x04000000UL or 0x08000000UL */
4919 #define TYPECODES_WITH_TRIVIALMAP_WORKS 1 /* but only without GENERATIONAL_GC */
4920 #endif
4921 #if defined(UNIX_OPENBSD) && defined(I80386) /* OpenBSD/i386 */
4922 #define MAPPABLE_ADDRESS_RANGE_START 0x00010000UL
4923 #error No way to accommodate 7 type bits, because of CODE_ADDRESS_RANGE.
4924 #endif
4925 #if defined(UNIX_MACOSX) && defined(I80386) /* Mac OS X/x86_64 with 32-bit ABI */
4926 #define MAPPABLE_ADDRESS_RANGE_START 0x10000000UL /* or 0x02000000UL or 0x04000000UL or 0x08000000UL or 0x20000000UL or 0x40000000UL or 0x80000000UL */
4927 #define TYPECODES_WITH_TRIVIALMAP_WORKS 1
4928 #endif
4929 #if defined(UNIX_MACOSX) && defined(POWERPC) /* Mac OS X/PowerPC */
4930 #define MAPPABLE_ADDRESS_RANGE_START 0x10000000UL /* or 0x02000000UL or 0x04000000UL or 0x08000000UL or 0x20000000UL or 0x40000000UL or 0x80000000UL */
4931 #define TYPECODES_WITH_TRIVIALMAP_WORKS 1
4932 #endif
4933 #if defined(UNIX_AIX) && defined(POWERPC) /* AIX/POWER with 32-bit ABI */
4934 #define MAPPABLE_ADDRESS_RANGE_START 0x00010000UL
4935 #error No way to accommodate 7 type bits, because of CODE_ADDRESS_RANGE.
4936 #endif
4937 #if defined(UNIX_HPUX) && defined(HPPA) /* HP-UX/hppa with 32-bit ABI */
4938 /* Does not work because mmap MAP_FIXED is not supported on this platform. */
4939 #define TYPECODES_WITH_TRIVIALMAP_WORKS 0
4940 #endif
4941 #if defined(UNIX_HPUX) && defined(IA64) /* HP-UX/ia64 with 32-bit ABI */
4942 /* Does not work because mmap MAP_FIXED is not supported on this platform. */
4943 #define TYPECODES_WITH_TRIVIALMAP_WORKS 0
4944 #endif
4945 #if defined(UNIX_IRIX) && (defined(MIPS) || defined(MIPS64)) /* IRIX 6.5 with o32 or n32 ABI */
4946 #if !(_MIPS_SIM == _ABIN32) /* IRIX 6.5 with o32 ABI */
4947 #define MAPPABLE_ADDRESS_RANGE_START 0x08000000UL /* or 0x01000000UL or 0x02000000UL or 0x04000000UL or 0x20000000UL or 0x40000000UL */
4948 #define TYPECODES_WITH_TRIVIALMAP_WORKS 0
4949 #else /* IRIX 6.5 with n32 ABI */
4950 #define TYPECODES_WITH_TRIVIALMAP_WORKS 0
4951 #endif
4952 #endif
4953 #if defined(UNIX_SUNOS5) && defined(I80386) /* Solaris/x86_64 with 32-bit ABI */
4954 #define TYPECODES_WITH_TRIVIALMAP_WORKS 0
4955 #endif
4956 #if defined(UNIX_SUNOS5) && defined(SPARC) /* Solaris/sparc64 with 32-bit ABI */
4957 #define MAPPABLE_ADDRESS_RANGE_START 0x08000000UL /* or 0x01000000UL or 0x02000000UL or 0x04000000UL or 0x10000000UL or 0x20000000UL or 0x40000000UL */
4958 #define TYPECODES_WITH_TRIVIALMAP_WORKS 0
4959 #endif
4960 #if defined(UNIX_HAIKU) && defined(I80386) /* Haiku/i386 */
4961 #define MAPPABLE_ADDRESS_RANGE_START 0x00010000UL
4962 #error No way to accommodate 7 type bits, because of CODE_ADDRESS_RANGE.
4963 #endif
4964 #if defined(UNIX_MINIX) && defined(I80386) /* Minix/i386 */
4965 #define TYPECODES_WITH_TRIVIALMAP_WORKS 1
4966 #endif
4967 #if defined(UNIX_CYGWIN) && defined(I80386) /* Cygwin, running on Windows 10 */
4968 #define MAPPABLE_ADDRESS_RANGE_START 0x40000000UL
4969 /* Warns "clisp might crash later" and
4970 produces messages "Cannot map memory to address". */
4971 #define TYPECODES_WITH_TRIVIALMAP_WORKS 0
4972 #endif
4973 #if defined(WIN32_NATIVE) && defined(I80386) /* mingw, running on Windows 10 */
4974 #define MAPPABLE_ADDRESS_RANGE_START 0x08000000UL /* or 0x04000000UL or 0x10000000UL or 0x20000000UL or 0x40000000UL */
4975 #define TYPECODES_WITH_TRIVIALMAP_WORKS 0 /* even without GENERATIONAL_GC */
4976 #endif
4977 #define MAPPABLE_ADDRESS_RANGE_END (MAPPABLE_ADDRESS_RANGE_START | 0x00FFFFFFUL)
4978 #define oint_type_shift 24
4979 #define oint_type_len 8
4980 #define oint_addr_shift 0
4981 #define oint_addr_len oint_type_shift
4982 #define oint_addr_mask (MAPPABLE_ADDRESS_RANGE_START | CODE_ADDRESS_RANGE | 0x00FFFFFFUL)
4983 /* Not just ~oint_addr_mask, because evaluation in preprocessor directives uses intmax_t. */
4984 #define oint_type_mask (0xFFFFFFFFUL & ~oint_addr_mask)
4985 #else
4986 /* 64-bit platforms */
4987 #if defined(UNIX_LINUX) && defined(AMD64) /* Linux/x86_64 */
4988 #define TYPECODES_WITH_TRIVIALMAP_WORKS 1
4989 #endif
4990 #if defined(UNIX_LINUX) && defined(ARM64) /* Linux/arm64 */
4991 #define TYPECODES_WITH_TRIVIALMAP_WORKS 1
4992 #endif
4993 #if defined(UNIX_LINUX) && defined(DECALPHA) /* Linux/alpha */
4994 #define TYPECODES_WITH_TRIVIALMAP_WORKS 1
4995 #endif
4996 #if defined(UNIX_LINUX) && defined(IA64) /* Linux/ia64 */
4997 #define oint_type_shift 53
4998 #define garcol_bit_o 60
4999 #define oint_addr_mask 0xE01FFFFFFFFFFFFFUL
5000 #define TYPECODES_WITH_TRIVIALMAP_WORKS 1
5001 #endif
5002 #if defined(UNIX_LINUX) && defined(MIPS64) /* Linux/mips with 64-bit ABI */
5003 #define TYPECODES_WITH_TRIVIALMAP_WORKS 1
5004 #endif
5005 #if defined(UNIX_LINUX) && defined(POWERPC64) /* Linux/powerpc64, Linux/powerpc64le */
5006 #define TYPECODES_WITH_TRIVIALMAP_WORKS 1
5007 #endif
5008 #if defined(UNIX_LINUX) && defined(RISCV64) /* Linux/riscv64 */
5009 #define TYPECODES_WITH_TRIVIALMAP_WORKS 1
5010 #endif
5011 #if defined(UNIX_LINUX) && defined(S390_64) /* Linux/s390x */
5012 #define TYPECODES_WITH_TRIVIALMAP_WORKS 1
5013 #endif
5014 #if defined(UNIX_LINUX) && defined(SPARC64) /* Linux/sparc64 */
5015 #if 0 /* Does not help for the older machine. */
5016 #undef MAPPABLE_ADDRESS_RANGE_START
5017 #undef MAPPABLE_ADDRESS_RANGE_END
5018 #define MAPPABLE_ADDRESS_RANGE_START 0x0000040000000000UL
5019 #define MAPPABLE_ADDRESS_RANGE_END 0x00000403FFFFFFFFUL
5020 #define oint_type_shift 34
5021 #define garcol_bit_o 41
5022 #define oint_addr_mask 0xFFFFFD03FFFFFFFFUL
5023 #endif
5024 #define TYPECODES_WITH_TRIVIALMAP_WORKS 0 /* 0 on an older machine (gcc-4.6.3), 1 on newer machines (gcc-6.4, gcc-7.2) */
5025 #endif
5026 #if (defined(UNIX_FREEBSD) || defined(UNIX_GNU_FREEBSD)) && defined(AMD64) /* FreeBSD/x86_64, GNU/kFreeBSD/x86_64 */
5027 #define TYPECODES_WITH_TRIVIALMAP_WORKS 1
5028 #endif
5029 #if defined(UNIX_FREEBSD) && defined(ARM64) /* FreeBSD/arm64 */
5030 #define TYPECODES_WITH_TRIVIALMAP_WORKS 1
5031 #endif
5032 #if defined(UNIX_NETBSD) && defined(AMD64) /* NetBSD/x86_64 */
5033 #define TYPECODES_WITH_TRIVIALMAP_WORKS 1
5034 #endif
5035 #if defined(UNIX_NETBSD) && defined(SPARC64) /* NetBSD/sparc64 */
5036 #define TYPECODES_WITH_TRIVIALMAP_WORKS ?
5037 #endif
5038 #if defined(UNIX_OPENBSD) && defined(AMD64) /* OpenBSD/x86_64 */
5039 #define TYPECODES_WITH_TRIVIALMAP_WORKS 1
5040 #endif
5041 #if defined(UNIX_MACOSX) && defined(AMD64) /* Mac OS X/x86_64 */
5042 #define TYPECODES_WITH_TRIVIALMAP_WORKS 0
5043 #endif
5044 #if defined(UNIX_AIX) && defined(POWERPC64) /* AIX/POWER with 64-bit ABI */
5045 #undef MAPPABLE_ADDRESS_RANGE_END
5046 #define MAPPABLE_ADDRESS_RANGE_END 0x00FFFFFFFFFFFFFFUL
5047 #define TYPECODES_WITH_TRIVIALMAP_WORKS 0
5048 #endif
5049 #if defined(UNIX_HPUX) && defined(HPPA64) /* HP-UX/hppa64 */
5050 /* Does not work because mmap MAP_FIXED is not supported on this platform. */
5051 #define TYPECODES_WITH_TRIVIALMAP_WORKS 0
5052 #endif
5053 #if defined(UNIX_HPUX) && defined(IA64) /* HP-UX/ia64 */
5054 /* Does not work because mmap MAP_FIXED is not supported on this platform. */
5055 #define TYPECODES_WITH_TRIVIALMAP_WORKS 0
5056 #endif
5057 #if defined(UNIX_SUNOS5) && defined(AMD64) /* Solaris/x86_64 */
5058 #define TYPECODES_WITH_TRIVIALMAP_WORKS 1
5059 #endif
5060 #if defined(UNIX_SUNOS5) && defined(SPARC64) /* Solaris/sparc64 */
5061 /* Link error: "ld: fatal: relocation error: R_SPARC_H44: file spvw.o: symbol symbol_tab_data: value 0x1000000400 does not fit" */
5062 #define TYPECODES_WITH_TRIVIALMAP_WORKS 0
5063 #endif
5064 #if defined(UNIX_CYGWIN) && defined(AMD64) /* Cygwin */
5065 /* Produces messages "Cannot map memory to address". */
5066 #define TYPECODES_WITH_TRIVIALMAP_WORKS 0
5067 #endif
5068 #define oint_type_len 8
5069 #ifndef oint_type_shift
5070 #define oint_type_shift 56
5071 #endif
5072 #define oint_addr_shift 0
5073 #define oint_addr_len oint_type_shift
5074 #ifndef oint_addr_mask
5075 #define oint_addr_mask ((1UL<<oint_addr_len)-1)
5076 #endif
5077 /* Not just ~oint_addr_mask, because evaluation in preprocessor directives uses intmax_t. */
5078 #define oint_type_mask (0xFFFFFFFFFFFFFFFFUL & ~oint_addr_mask)
5079 #endif
5080 #else
5081 /* Heap object and STACK addresses are allocated through mymalloc.
5082 Therefore CODE_ADDRESS_RANGE and MALLOC_ADDRESS_RANGE matter here. */
5083 /* To determine TYPECODES_WITH_MALLOC_WORKS, run one of
5084 make -k -f Makefile.devel build-porting32-gcc-typecodes-spvw_mixed_blocks-malloc build-porting32-gcc-typecodes-spvw_mixed_pages build-porting32-gcc-typecodes-spvw_pure_pages
5085 make -k -f Makefile.devel build-porting32-cc-typecodes-spvw_mixed_blocks-malloc build-porting32-cc-typecodes-spvw_mixed_pages build-porting32-cc-typecodes-spvw_pure_pages
5086 make -k -f Makefile.devel build-porting64-gcc-typecodes-spvw_mixed_blocks-malloc build-porting64-gcc-typecodes-spvw_mixed_pages build-porting64-gcc-typecodes-spvw_pure_pages
5087 make -k -f Makefile.devel build-porting64-cc-typecodes-spvw_mixed_blocks-malloc build-porting64-cc-typecodes-spvw_mixed_pages build-porting64-cc-typecodes-spvw_pure_pages
5088 */
5089 #if !defined(WIDE_HARD)
5090 /* 32-bit platforms */
5091 #if defined(UNIX_HPUX) && defined(HPPA) /* HP-UX/hppa with 32-bit ABI */
5092 #define oint_type_shift 24
5093 #define oint_type_len 8
5094 #define oint_type_mask 0xBF000000UL
5095 #define oint_addr_shift 0
5096 #define oint_addr_len 24
5097 #define oint_addr_mask 0x40FFFFFFUL
5098 /* typecodes-spvw_pure_pages works, the other two crash. */
5099 #define TYPECODES_WITH_MALLOC_WORKS 0
5100 #endif
5101 #if defined(UNIX_HPUX) && defined(IA64) /* HP-UX/ia64 with 32-bit ABI */
5102 #define oint_type_shift 24
5103 #define oint_type_len 8
5104 #define oint_type_mask 0xBF000000UL
5105 #define oint_addr_shift 0
5106 #define oint_addr_len 24
5107 #define oint_addr_mask 0x40FFFFFFUL
5108 #error No way to accommodate 7 type bits, because of CODE_ADDRESS_RANGE.
5109 #define TYPECODES_WITH_MALLOC_WORKS 0
5110 #endif
5111 /* It is not worth testing these configurations without TRIVIALMAP_MEMORY.
5112 Most of them would fail when starting lisp.run, with the error
5113 "Return value of malloc() = ... is not compatible with type code distribution." */
5114 #ifndef oint_addr_mask
5115 #error "This configuration is not supported without TRIVIALMAP_MEMORY. Add -DTRIVIALMAP_MEMORY to the CFLAGS in the Makefile."
5116 #endif
5117 #else
5118 /* 64-bit platforms */
5119 /* Nearly the same as with TRIVIALMAP_MEMORY. */
5120 #if defined(UNIX_LINUX) && defined(AMD64) /* Linux/x86_64 */
5121 #define TYPECODES_WITH_MALLOC_WORKS 1
5122 #endif
5123 #if defined(UNIX_LINUX) && defined(ARM64) /* Linux/arm64 */
5124 #define TYPECODES_WITH_MALLOC_WORKS 1
5125 #endif
5126 #if defined(UNIX_LINUX) && defined(DECALPHA) /* Linux/alpha */
5127 #define TYPECODES_WITH_MALLOC_WORKS 1
5128 #endif
5129 #if defined(UNIX_LINUX) && defined(IA64) /* Linux/ia64 */
5130 #define oint_type_shift 53
5131 #define garcol_bit_o 60
5132 #define oint_addr_mask 0xE01FFFFFFFFFFFFFUL
5133 #define TYPECODES_WITH_MALLOC_WORKS 0
5134 #endif
5135 #if defined(UNIX_LINUX) && defined(MIPS64) /* Linux/mips with 64-bit ABI */
5136 #define TYPECODES_WITH_MALLOC_WORKS 1
5137 #endif
5138 #if defined(UNIX_LINUX) && defined(POWERPC64) /* Linux/powerpc64, Linux/powerpc64le */
5139 #define TYPECODES_WITH_MALLOC_WORKS 1
5140 #endif
5141 #if defined(UNIX_LINUX) && defined(RISCV64) /* Linux/riscv64 */
5142 #define TYPECODES_WITH_MALLOC_WORKS 1
5143 #endif
5144 #if defined(UNIX_LINUX) && defined(S390_64) /* Linux/s390x */
5145 #define TYPECODES_WITH_MALLOC_WORKS 1
5146 #endif
5147 #if defined(UNIX_LINUX) && defined(SPARC64) /* Linux/sparc64 */
5148 #if 0 /* Does not help for the older machine. */
5149 /* Avoid error
5150 "Return value of malloc() = 00000100004808e0 is not compatible with type code distribution."
5151 as well as
5152 "Return value of malloc() = fffff8010049a010 is not compatible with type code distribution." */
5153 #define oint_type_shift 35
5154 #define garcol_bit_o 42
5155 #define oint_addr_mask 0xFFFFF907FFFFFFFFUL
5156 #endif
5157 #define TYPECODES_WITH_MALLOC_WORKS 0 /* 0 on an older machine (gcc-4.6.3), 1 on newer machines (gcc-6.4, gcc-7.2), but with unexpected "No more room for LISP objects" */
5158 #endif
5159 #if (defined(UNIX_FREEBSD) || defined(UNIX_GNU_FREEBSD)) && defined(AMD64) /* FreeBSD/x86_64, GNU/kFreeBSD/x86_64 */
5160 #define TYPECODES_WITH_MALLOC_WORKS 1
5161 #endif
5162 #if defined(UNIX_FREEBSD) && defined(ARM64) /* FreeBSD/arm64 */
5163 #define TYPECODES_WITH_MALLOC_WORKS 1
5164 #endif
5165 #if defined(UNIX_NETBSD) && defined(AMD64) /* NetBSD/x86_64 */
5166 #define TYPECODES_WITH_MALLOC_WORKS 1
5167 #endif
5168 #if defined(UNIX_NETBSD) && defined(SPARC64) /* NetBSD/sparc64 */
5169 #define TYPECODES_WITH_MALLOC_WORKS ?
5170 #endif
5171 #if defined(UNIX_OPENBSD) && defined(AMD64) /* OpenBSD/x86_64 */
5172 #define TYPECODES_WITH_MALLOC_WORKS 1
5173 #endif
5174 #if defined(UNIX_MACOSX) && defined(AMD64) /* Mac OS X/x86_64 */
5175 #define TYPECODES_WITH_MALLOC_WORKS 0
5176 #endif
5177 #if defined(UNIX_AIX) && defined(POWERPC64) /* AIX/POWER with 64-bit ABI */
5178 #define TYPECODES_WITH_MALLOC_WORKS 0
5179 #endif
5180 #if defined(UNIX_HPUX) && defined(HPPA64) /* HP-UX/hppa64 */
5181 #define oint_type_shift 53
5182 #define oint_type_len 9
5183 #define oint_addr_mask 0xC01FFFFFFFFFFFFFUL
5184 #define garcol_bit_o 60
5185 /* Crashes mentioning #<ADDRESS #x80000001000402A0>, which is indeed an
5186 address without typecode. cc apparently miscompiles some use of the
5187 type_pointer_object macro, even when no optimization is enabled. */
5188 #define TYPECODES_WITH_MALLOC_WORKS 0
5189 #endif
5190 #if defined(UNIX_HPUX) && defined(IA64) /* HP-UX/ia64 */
5191 #error No way to accommodate 7 type bits, because of CODE_ADDRESS_RANGE.
5192 #endif
5193 #if defined(UNIX_SUNOS5) && defined(AMD64) /* Solaris/x86_64 */
5194 #define TYPECODES_WITH_MALLOC_WORKS 1
5195 #endif
5196 #if defined(UNIX_SUNOS5) && defined(SPARC64) /* Solaris/sparc64 */
5197 /* Link error: "ld: fatal: relocation error: R_SPARC_H44: file spvw.o: symbol symbol_tab_data: value 0x1000000400 does not fit" */
5198 #define TYPECODES_WITH_MALLOC_WORKS 0
5199 #endif
5200 #if defined(UNIX_CYGWIN) && defined(AMD64) /* Cygwin */
5201 #define TYPECODES_WITH_MALLOC_WORKS 1
5202 #endif
5203 #ifndef oint_type_shift
5204 #define oint_type_shift 56
5205 #endif
5206 #ifndef oint_type_len
5207 #define oint_type_len 8
5208 #endif
5209 #define oint_addr_shift 0
5210 #define oint_addr_len oint_type_shift
5211 #ifndef oint_addr_mask
5212 #define oint_addr_mask ((1UL<<oint_addr_len)-1)
5213 #endif
5214 /* Not just ~oint_addr_mask, because evaluation in preprocessor directives uses intmax_t. */
5215 #define oint_type_mask (0xFFFFFFFFFFFFFFFFUL & ~oint_addr_mask)
5216 #endif
5217 #endif
5218 #define oint_data_shift oint_addr_shift
5219 #define oint_data_len oint_addr_len
5220 #define oint_data_mask ((1UL<<oint_data_len)-1)
5221 #endif
5222 #endif
5223 #endif
5224 %% #if notused
5225 %% export_def(oint_type_shift);
5226 %% export_def(oint_type_len);
5227 %% export_def(oint_type_mask);
5228 %% export_def(oint_addr_shift);
5229 %% export_def(oint_addr_len);
5230 %% export_def(oint_addr_mask);
5231 %% #endif
5232 #ifndef oint_type_len
5233 #error CLISP has not been ported to this platform - oint_type_len undefined
5234 #endif
5235
5236 /* Generally we use all of the space of an address for the data of Fixnums etc.
5237 Always [oint_data_shift..oint_data_shift+oint_data_len-1] is subset of
5238 [oint_addr_shift..oint_addr_shift+oint_addr_len-1],
5239 thus oint_data_len <= oint_addr_len. */
5240 #ifndef oint_data_len
5241 #define oint_data_shift oint_addr_shift
5242 #define oint_data_len oint_addr_len
5243 #define oint_data_mask oint_addr_mask
5244 #endif
5245 %% #if notused
5246 %% export_def(oint_data_shift);
5247 %% export_def(oint_data_len);
5248 %% export_def(oint_data_mask);
5249 %% #endif
5250
5251 /* Integer type for typebits: */
5252 /* Use a #if cascade because oint_type_len may expand to an parenthesized expression. */
5253 #if oint_type_len <= 8
5254 typedef uint8 tint;
5255 #elif oint_type_len <= 16
5256 typedef uint16 tint;
5257 #elif oint_type_len <= 32
5258 typedef uint32 tint;
5259 #elif oint_type_len <= 64
5260 typedef uint64 tint;
5261 #else
5262 typedef unsigned_int_with_n_bits(oint_type_len) tint;
5263 #endif
5264 %% #if oint_type_len > 32 && oint_type_len <= 64
5265 %% sprintf(buf,"uint64"); emit_typedef(buf,"tint");
5266 %% #else
5267 %% sprintf(buf,"uint%d",oint_type_len); emit_typedef(buf,"tint");
5268 %% #endif
5269
5270 /* Integer type for addresses: */
5271 /* Use a #if cascade because oint_addr_len may expand to an parenthesized expression. */
5272 #if defined(WIDE_HARD)
5273 typedef uint64 aint;
5274 typedef sint64 saint;
5275 #elif oint_addr_len <= 8
5276 typedef uint8 aint;
5277 typedef sint8 saint;
5278 #elif oint_addr_len <= 16
5279 typedef uint16 aint;
5280 typedef sint16 saint;
5281 #elif oint_addr_len <= 32
5282 typedef uint32 aint;
5283 typedef sint32 saint;
5284 #elif oint_addr_len <= 64
5285 typedef uint64 aint;
5286 typedef sint64 saint;
5287 #else
5288 typedef unsigned_int_with_n_bits(oint_addr_len) aint;
5289 typedef signed_int_with_n_bits(oint_addr_len) saint;
5290 #endif
5291 %% #if defined(WIDE_HARD) || (oint_addr_len > 32 && oint_addr_len <= 64)
5292 %% sprintf(buf,"uint64"); emit_typedef(buf,"aint");
5293 %% #if notused
5294 %% sprintf(buf,"sint64"); emit_typedef(buf,"saint");
5295 %% #endif
5296 %% #else
5297 %% sprintf(buf,"uint%d",oint_addr_len); emit_typedef(buf,"aint");
5298 %% #if notused
5299 %% sprintf(buf,"sint%d",oint_addr_len); emit_typedef(buf,"saint");
5300 %% #endif
5301 %% #endif
5302
5303 /* Integer type for immediate values:
5304 Always 32 = intLsize <= intVsize <= 64. */
5305 #if (oint_data_len <= 32)
5306 #define intVsize 32
5307 #else
5308 #define intVsize 64
5309 #endif
5310 typedef unsigned_int_with_n_bits(intVsize) uintV;
5311 typedef signed_int_with_n_bits(intVsize) sintV;
5312 %% sprintf(buf,"uint%d",intVsize); emit_typedef(buf,"uintV");
5313 %% sprintf(buf,"sint%d",intVsize); emit_typedef(buf,"sintV");
5314
5315 /* Integer type used to represent an amount of memory:
5316 (This may be larger than size_t or ptrdiff_t: size_t is required by ISO C to
5317 be enough for the size of a single memory block; ptrdiff_t is required by
5318 ISO C to be enough for the size of a single memory block plus room for a sign
5319 bit. But on segmented architectures which allow many medium-sized memory
5320 blocks, like the 80286 was, the total available memory size may be bigger.
5321 Also, we avoid size_t because it's likely to be wrong on 64-bit Woe32.) */
5322 #if !defined(WIDE_HARD) || ((oint_addr_mask & ~0xFFFFFFFFUL) == 0)
5323 /* A 32-bit integer is sufficient. */
5324 #define intMsize intLsize
5325 typedef uintL uintM;
5326 typedef sintL sintM;
5327 #else
5328 /* An integer as wide as a pointer may be required. */
5329 #define intMsize pointer_bitsize
5330 typedef uintP uintM;
5331 typedef sintP sintM;
5332 #endif
5333
5334 /* Number of bits by which an address is finally being shifted: */
5335 #ifndef addr_shift
5336 #define addr_shift 0
5337 #endif
5338 %% #if notused
5339 %% export_def(addr_shift);
5340 %% #endif
5341
5342 /* Verify the values w.r.t. the earlier configured SINGLEMAP_MEMORY. */
5343 #if defined(SINGLEMAP_MEMORY)
5344 #if oint_addr_shift != 0
5345 #error oint_addr_shift must be 0 with SINGLEMAP_MEMORY !!
5346 #endif
5347 #if addr_shift != 0
5348 #error addr_shift must be 0 with SINGLEMAP_MEMORY !!
5349 #endif
5350 #endif
5351
5352
5353 /* Flavor of the garbage collection: normal or generational. */
5354 #if /* Generational GC requires virtual memory. */ \
5355 defined(VIRTUAL_MEMORY) \
5356 && /* It requires memory mapping so that every object is visible at a \
5357 single address. */ \
5358 (defined(SINGLEMAP_MEMORY) || defined(TRIVIALMAP_MEMORY)) \
5359 && /* It requires a working mprotect(). */ \
5360 defined(HAVE_WORKING_MPROTECT) \
5361 && /* It requires SIGSEGV recovery, provided by libsigsegv. */ \
5362 defined(HAVE_SIGSEGV_RECOVERY) \
5363 && /* Not worth spending effort on making it work with \
5364 WIDE_SOFT_LARGEFIXNUM. */ \
5365 !defined(WIDE_SOFT_LARGEFIXNUM) \
5366 && /* It does not work on EdgeRouter Pro (Cavium Octeon II) hardware. */ \
5367 !(defined(UNIX_LINUX) && (defined(MIPS) || defined(MIPS64))) \
5368 && /* It does not work on Linux/riscv64 so far (Linux bug with PROT_NONE). */\
5369 !(defined(UNIX_LINUX) && defined(RISCV64)) \
5370 && /* It does not work on NetBSD 7 (both NetBSD/i386 and NetBSD/sparc). */\
5371 !defined(UNIX_NETBSD) \
5372 && /* It does not work in QEMU user-mode. */ \
5373 !((defined(UNIX_LINUX) && defined(HPPA)) || (defined(UNIX_LINUX) && defined(M68K))) \
5374 && /* Generational GC is tricky stuff. Turn it off at safety 3. */ \
5375 (SAFETY < 3) \
5376 && /* The user can also turn off generational GC explicitly. */ \
5377 !defined(NO_GENERATIONAL_GC)
5378 #ifndef GENERATIONAL_GC
5379 #define GENERATIONAL_GC
5380 #endif
5381 #endif
5382
5383
5384 /* Put subr_tab and symbol_tab to given addresses through memory-mapping. */
5385 #if defined(SINGLEMAP_MEMORY) && !defined(WIDE_SOFT)
5386 #define MAP_MEMORY_TABLES
5387 #endif
5388
5389
5390 #ifdef SINGLEMAP_MEMORY
5391 /* Some type-bit combinations might not be allowed */
5392 #ifdef vm_addr_mask
5393 #define tint_allowed_type_mask ((oint_type_mask & vm_addr_mask) >> oint_type_shift)
5394 #endif
5395 #endif
5396
5397
5398 /* Complete the definition of the type 'gcv_object_t'. */
5399 #if defined(OBJECT_STRUCT) || defined(WIDE_STRUCT)
5400 #if defined(WIDE) && !defined(WIDE_HARD)
5401 #ifdef GENERATIONAL_GC
5402 /* The generational GC can't deal with an object-pointer that points
5403 towards two memory pages.
5404 Thus we enforce alignof(gcv_object_t) = sizeof(gcv_object_t). */
5405 #define _attribute_aligned_object_ __attribute__ ((aligned(8)))
5406 #else
5407 #define _attribute_aligned_object_
5408 #endif
5409 #endif
5410 #ifdef DEBUG_GCSAFETY
5411 struct object;
5412 struct gcv_object_t {
5413 INNARDS_OF_GCV_OBJECT
5414 /* Conversion to object. */
5415 operator object () const;
5416 /* Conversion from object. */
5417 gcv_object_t (object obj);
5418 /* Conversion from fake_gcv_object. */
5419 gcv_object_t (struct fake_gcv_object obj);
5420 /* Uninitialized object. */
5421 gcv_object_t ();
5422 };
5423 #else
5424 typedef struct { INNARDS_OF_GCV_OBJECT } gcv_object_t;
5425 #endif
5426 #endif
5427 #ifndef _attribute_aligned_object_
5428 #define _attribute_aligned_object_
5429 #endif
5430
5431
5432 /* Define the type 'object'. */
5433 #ifdef DEBUG_GCSAFETY
5434 /* A counter that is incremented each time an allocation occurs that could
5435 trigger GC. */
5436 #if defined(MULTITHREAD)
5437 /* VTZ: this is slow but there will be need of many forward declarations
5438 in order to compile. Also in GCSAFETY we do not care about peformance. */
5439 extern uintL* current_thread_alloccount (void);
5440 #define alloccount (*current_thread_alloccount())
5441 #else
5442 extern uintL alloccount;
5443 #endif
5444 /* A register-allocated object contains, if not GC-invariant, the timestamp
5445 of when it was fetched from a GC-visible location. */
5446 struct object {
5447 INNARDS_OF_GCV_OBJECT
5448 uintL allocstamp;
5449 };
5450 /* Always initialize allocstamp with the current(!) value of alloccount. */
5451 #define INIT_ALLOCSTAMP , designated_init(allocstamp,alloccount)
5452 #else
5453 typedef gcv_object_t object;
5454 #define INIT_ALLOCSTAMP
5455 #endif
5456 %% #ifdef DEBUG_GCSAFETY
5457 %% #if defined(MULTITHREAD)
5458 %% exportF(uintL*,current_thread_alloccount,(void));
5459 %% export_def(alloccount);
5460 %% #else
5461 %% exportV(uintL,alloccount);
5462 %% #endif
5463 %% #else
5464 %% emit_typedef("gcv_object_t","object");
5465 %% #endif
5466
5467 /* fake_gcv_object(value)
5468 creates a gcv_object that is actually not seen by GC,
5469 for use as second word in SKIP2 frames. */
5470 #ifdef DEBUG_GCSAFETY
5471 struct fake_gcv_object {
5472 oint fake_value;
fake_gcv_objectfake_gcv_object5473 fake_gcv_object (oint value) : fake_value (value) {}
5474 };
5475 #else
5476 #define fake_gcv_object(value) as_object((oint)(value))
5477 #endif
5478 %% #ifdef export_unwind_protect_macros
5479 %% #ifdef DEBUG_GCSAFETY
5480 %% puts("struct fake_gcv_object { oint fake_value; fake_gcv_object (oint value) : fake_value (value) {} };");
5481 %% #else
5482 %% export_def(fake_gcv_object(value));
5483 %% #endif
5484 %% #endif
5485
5486 /* Hack for use only in areas where no GC can be triggered. */
5487 #ifdef DEBUG_GCSAFETY
5488 struct gcunsafe_object_t : gcv_object_t {
5489 uintL allocstamp;
5490 /* Conversion from object. */
5491 gcunsafe_object_t (object obj);
5492 /* Conversion from gcv_object_t. */
5493 gcunsafe_object_t (gcv_object_t obj);
5494 /* Verification that no GC has been triggered. */
5495 ~gcunsafe_object_t (void);
5496 };
5497 #else
5498 typedef gcv_object_t gcunsafe_object_t;
5499 #endif
5500
5501
5502 /* mask of those bits of a tint, which really belong to the type:
5503 tint_type_mask = oint_type_mask >> oint_type_shift
5504 (a constant expression, without any 'long long's in it!) */
5505 #ifdef WIDE_SOFT
5506 #define tint_type_mask (bitm(oint_type_len)-1)
5507 #else
5508 #define tint_type_mask (oint_type_mask >> oint_type_shift)
5509 #endif
5510 %% #if notused
5511 %% export_def(tint_type_mask);
5512 %% #endif
5513
5514 /* To add something to an object/oint:
5515 objectplus(obj,offset) */
5516 #if !(defined(WIDE_SOFT) || defined(OBJECT_STRUCT))
5517 #define objectplus(obj,offset) ((object)pointerplus(obj,offset))
5518 #else /* defined(WIDE_SOFT) || defined(OBJECT_STRUCT) */
5519 #define objectplus(obj,offset) as_object(as_oint(obj)+(soint)(offset))
5520 #endif
5521 %% #if !(defined(WIDE_SOFT) || defined(OBJECT_STRUCT))
5522 %% emit_define("objectplus(obj,offset)","((object)pointerplus(obj,offset))");
5523 %% #else
5524 %% emit_define("objectplus(obj,offset)","as_object(as_oint(obj)+(soint)(offset))");
5525 %% #endif
5526
5527 /* Bit operations on entities of type uintV:
5528 ...vbit... instead of ...bit..., "v" = "value". */
5529 #if (intVsize > 32)
5530 #define vbit(n) (LL(1)<<(n))
5531 #define vbitm(n) (LL(2)<<((n)-1))
5532 #define vbit_test(x,n) ((x) & vbit(n))
5533 #define minus_vbit(n) (-LL(1)<<(n))
5534 #else
5535 #define vbit bit
5536 #define vbitm bitm
5537 #define vbit_test bit_test
5538 #define minus_vbit minus_bit
5539 #endif
5540 %% #if notused
5541 %% export_def(vbit(n));
5542 %% export_def(vbitm(n));
5543 %% export_def(vbit_test(x,n));
5544 %% export_def(minus_vbit(n));
5545 %% #endif
5546
5547 /* Bit operations on entities of type oint:
5548 ...wbit... instead of ...bit..., "w" = "wide". */
5549 #if defined(WIDE_SOFT)
5550 #define wbit(n) (LL(1)<<(n))
5551 #define wbitm(n) (LL(2)<<((n)-1))
5552 #define wbit_test(x,n) ((x) & wbit(n))
5553 #define minus_wbit(n) (-LL(1)<<(n))
5554 #else
5555 #define wbit bit
5556 #define wbitm bitm
5557 #define wbit_test bit_test
5558 #define minus_wbit minus_bit
5559 #endif
5560 %% export_def(wbit);
5561 %% #if notused
5562 %% export_def(wbitm);
5563 %% #endif
5564 %% export_def(wbit_test);
5565 %% export_def(minus_wbit);
5566
5567 #ifdef TYPECODES
5568
5569 /* Type info:
5570 typecode(object) and mtypecode(object) yield the type code of
5571 an object obj. For mtypecode it has to be in memory. */
5572 #if !(exact_uint_size_p(oint_type_len) && (tint_type_mask == bit(oint_type_len)-1))
5573 #define typecode(expr) \
5574 ((tint)(as_oint(expr) >> oint_type_shift) & (oint_type_mask >> oint_type_shift))
5575 #define mtypecode(expr) typecode(expr)
5576 #else
5577 /* The type 'tint' has exactly oint_type_len bits,
5578 and tint_type_mask = 2^oint_type_len-1.
5579 So it's not necessary for you to AND.
5580 On the other hand on a 68000 a ROL.L #8 is faster,
5581 as is a shift on a SPARC. */
5582 #define typecode(expr) ((tint)(as_oint(expr) >> oint_type_shift))
5583 #if defined(SPARC) && !defined(WIDE)
5584 #undef typecode
5585 #define typecode(expr) \
5586 ((as_oint(expr) << (32-oint_type_len-oint_type_shift)) >> (32-oint_type_len))
5587 #elif defined(WIDE) && defined(WIDE_STRUCT)
5588 #undef typecode
5589 #define typecode(expr) ((expr).u.both.type)
5590 #endif
5591 /* Furthermore you can do accesses in memory without shift: */
5592 #if !defined(WIDE) && (oint_type_len==8) && (((oint_type_shift==24) && BIG_ENDIAN_P) || ((oint_type_shift==0) && !BIG_ENDIAN_P))
5593 #define mtypecode(expr) (*(tint*)&(expr))
5594 #define fast_mtypecode
5595 #elif !defined(WIDE) && (oint_type_len==8) && (((oint_type_shift==24) && !BIG_ENDIAN_P) || ((oint_type_shift==0) && BIG_ENDIAN_P))
5596 #define mtypecode(expr) (*((tint*)&(expr)+3))
5597 #define fast_mtypecode
5598 #elif defined(WIDE)
5599 #ifdef WIDE_STRUCT
5600 #define mtypecode(expr) ((expr).u.both.type)
5601 #elif (oint_type_len==8)
5602 #if ((oint_type_shift==56) && BIG_ENDIAN_P) || ((oint_type_shift==0) && !BIG_ENDIAN_P)
5603 #define mtypecode(expr) (*(tint*)&(expr))
5604 #elif ((oint_type_shift==0) && BIG_ENDIAN_P) || ((oint_type_shift==56) && !BIG_ENDIAN_P)
5605 #define mtypecode(expr) (*((tint*)&(expr)+7))
5606 #endif
5607 #elif (oint_type_len==16)
5608 #if ((oint_type_shift==48) && BIG_ENDIAN_P) || ((oint_type_shift==0) && !BIG_ENDIAN_P)
5609 #define mtypecode(expr) (*(tint*)&(expr))
5610 #elif ((oint_type_shift==0) && BIG_ENDIAN_P) || ((oint_type_shift==48) && !BIG_ENDIAN_P)
5611 #define mtypecode(expr) (*((tint*)&(expr)+3))
5612 #endif
5613 #elif (oint_type_len==32)
5614 #if ((oint_type_shift==32) && BIG_ENDIAN_P) || ((oint_type_shift==0) && !BIG_ENDIAN_P)
5615 #define mtypecode(expr) (*(tint*)&(expr))
5616 #elif ((oint_type_shift==0) && BIG_ENDIAN_P) || ((oint_type_shift==32) && !BIG_ENDIAN_P)
5617 #define mtypecode(expr) (*((tint*)&(expr)+1))
5618 #endif
5619 #endif
5620 #define fast_mtypecode
5621 #endif
5622 #ifndef mtypecode
5623 /* no optimization is possible */
5624 #undef fast_mtypecode
5625 #define mtypecode(expr) typecode(expr)
5626 #endif
5627 #endif
5628
5629 /* Extraction of the address field without type info.
5630 untype(obj) */
5631 #if defined(WIDE) && defined(WIDE_STRUCT)
5632 #define untype(expr) ((expr).u.both.addr)
5633 #elif !(defined(SPARC) && (oint_addr_mask==bitm(oint_addr_len)-1))
5634 #define untype(expr) \
5635 ((aint)(as_oint(expr) >> oint_addr_shift) & (aint)(oint_addr_mask >> oint_addr_shift))
5636 #else
5637 /* On a SPARC processor long constants are slower than shifts.
5638 Therefore, one does not need to use AND here. */
5639 #if (oint_addr_len+oint_addr_shift<=pointer_bitsize)
5640 #define untype(expr) \
5641 (((uintP)as_oint(expr) << (pointer_bitsize-oint_addr_len-oint_addr_shift)) >> (pointer_bitsize-oint_addr_len))
5642 #else /* oint must be 64 bits wide. */
5643 #define untype(expr) \
5644 ((aint)((as_oint(expr) << (64-oint_addr_len-oint_addr_shift)) >> (64-oint_addr_len)))
5645 #endif
5646 #endif
5647
5648 /* Object from type info and address field:
5649 type_untype_object(type,address) */
5650 #if defined(WIDE) && defined(WIDE_STRUCT)
5651 #if BIG_ENDIAN_P==WIDE_ENDIANNESS
5652 #define type_untype_object(type,address) ((object){{(tint)(type),(aint)(address)}INIT_ALLOCSTAMP})
5653 #else
5654 #define type_untype_object(type,address) ((object){{(aint)(address),(tint)(type)}INIT_ALLOCSTAMP})
5655 #endif
5656 #elif !(oint_addr_shift==0)
5657 #define type_untype_object(type,address) \
5658 (as_object( ((oint)(tint)(type) << oint_type_shift) + \
5659 ((oint)(aint)(address) << oint_addr_shift) ))
5660 #else /* you don't have to shift if oint_addr_shift=0: */
5661 #if defined(WIDE_SOFT)
5662 /* Beware: Conversion of address to oint by Zero-Extend! */
5663 #define type_untype_object(type,address) \
5664 objectplus((oint)(aint)(address),(oint)(tint)(type)<<oint_type_shift)
5665 #elif defined(OBJECT_STRUCT)
5666 #define type_untype_object(type,address) \
5667 as_object((oint)pointerplus((address),(oint)(tint)(type)<<oint_type_shift))
5668 #else /* normal case */
5669 /* In order for this (NIL_IS_CONSTANT) to be a valid initializer
5670 under gcc-2.5.8, you must not cast from pointer to oint and then
5671 back to pointer, but you'll have to stay in the pointer's range.. */
5672 #define type_untype_object(type,address) \
5673 as_object(pointerplus((address),(oint)(tint)(type)<<oint_type_shift))
5674 #endif
5675 #endif
5676
5677 /* Object from type info and direct data (as "address"):
5678 type_data_object(type,data) */
5679 #if defined(WIDE) && defined(WIDE_STRUCT)
5680 #if BIG_ENDIAN_P==WIDE_ENDIANNESS
5681 #define type_data_object(type,data) ((object){{(tint)(type),(aint)(data)}INIT_ALLOCSTAMP})
5682 #else
5683 #define type_data_object(type,data) ((object){{(aint)(data),(tint)(type)}INIT_ALLOCSTAMP})
5684 #endif
5685 #elif !(oint_addr_shift==0)
5686 #define type_data_object(type,data) \
5687 (as_object( ((oint)(tint)(type) << oint_type_shift) + \
5688 ((oint)(aint)(data) << oint_addr_shift) ))
5689 #else /* if oint_addr_shift=0, you don't have to shift: */
5690 #define type_data_object(type,data) \
5691 (as_object( ((oint)(tint)(type) << oint_type_shift) + (oint)(aint)(data) ))
5692 #endif
5693
5694 /* Extraction of the address without type info:
5695 upointer(obj)
5696 (upointer means "untyped pointer".) */
5697 #if (addr_shift==0)
5698 #define upointer untype
5699 #else
5700 #define optimized_upointer(obj) \
5701 ((aint)((as_oint(obj) << (32-oint_addr_len-oint_addr_shift)) >> (32-oint_addr_len-addr_shift)))
5702 #define upointer(obj) (untype(obj)<<addr_shift)
5703 #endif
5704
5705 /* Object from type info and address:
5706 type_pointer_object(type,address) */
5707 #if defined(WIDE_SOFT) && !defined(WIDE_STRUCT)
5708 /* Cast to uintP, so that conversion of address to aint is done by Zero-Extend! */
5709 #define type_pointer_object(type,address) \
5710 type_untype_object(type,(aint)(uintP)(address)>>addr_shift)
5711 #elif (addr_shift==0)
5712 /* (No cast to aint, so NIL can be used to initialize.) */
5713 #define type_pointer_object(type,address) \
5714 type_untype_object(type,address)
5715 #else /* more efficient, */
5716 /* but this requires address to be divisible by 2^addr_shift: */
5717 #define type_pointer_object(type,address) \
5718 (as_object(((oint)(tint)(type) << oint_type_shift) + \
5719 ((oint)(aint)(address) << (oint_addr_shift-addr_shift))))
5720 #endif
5721
5722 /* Object from constant type info and constant address:
5723 type_constpointer_object(type,address) */
5724 #define type_constpointer_object(type,address) type_pointer_object(type,address)
5725
5726 /* oint from constant type info and address = 0:
5727 type_zero_oint(type) */
5728 #if defined(WIDE_SOFT) && defined(WIDE_STRUCT)
5729 #define type_zero_oint(type) as_oint(type_untype_object(type,0))
5730 #else
5731 #define type_zero_oint(type) ((oint)(tint)(type) << oint_type_shift)
5732 #endif
5733
5734 #else /* HEAPCODES */
5735
5736 #ifdef ONE_FREE_BIT_HEAPCODES
5737
5738 /* We can assume a general alignment of 4 bytes, and thus have the low 2
5739 bits for encoding type. Here's how we divide the address space:
5740 machine, frame_pointer 1/4
5741 subr 1/4
5742 cons 1/8
5743 varobject 1/4 (not 1/8 because symbol_tab is not 8-aligned)
5744 immediate > 0 (anything >= 7/256 does it).
5745 Note that cons and varobject cannot have the same encoding mod 8
5746 (otherwise gc_mark:up wouldn't work).
5747 So, here are the encodings.
5748 machine ... .00 encodes pointers, offset 0
5749 subr ... .10 encodes pointers, offset 2
5750 varobject ... .01 offset 1, the pointers are == 0 mod 4
5751 cons ... 011 offset 3, the pointers are == 0 mod 8
5752 immediate ... 111
5753 fixnum 00s 111 s = sign bit
5754 sfloat 01s 111 s = sign bit
5755 char 100 111
5756 small-read-label 110 111
5757 system 111 111
5758 Varobjects all start with a word containing the type (1 byte) and a
5759 length field (up to 24 bits). */
5760
5761 /* These are the biases, mod 8. */
5762 #define machine_bias 0UL /* mod 4 */
5763 #define subr_bias 2UL /* mod 4 */
5764 #define varobject_bias 1UL /* mod 4 */
5765 #define cons_bias 3UL /* mod 8 */
5766 #define immediate_bias 7UL /* mod 8 */
5767
5768 /* Immediate objects have a second type field,
5769 consisting of the bits imm_type_shift+2,...,imm_type_shift. */
5770
5771 /* Distinction between fixnums and bignums. */
5772 #define bignum_bit_o 1
5773 #define NUMBER_BITS_INVERTED
5774 /* Distinction between fixnums, short-floats and other kinds of numbers.
5775 (NB: IMMEDIATE_FFLOAT is not defined for HEAPCODES.) */
5776 #define number_immediatep(obj) ((as_oint(obj) & wbit(1)) != 0)
5777
5778 /* For masking out the nonimmediate biases.
5779 This must be 3, not 7, otherwise gc_mark won't work. */
5780 #define nonimmediate_bias_mask 3
5781 #define nonimmediate_heapcode_mask 3
5782
5783 /* Combine an object from type info and immediate data.
5784 type_data_object(type,data) */
5785 #define type_data_object(type,data) \
5786 (as_object( ((oint)(tint)(type) << oint_type_shift) + \
5787 ((oint)(aint)(data) << oint_data_shift) ))
5788
5789 /* An oint made up with a given type info, and address = 0.
5790 type_zero_oint(type) */
5791 #define type_zero_oint(type) ((oint)(tint)(type) << oint_type_shift)
5792
5793 /* The GC bit. Addresses may not have this bit set. */
5794 /* define garcol_bit_o (already defined above) # only set during garbage collection */
5795
5796 /* A bit mask used for testing for immediate objects types:
5797 #define immediate_object_p(obj) \
5798 ((as_oint(obj) & immediate_bias_mask) == immediate_bias)
5799 It must contain all the bits of immediate_bias. */
5800 #define immediate_bias_mask 7
5801
5802 /* Test for gc-invariant object. (This includes immediate, machine, subr.)
5803 gcinvariant_object_p(obj) */
5804 #define gcinvariant_object_p(obj) \
5805 (((as_oint(obj) & 1) == 0) || immediate_object_p(obj))
5806 #define gcinvariant_oint_p(obj_o) \
5807 ((((obj_o) & 1) == 0) || ((7 & ~(obj_o)) == 0))
5808
5809 /* Test for gc-invariant object, given only the bias. */
5810 #define gcinvariant_bias_p(bias) \
5811 ((((bias) & 1) == 0) || ((7 & ~(bias)) == 0))
5812
5813 /* The heap of a heap allocated object. 0 for varobjects, 1 for conses. */
5814 #define nonimmediate_heapnr(obj) \
5815 ((as_oint(obj) >> 1) & 1)
5816
5817 #endif /* ONE_FREE_BIT_HEAPCODES */
5818
5819 #ifdef KERNELVOID32_HEAPCODES
5820
5821 /* We must assume a general alignment of 4 bytes and an enforced alignment
5822 of 8 bytes for Lisp objects, and thus have the low 2 to 3 bits for
5823 encoding heap and the garcol_bit. Here's how we divide the address space:
5824 machine, frame_pointer 1/4 * 7/8
5825 immediate 1/4 * 1/8
5826 cons 1/8
5827 varobject 1/8
5828 Note that cons and varobject cannot have the same encoding mod 8
5829 (otherwise gc_mark:up wouldn't work).
5830 Immediates look like pointers in the range 0xC0000000..0xFFFFFFFF.
5831 We know that the Linux kernel never assigns virtual memory in this area.
5832 So, here are the encodings. Bit 0 is used as the garcol_bit.
5833 With KERNELVOID32A_HEAPCODES:
5834 machine ... ... .00 encodes pointers, offset 0
5835 cons ... ... 010 offset 2, the pointers are == 0 mod 8
5836 varobject ... ... 110 offset 6, the pointers are == 4 mod 8
5837 immediate 110 ... ... 00
5838 fixnum 110 ... 00s 00 s = sign bit
5839 sfloat 110 ... 01s 00 s = sign bit
5840 char 110 ... 100 00
5841 small-read-label 110 ... 110 00
5842 system 110 ... 111 00
5843 With KERNELVOID32B_HEAPCODES:
5844 machine ... ... .00 encodes pointers, offset 0
5845 cons ... ... 010 offset 2, the pointers are == 0 mod 8
5846 varobject ... ... 110 offset 6, the pointers are == 4 mod 8
5847 immediate 111 ... ... 00
5848 fixnum 111 ... 00s 00 s = sign bit
5849 sfloat 111 ... 01s 00 s = sign bit
5850 char 111 ... 100 00
5851 small-read-label 111 ... 110 00
5852 system 111 ... 111 00
5853 Varobjects all start with a word containing the type (1 byte) and a
5854 length field (up to 24 bits). */
5855
5856 /* These are the biases. */
5857 #define machine_bias 0 /* + 0 mod 4 */
5858 #define varobject_bias 2 /* + 4 mod 8 */
5859 #define cons_bias 2 /* + 0 mod 8 */
5860 #ifdef KERNELVOID32A_HEAPCODES
5861 #define immediate_bias 0xC0000000 /* + 0 mod 4 */
5862 #endif
5863 #ifdef KERNELVOID32B_HEAPCODES
5864 #define immediate_bias 0xE0000000 /* + 0 mod 4 */
5865 #endif
5866 #define subr_bias varobject_bias
5867
5868 /* Immediate objects have a second type field. */
5869 #define imm_type_shift 2 /* could also be 3, if oint_data_shift == 6 */
5870
5871 /* Distinction between fixnums and bignums. */
5872 #define bignum_bit_o 1
5873 /* Distinction between fixnums, short-floats and other kinds of numbers.
5874 (NB: IMMEDIATE_FFLOAT is not defined for HEAPCODES.) */
5875 #define number_immediatep(obj) ((as_oint(obj) & wbit(1)) == 0)
5876
5877 /* The misalignment of varobjects, modulo varobject_alignment. */
5878 #define varobjects_misaligned 4
5879
5880 /* For masking out the nonimmediate biases.
5881 nonimmediate_bias_mask must be <= sizeof(gcv_object_t)-1, due to the way
5882 gc_mark works. */
5883 #define nonimmediate_bias_mask 3
5884 #define nonimmediate_heapcode_mask 7
5885
5886 /* Combine an object from type info and immediate data.
5887 type_data_object(type,data) */
5888 #define type_data_object(type,data) \
5889 (as_object( ((oint)(tint)(type) << oint_type_shift) + \
5890 ((oint)(aint)(data) << oint_data_shift) ))
5891
5892 /* An oint made up with a given type info, and address = 0.
5893 type_zero_oint(type) */
5894 #define type_zero_oint(type) ((oint)(tint)(type) << oint_type_shift)
5895
5896 /* The GC bit. Addresses may not have this bit set. */
5897 /* define garcol_bit_o (already defined above) # only set during garbage collection */
5898
5899 /* A bit mask used for testing for immediate objects types:
5900 #define immediate_object_p(obj) \
5901 ((as_oint(obj) & immediate_bias_mask) == immediate_bias)
5902 It must contain all the bits of immediate_bias. */
5903 #define immediate_bias_mask 0xE0000003
5904
5905 /* Test for gc-invariant object. (This includes immediate, machine.)
5906 gcinvariant_object_p(obj) */
5907 #define gcinvariant_object_p(obj) \
5908 ((as_oint(obj) & bit(1)) == 0)
5909 #define gcinvariant_oint_p(obj_o) \
5910 (((obj_o) & bit(1)) == 0)
5911 /* NB: Subrs are not included in this test, because subrp(obj) require a
5912 memory access. */
5913
5914 /* Test for gc-invariant object, given only the bias. */
5915 #define gcinvariant_bias_p(bias) \
5916 (((bias) & 2) == 0)
5917
5918 /* The heap of a heap allocated object. 0 for varobjects, 1 for conses. */
5919 #define nonimmediate_heapnr(obj) \
5920 (1 & ~(as_oint(obj) >> 2))
5921
5922 #endif /* KERNELVOID32_HEAPCODES */
5923
5924 #ifdef GENERIC64_HEAPCODES
5925
5926 #ifdef GENERIC64A_HEAPCODES
5927
5928 /* We must assume a general alignment of 8 bytes for Lisp objects, and thus
5929 have the low 3 bits for encoding heap and the garcol_bit. Here's how we
5930 divide the address space:
5931 machine, frame_pointer 1/4 * 7/8
5932 immediate 1/4 * 1/8
5933 cons 1/8
5934 varobject 1/8
5935 Note that cons and varobject cannot have the same encoding mod 8
5936 (otherwise gc_mark:up wouldn't work).
5937 Immediates look like pointers in the range
5938 0xC000000000000000..0xFFFFFFFFFFFFFFFF.
5939 We know that the Linux kernel never assigns virtual memory in this area.
5940 So, here are the encodings. Bit 0 is used as the garcol_bit.
5941 machine ... ... 00 encodes pointers, offset 0
5942 cons ... ... 010 offset 2, the pointers are == 0 mod 8
5943 varobject ... ... 110 offset 6, the pointers are == 0 mod 8
5944 immediate 110 ... ... 00
5945 fixnum 110 ... 00s 00 s = sign bit
5946 sfloat 110 ... 01s 00 s = sign bit
5947 char 110 ... 100 00
5948 small-read-label 110 ... 110 00
5949 system 110 ... 111 00
5950 Varobjects all start with a word containing the type (1 byte) and a
5951 length field (up to 24 bits). */
5952
5953 /* These are the biases. */
5954 #define machine_bias 0 /* + 0 mod 4 */
5955 #define varobject_bias 6 /* + 0 mod 8 */
5956 #define cons_bias 2 /* + 0 mod 8 */
5957 #define immediate_bias 0xC000000000000000UL /* + 0 mod 8 */
5958 #define subr_bias varobject_bias
5959
5960 /* Immediate objects have a second type field. */
5961 #define imm_type_shift 2 /* could also be 3, if oint_data_shift == 6 */
5962
5963 #endif /* GENERIC64A_HEAPCODES */
5964
5965 #ifdef GENERIC64B_HEAPCODES
5966
5967 /* We must assume a general alignment of 8 bytes for Lisp objects, and thus
5968 have the low 3 bits for encoding heap and the garcol_bit. Here's how we
5969 divide the address space:
5970 machine, frame_pointer 1/4 * 7/8
5971 immediate 1/8 * 1/8
5972 cons 1/8
5973 varobject 1/8
5974 Note that cons and varobject cannot have the same encoding mod 8
5975 (otherwise gc_mark:up wouldn't work).
5976 So, here are the encodings. Bit 0 is used as the garcol_bit.
5977 machine ... ... 00 encodes pointers, offset 0
5978 cons ... ... 010 offset 2, the pointers are == 0 mod 8
5979 varobject ... ... 110 offset 6, the pointers are == 0 mod 8
5980 immediate 110 ... ... 100
5981 fixnum 110 ... 00s 100 s = sign bit
5982 sfloat 110 ... 01s 100 s = sign bit
5983 char 110 ... 100 100
5984 small-read-label 110 ... 110 100
5985 system 110 ... 111 100
5986 Varobjects all start with a word containing the type (1 byte) and a
5987 length field (up to 24 bits). */
5988
5989 /* These are the biases. */
5990 #define machine_bias 0 /* + 0 mod 4 */
5991 #define varobject_bias 6 /* + 0 mod 8 */
5992 #define cons_bias 2 /* + 0 mod 8 */
5993 #define immediate_bias 0xC000000000000004UL /* + 0 mod 8 */
5994 #define subr_bias varobject_bias
5995
5996 /* Immediate objects have a second type field. */
5997 #define imm_type_shift 3 /* relies on oint_data_shift == 6 */
5998
5999 #endif /* GENERIC64B_HEAPCODES */
6000
6001 #ifdef GENERIC64C_HEAPCODES
6002
6003 /* We must assume a general alignment of 8 bytes for Lisp objects, and thus
6004 have the low 3 bits for encoding heap and the garcol_bit. Here's how we
6005 divide the address space:
6006 machine, frame_pointer 1/8
6007 immediate 1/8
6008 cons 1/8
6009 varobject 1/8
6010 Note that cons and varobject cannot have the same encoding mod 8
6011 (otherwise gc_mark:up wouldn't work).
6012 So, here are the encodings. Bit 0 is used as the garcol_bit.
6013 machine ... ... 000 encodes pointers, offset 0
6014 cons ... ... 010 offset 2, the pointers are == 0 mod 8
6015 varobject ... ... 110 offset 6, the pointers are == 0 mod 8
6016 immediate ... ... 100
6017 fixnum ... 00s 100 s = sign bit
6018 sfloat ... 01s 100 s = sign bit
6019 char ... 100 100
6020 small-read-label ... 110 100
6021 system ... 111 100
6022 Varobjects all start with a word containing the type (1 byte) and a
6023 length field (up to 24 bits). */
6024
6025 /* These are the biases. */
6026 #define machine_bias 0 /* + 0 mod 8 */
6027 #define varobject_bias 6 /* + 0 mod 8 */
6028 #define cons_bias 2 /* + 0 mod 8 */
6029 #define immediate_bias 4 /* + 0 mod 8 */
6030 #define subr_bias varobject_bias
6031
6032 /* Immediate objects have a second type field. */
6033 #define imm_type_shift 3 /* relies on oint_data_shift == 6 */
6034
6035 #endif /* GENERIC64C_HEAPCODES */
6036
6037 /* Distinction between fixnums and bignums. */
6038 #define bignum_bit_o 1
6039 /* Distinction between fixnums, short-floats and other kinds of numbers.
6040 (NB: IMMEDIATE_FFLOAT is not defined for HEAPCODES.) */
6041 #define number_immediatep(obj) ((as_oint(obj) & wbit(1)) == 0)
6042
6043 /* For masking out the nonimmediate biases. */
6044 #define nonimmediate_bias_mask 7
6045 #define nonimmediate_heapcode_mask 7
6046
6047 /* Combine an object from type info and immediate data.
6048 type_data_object(type,data) */
6049 #define type_data_object(type,data) \
6050 (as_object( ((oint)(tint)(type) << oint_type_shift) + \
6051 ((oint)(aint)(data) << oint_data_shift) ))
6052
6053 /* An oint made up with a given type info, and address = 0.
6054 type_zero_oint(type) */
6055 #define type_zero_oint(type) ((oint)(tint)(type) << oint_type_shift)
6056
6057 /* The GC bit. Addresses may not have this bit set. */
6058 /* define garcol_bit_o (already defined above) # only set during garbage collection */
6059
6060 /* A bit mask used for testing for immediate objects types:
6061 #define immediate_object_p(obj) \
6062 ((as_oint(obj) & immediate_bias_mask) == immediate_bias)
6063 It must contain all the bits of immediate_bias. */
6064 #ifdef GENERIC64A_HEAPCODES
6065 #define immediate_bias_mask 0xE000000000000003UL
6066 #endif
6067 #ifdef GENERIC64B_HEAPCODES
6068 #define immediate_bias_mask 0xE000000000000007UL
6069 #endif
6070 #ifdef GENERIC64C_HEAPCODES
6071 #define immediate_bias_mask 7
6072 #endif
6073
6074 /* Test for gc-invariant object. (This includes immediate, machine.)
6075 gcinvariant_object_p(obj) */
6076 #define gcinvariant_object_p(obj) \
6077 ((as_oint(obj) & bit(1)) == 0)
6078 #define gcinvariant_oint_p(obj_o) \
6079 (((obj_o) & bit(1)) == 0)
6080 /* NB: Subrs are not included in this test, because subrp(obj) require a
6081 memory access. */
6082
6083 /* Test for gc-invariant object, given only the bias. */
6084 #define gcinvariant_bias_p(bias) \
6085 (((bias) & 2) == 0)
6086
6087 /* The heap of a heap allocated object. 0 for varobjects, 1 for conses. */
6088 #define nonimmediate_heapnr(obj) \
6089 (1 & ~(as_oint(obj) >> 2))
6090
6091 #endif /* GENERIC64_HEAPCODES */
6092
6093 /* The types of immediate objects. */
6094 #define fixnum_type ((0 << imm_type_shift) + immediate_bias)
6095 #define sfloat_type ((2 << imm_type_shift) + immediate_bias)
6096 #define char_type ((4 << imm_type_shift) + immediate_bias)
6097 #define small_read_label_type ((6 << imm_type_shift) + immediate_bias)
6098 #define system_type ((7 << imm_type_shift) + immediate_bias)
6099
6100 /* The sign bit, for immediate numbers only. */
6101 #define sign_bit_t (0 + imm_type_shift)
6102 #define sign_bit_o (sign_bit_t+oint_type_shift)
6103
6104 /* Test for immediate object.
6105 immediate_object_p(obj) */
6106 #if (immediate_bias_mask == immediate_bias)
6107 /* Small optimization */
6108 #define immediate_object_p(obj) \
6109 ((immediate_bias_mask & ~as_oint(obj)) == 0)
6110 #else
6111 #define immediate_object_p(obj) \
6112 ((as_oint(obj) & immediate_bias_mask) == immediate_bias)
6113 #endif
6114
6115 #endif /* TYPECODES */
6116 %% #ifdef TYPECODES
6117 %% export_def(typecode(expr));
6118 %% export_def(mtypecode(expr));
6119 %% export_def(type_untype_object(type,address));
6120 %% export_def(upointer(obj));
6121 %% export_def(type_pointer_object(type,address));
6122 %% export_def(type_constpointer_object(type,address));
6123 %% #else
6124 %% export_def(number_immediatep(obj));
6125 %% export_def(immediate_object_p(obj));
6126 %% export_def(gcinvariant_object_p(obj));
6127 %% export_def(gcinvariant_oint_p(obj_o));
6128 %% export_def(gcinvariant_bias_p(bias));
6129 %% #endif
6130 %% export_def(type_data_object(type,address));
6131 %% export_def(type_zero_oint(obj));
6132
6133 /* The misalignment of varobjects, modulo varobject_alignment. */
6134 #ifndef varobjects_misaligned
6135 #define varobjects_misaligned 0
6136 #endif
6137 #if varobjects_misaligned
6138 #define VAROBJECTS_ALIGNMENT_DUMMY_DECL char alignment_dummy[varobjects_misaligned];
6139 #else
6140 #define VAROBJECTS_ALIGNMENT_DUMMY_DECL
6141 #endif
6142 %% export_def(varobjects_misaligned);
6143 %% export_def(VAROBJECTS_ALIGNMENT_DUMMY_DECL);
6144 /* If varobjects are misaligned, fields of varobjects must be aligned on 4-byte
6145 boundaries only, even if they are of type 'double' or 'uint64'. This is
6146 necessary for KERNELVOID32_HEAPCODES on Linux/sparc and NetBSD/sparc. */
6147 #if defined(GNU) && varobjects_misaligned
6148 #define _attribute_in_misaligned_varobjects_ __attribute__ ((packed, aligned (4)))
6149 #else
6150 #define _attribute_in_misaligned_varobjects_
6151 #endif
6152 %% #if defined(GNU) && varobjects_misaligned
6153 %% #define attribute_in_misaligned_varobjects " __attribute__ ((packed, aligned (4)))"
6154 %% #else
6155 %% #define attribute_in_misaligned_varobjects ""
6156 %% #endif
6157
6158 /* The misalignment of conses, modulo 2*sizeof(gcv_object_t).
6159 Note: It is more efficient w.r.t. to the data cache to misalign the
6160 varobjects than the conses. */
6161 #ifndef conses_misaligned
6162 #define conses_misaligned 0
6163 #endif
6164
6165
6166 /* Pointers that are arguments of make_machine() must have a certain
6167 alignment. */
6168 #ifdef TYPECODES
6169 #define PSEUDODATA_ALIGNMENT 1
6170 #define log2_PSEUDODATA_ALIGNMENT 0
6171 #else /* HEAPCODES */
6172 #ifdef GENERIC64C_HEAPCODES
6173 /* See above: machine ... ... 000 */
6174 #define PSEUDODATA_ALIGNMENT 8
6175 #define log2_PSEUDODATA_ALIGNMENT 3
6176 #else
6177 /* See above: machine ... ... 00 */
6178 #define PSEUDODATA_ALIGNMENT 4
6179 #define log2_PSEUDODATA_ALIGNMENT 2
6180 #endif
6181 #endif
6182
6183
6184 /* Objects with variable length must reside at addresses that are divisible
6185 by 2 or 4 or 8. This alignment should be so large as to avoid misaligned
6186 accesses to 'long' and especially 'double' fields in varobjects.
6187 Look
6188 1. at alignof(long), alignof(double) (matters only if FAST_DOUBLE),
6189 2. at the definition of BIGGEST_ALIGNMENT and BIGGEST_FIELD_ALIGNMENT in
6190 gcc-5.4.0/gcc/config/<cpu>/<cpu>.h, divided by 8. */
6191 #if defined(M68K)
6192 #if addr_shift!=0
6193 #define varobject_alignment bit(addr_shift) /* because of the condensed distribution of typecodes */
6194 #else
6195 #define varobject_alignment 2
6196 #endif
6197 #endif
6198 #if defined(I80386) || defined(POWERPC) || defined(ARM) || defined(S390)
6199 #define varobject_alignment 4
6200 #endif
6201 #if defined(SPARC) || defined(HPPA) || defined(MIPS) || defined(DECALPHA) || defined(IA64) || defined(AMD64) || defined(ARM64) || defined(RISCV64)
6202 #define varobject_alignment 8
6203 #endif
6204 #if (!defined(TYPECODES) || defined(GENERATIONAL_GC)) && (varobject_alignment < 4)
6205 #undef varobject_alignment
6206 #define varobject_alignment 4
6207 #endif
6208 #if ((defined(GENERATIONAL_GC) && defined(WIDE)) || defined(KERNELVOID32_HEAPCODES) || defined(GENERIC64_HEAPCODES)) && (varobject_alignment < 8)
6209 #undef varobject_alignment
6210 #define varobject_alignment 8
6211 #endif
6212 /* varobject_alignment should be defined: */
6213 #ifndef varobject_alignment
6214 #error varobject_alignment depends on CPU -- readjust varobject_alignment!!
6215 #endif
6216 /* varobject_alignment should be a power of 2: */
6217 #if !((varobject_alignment & (varobject_alignment-1)) ==0)
6218 #error Bogus varobject_alignment -- readjust varobject_alignment!!
6219 #endif
6220 /* varobject_alignment should be a multiple of 2^addr_shift : */
6221 #if (varobject_alignment % bit(addr_shift))
6222 #error Bogus varobject_alignment -- readjust varobject_alignment!!
6223 #endif
6224 %% export_def(varobject_alignment);
6225
6226 /* In some cases it is required that sizeof(symbol_) is a multiple of varobject_alignment.
6227 - When KERNELVOID32_HEAPCODES || GENERIC64_HEAPCODES.
6228 - When MAP_MEMORY_TABLES, because symbol_tab_data (with elements of size sizeof(symbol_))
6229 gets copied to symbol_tab (into the heap, where varobject_alignment is a requirement). */
6230 #if defined(KERNELVOID32_HEAPCODES) || defined(GENERIC64_HEAPCODES) || defined(MAP_MEMORY_TABLES)
6231 #define sizeof_symbol_is_multiple_of_varobject_alignment
6232 #endif
6233
6234
6235 #ifdef TYPECODES
6236
6237 /* Now we'll define the various type bits and type codes. */
6238
6239 /* Single-floats can be immediate objects, like short-floats, if there are
6240 enough bits in a 'gcv_object_t'. */
6241 #if defined(WIDE_HARD) || defined(WIDE_SOFT)
6242 #define IMMEDIATE_FFLOAT
6243 #endif
6244
6245 /* Determine whether a type isn't changed by the GC
6246 (ie. if it's not a pointer): */
6247 #if 0 && (defined(GNU) || defined(INTEL))
6248 #define gcinvariant_type_p(type) \
6249 ({var bool _erg; \
6250 switch (type) \
6251 { case_machine: \
6252 case_char: case_subr: case_system: \
6253 case_fixnum: case_sfloat: \
6254 /* with WIDE also: case_ffloat: */ \
6255 _erg = true; break; \
6256 default: _erg = false; break; \
6257 } \
6258 _erg; \
6259 })
6260 #endif
6261
6262 #ifndef tint_allowed_type_mask
6263 #define tint_allowed_type_mask tint_type_mask
6264 #endif
6265
6266 /* There are 7 to 8 type bits available: TB7, [TB6,] TB5, TB4, ..., TB0.
6267 All of them have to be set in tint_allowed_type_mask and thus in tint_type_mask as well
6268 We distribute them under the assumption that only one bit is missing in tint_type_mask.
6269 TB6 will be set to -1, if it can't be used. */
6270 #if defined(SINGLEMAP_MEMORY)
6271 /* TB7 will be used as garcol_bit.
6272 bit(TB7)|SINGLEMAP_ADDRESS_BASE does not need to be a mappable address. */
6273 #if defined(garcol_bit_o)
6274 #define TB7 (garcol_bit_o-oint_type_shift)
6275 #else
6276 #if ((oint_type_mask >> (oint_type_len-1 + oint_type_shift)) & 1) != 0
6277 #define TB7 (oint_type_len-1)
6278 #elif ((oint_type_mask >> (oint_type_len-2 + oint_type_shift)) & 1) != 0
6279 #define TB7 (oint_type_len-2)
6280 #else
6281 #error What is the right value for TB7?
6282 #endif
6283 #endif
6284 /* The other bits must be allocated in tint_type_mask.
6285 Assume tint_type_mask has 6..7 bits and up to 3 "holes". */
6286 #if (((tint_type_mask >> 0) & 1) != 0) && (0 != TB7)
6287 #define TB0 0
6288 #endif
6289 #if (((tint_type_mask >> 1) & 1) != 0) && (1 != TB7)
6290 #if !defined(TB0)
6291 #define TB0 1
6292 #else
6293 #define TB1 1
6294 #endif
6295 #endif
6296 #if (((tint_type_mask >> 2) & 1) != 0) && (2 != TB7)
6297 #if !defined(TB0)
6298 #define TB0 2
6299 #elif !defined(TB1)
6300 #define TB1 2
6301 #else
6302 #define TB2 2
6303 #endif
6304 #endif
6305 #if (((tint_type_mask >> 3) & 1) != 0) && (3 != TB7)
6306 #if !defined(TB0)
6307 #define TB0 3
6308 #elif !defined(TB1)
6309 #define TB1 3
6310 #elif !defined(TB2)
6311 #define TB2 3
6312 #else
6313 #define TB3 3
6314 #endif
6315 #endif
6316 #if (((tint_type_mask >> 4) & 1) != 0) && (4 != TB7)
6317 #if !defined(TB1)
6318 #define TB1 4
6319 #elif !defined(TB2)
6320 #define TB2 4
6321 #elif !defined(TB3)
6322 #define TB3 4
6323 #else
6324 #define TB4 4
6325 #endif
6326 #endif
6327 #if (((tint_type_mask >> 5) & 1) != 0) && (5 != TB7)
6328 #if !defined(TB2)
6329 #define TB2 5
6330 #elif !defined(TB3)
6331 #define TB3 5
6332 #elif !defined(TB4)
6333 #define TB4 5
6334 #else
6335 #define TB5 5
6336 #endif
6337 #endif
6338 #if (((tint_type_mask >> 6) & 1) != 0) && (6 != TB7)
6339 #if !defined(TB3)
6340 #define TB3 6
6341 #elif !defined(TB4)
6342 #define TB4 6
6343 #elif !defined(TB5)
6344 #define TB5 6
6345 #else
6346 #define TB6 6
6347 #endif
6348 #endif
6349 #if (((tint_type_mask >> 7) & 1) != 0) && (7 != TB7)
6350 #if !defined(TB4)
6351 #define TB4 7
6352 #elif !defined(TB5)
6353 #define TB5 7
6354 #elif !defined(TB6)
6355 #define TB6 7
6356 #endif
6357 #endif
6358 #if (((tint_type_mask >> 8) & 1) != 0) && (8 != TB7)
6359 #if !defined(TB5)
6360 #define TB5 8
6361 #elif !defined(TB6)
6362 #define TB6 8
6363 #endif
6364 #endif
6365 #if (((tint_type_mask >> 9) & 1) != 0) && (9 != TB7)
6366 #if !defined(TB6)
6367 #define TB6 9
6368 #endif
6369 #endif
6370 #if !defined(TB6)
6371 #define TB6 -1
6372 #endif
6373 #else
6374 /* In the normal TYPECODES model, the type bits are packed into 8 bits. */
6375 #if ((0xFF & ~tint_allowed_type_mask) == 0)
6376 #define TB7 7
6377 #define TB6 6
6378 #define TB5 5
6379 #define TB4 4
6380 #define TB3 3
6381 #define TB2 2
6382 #define TB1 1
6383 #define TB0 0
6384 #elif (oint_type_len==7)
6385 #define TB7 6
6386 #define TB6 -1
6387 #define TB5 5
6388 #define TB4 4
6389 #define TB3 3
6390 #define TB2 2
6391 #define TB1 1
6392 #define TB0 0
6393 #else
6394 /* Some bits have to be avoided */
6395 #define tint_avoid ((bitm(oint_type_len)-1) & ~tint_allowed_type_mask)
6396 /* tint_avoid must only contain one bit: */
6397 #if (tint_avoid & (tint_avoid-1))
6398 #error Bogus oint_type_mask -- oint_type_mask has more than one extraneous bit!!
6399 #endif
6400 /* tint_avoid consists of exactly one bit that has to be avoided. */
6401 #if (tint_avoid > bit(0))
6402 #define TB0 0
6403 #else
6404 #define TB0 1
6405 #endif
6406 #if (tint_avoid > bit(1))
6407 #define TB1 1
6408 #else
6409 #define TB1 2
6410 #endif
6411 #if (tint_avoid > bit(2))
6412 #define TB2 2
6413 #else
6414 #define TB2 3
6415 #endif
6416 #if (tint_avoid > bit(3))
6417 #define TB3 3
6418 #else
6419 #define TB3 4
6420 #endif
6421 #if (tint_avoid > bit(4))
6422 #define TB4 4
6423 #else
6424 #define TB4 5
6425 #endif
6426 #if (tint_avoid > bit(5))
6427 #define TB5 5
6428 #else
6429 #define TB5 6
6430 #endif
6431 #if ((tint_allowed_type_mask & ~0xFF) == 0)
6432 #define TB6 -1
6433 #if (tint_avoid > bit(6))
6434 #define TB7 6
6435 #else
6436 #define TB7 7
6437 #endif
6438 #else
6439 #if (tint_avoid > bit(6))
6440 #define TB6 6
6441 #else
6442 #define TB6 7
6443 #endif
6444 #if (tint_avoid > bit(7))
6445 #define TB7 7
6446 #else
6447 #define TB7 8
6448 #endif
6449 #endif
6450 #endif
6451 #endif
6452
6453 /* bit masks for the type bits: */
6454 #define BTB0 bit(TB0)
6455 #define BTB1 bit(TB1)
6456 #define BTB2 bit(TB2)
6457 #define BTB3 bit(TB3)
6458 #define BTB4 bit(TB4)
6459 #define BTB5 bit(TB5)
6460 #define BTB6 bit(TB6)
6461 #define BTB7 bit(TB7)
6462
6463 #define STANDARD_8BIT_TYPECODES
6464
6465 #ifdef STANDARD_8BIT_TYPECODES
6466
6467 #if defined(I80386) && defined(UNIX_LINUX) && (CODE_ADDRESS_RANGE == 0)
6468 /* At 0x60000000 there are the shared-libraries.
6469 At 0x50000000 (Linux 1.2) resp. 0x40000000 (Linux 2.0) there are several
6470 mmap-pages,for example ones allocated by setlocale() or gettext().
6471 Therefore we only have to do a few changes to the distribution of the type codes. */
6472 #endif
6473
6474 #if defined(I80386) && defined(UNIX_LINUX) && (CODE_ADDRESS_RANGE != 0)
6475 /* Code and malloc memory is at 0x08000000.
6476 Therefore avoid allocating typecode 0x08 for the moment. */
6477 #endif
6478
6479 #if (defined(M68K) || defined(SPARC)) && defined(UNIX_LINUX)
6480 /* At 0x50000000 there are shared libraries located.
6481 But this doesn't mean we have to change the type code distribution. */
6482 #endif
6483
6484 #if (defined(MIPS) || defined(POWERPC)) && defined(UNIX_LINUX)
6485 /* At 0x2AAAB000 there are shared libraries located.
6486 But this doesn't mean we have to change the type code distribution. */
6487 #endif
6488
6489 #if defined(DECALPHA) && defined(UNIX_OSF) && !(defined(NO_SINGLEMAP) || defined(NO_TRIVIALMAP))
6490 /* mmap() only works with addresses >=0, <2^38, but since ordinary pointers are in the range
6491 1*2^32..2*2^32, only the Bits 37..33 remain as type-bits. */
6492 #endif
6493
6494 #if defined(SPARC64) && defined(UNIX_LINUX)
6495 /* At 0x70000000 there are shared libraries located.
6496 But this doesn't mean we have to change the type code distribution. */
6497 #endif
6498
6499 /* Type bits:
6500 in Typcodes (tint): */
6501 #define garcol_bit_t TB7 /* only set during GC */
6502 #if (TB6 >= 0)
6503 #define cons_bit_t TB6 /* only set for CONS */
6504 #endif
6505 #define number_bit_t TB5 /* only set for numbers */
6506 #define notsimple_bit_t TB3 /* for arrays: deleted for simple arrays */
6507 #define sign_bit_t TB0 /* Sign for real numbers (set <==> number <0) */
6508 #define float_bit_t TB1
6509 #define float1_bit_t TB3
6510 #define float2_bit_t TB2
6511 #define ratio_bit_t TB3
6512 #define bignum_bit_t TB2
6513 /* in Objects (oint): */
6514 #if !defined(garcol_bit_o)
6515 #define garcol_bit_o (garcol_bit_t+oint_type_shift) /* only set during the garbage collection! */
6516 #else
6517 /* Verify garcol_bit_o has the expected value. */
6518 #if !(garcol_bit_o == (garcol_bit_t+oint_type_shift))
6519 #error garcol_bit_o already defined, but is not consistent with TB7!
6520 #endif
6521 #endif
6522 #if (TB6 >= 0)
6523 #define cons_bit_o (cons_bit_t+oint_type_shift) /* only set for cons CONS */
6524 #endif
6525 #define number_bit_o (number_bit_t+oint_type_shift) /* only set for numbers */
6526 #define notsimple_bit_o (notsimple_bit_t+oint_type_shift) /* for arrays: deleted for simple arrays */
6527 #define sign_bit_o (sign_bit_t+oint_type_shift) /* Sign for real numbers */
6528 #define float_bit_o (float_bit_t+oint_type_shift)
6529 #define float1_bit_o (float1_bit_t+oint_type_shift)
6530 #define float2_bit_o (float2_bit_t+oint_type_shift)
6531 #define ratio_bit_o (ratio_bit_t+oint_type_shift)
6532 #define bignum_bit_o (bignum_bit_t+oint_type_shift)
6533
6534 /* constant type codes: */
6535 #define machine_type (0) /* 0x00 # %00000000 ; machine pointer */
6536 #define subr_type ( BTB0) /* 0x01 # %00000001 ; SUBR */
6537 #define char_type ( BTB1 ) /* 0x02 # %00000010 ; character */
6538 #define system_type ( BTB1|BTB0) /* 0x03 # %00000011 ; frame-pointer, small-read-label, system */
6539 #define symbol_type ( BTB2 ) /* 0x04 # %000001xx ; symbol */
6540 /* bits for symbols in the GCself pointer: */
6541 #define var_bit0_t TB0 /* set if the symbol is proclaimed SPECIAL or constant */
6542 #define var_bit1_t TB1 /* set if the symbol is a symbol-macro or constant */
6543 #if (TB6 < 0)
6544 #define cons_type ( BTB3 ) /* 0x08 # %00001000 ; cons */
6545 #endif
6546 #define closure_type ( BTB3 |BTB0) /* 0x09 # %00001001 ; closure */
6547 #define structure_type ( BTB3 |BTB1 ) /* 0x0A # %00001010 ; structure */
6548 #define stream_type ( BTB3 |BTB1|BTB0) /* 0x0B # %00001011 ; stream */
6549 #define orecord_type ( BTB3|BTB2 ) /* 0x0C # %00001100 ; OtherRecord (Package, Byte, ...) */
6550 #define instance_type ( BTB3|BTB2 |BTB0) /* 0x0D # %00001101 ; CLOS instance */
6551 #define lrecord_type ( BTB3|BTB2|BTB1 ) /* 0x0E # %00001110 ; LongRecord (WeakList, WeakAlist, ...) */
6552 #define mdarray_type ( BTB3|BTB2|BTB1|BTB0) /* 0x0F # %00001111 ; other array (rank/=1 or other eltype) */
6553 #define sbvector_type ( BTB4 ) /* 0x10 # %00010000 ; simple-bit-vector */
6554 #define sb2vector_type ( BTB4 |BTB0) /* 0x11 # %00010001 ; simple (VECTOR (UNSIGNED-BYTE 2)) */
6555 #define sb4vector_type ( BTB4 |BTB1 ) /* 0x12 # %00010010 ; simple (VECTOR (UNSIGNED-BYTE 4)) */
6556 #define sb8vector_type ( BTB4 |BTB1|BTB0) /* 0x13 # %00010011 ; simple (VECTOR (UNSIGNED-BYTE 8)) */
6557 #define sb16vector_type ( BTB4 |BTB2 ) /* 0x14 # %00010100 ; simple (VECTOR (UNSIGNED-BYTE 16)) */
6558 #define sb32vector_type ( BTB4 |BTB2 |BTB0) /* 0x15 # %00010101 ; simple (VECTOR (UNSIGNED-BYTE 32)) */
6559 #define sstring_type ( BTB4 |BTB2|BTB1 ) /* 0x16 # %00010110 ; simple-string */
6560 #define svector_type ( BTB4 |BTB2|BTB1|BTB0) /* 0x17 # %00010111 ; simple-vector */
6561 #define bvector_type ( BTB4|BTB3 ) /* 0x18 # %00011000 ; non-simple bit-vector */
6562 #define b2vector_type ( BTB4|BTB3 |BTB0) /* 0x19 # %00011001 ; non-simple (VECTOR (UNSIGNED-BYTE 2)) */
6563 #define b4vector_type ( BTB4|BTB3 |BTB1 ) /* 0x1A # %00011010 ; non-simple (VECTOR (UNSIGNED-BYTE 4)) */
6564 #define b8vector_type ( BTB4|BTB3 |BTB1|BTB0) /* 0x1B # %00011011 ; non-simple (VECTOR (UNSIGNED-BYTE 8)) */
6565 #define b16vector_type ( BTB4|BTB3|BTB2 ) /* 0x1C # %00011100 ; non-simple (VECTOR (UNSIGNED-BYTE 16)) */
6566 #define b32vector_type ( BTB4|BTB3|BTB2 |BTB0) /* 0x1D # %00011101 ; non-simple (VECTOR (UNSIGNED-BYTE 32)) */
6567 #define string_type ( BTB4|BTB3|BTB2|BTB1 ) /* 0x1E # %00011110 ; non-simple string */
6568 #define vector_type ( BTB4|BTB3|BTB2|BTB1|BTB0) /* 0x1F # %00011111 ; non-simple (VECTOR T) */
6569 #define fixnum_type ( BTB5 ) /* 0x20 # %00100000 ; fixnum */
6570 #define sfloat_type ( BTB5 |BTB1 ) /* 0x22 # %00100010 ; short-float */
6571 #define bignum_type ( BTB5 |BTB2 ) /* 0x24 # %00100100 ; bignum */
6572 #define ffloat_type ( BTB5 |BTB2|BTB1 ) /* 0x26 # %00100110 ; single-float */
6573 #define ratio_type ( BTB5 |BTB3 ) /* 0x28 # %00101000 ; ratio */
6574 #define dfloat_type ( BTB5 |BTB3 |BTB1 ) /* 0x2A # %00101010 ; double-float */
6575 #define complex_type ( BTB5 |BTB3|BTB2 ) /* 0x2C # %00101100 ; complex */
6576 #define lfloat_type ( BTB5 |BTB3|BTB2|BTB1 ) /* 0x2E # %00101110 ; long-float */
6577 #if (TB6 >= 0)
6578 #define cons_type (BTB6 ) /* 0x40 # %01000000 ; cons */
6579 #endif
6580
6581 /* Bits for symbols in VAR/FUN-Frames (in LISP-Stack): */
6582 #define active_bit 0 /* set: binding is active */
6583 #define dynam_bit 1 /* set: binding is dynamic */
6584 #define svar_bit 2 /* set: next parameter is supplied-p-parameter for this */
6585 /* If symbols are always on addresses divisible by 8, we can store
6586 these bits in the symbol pointer.
6587 There are
6588 1) symbols in the heap - these have the alignment varobject_alignment.
6589 2) symbols in the symbol_tab_data - their alignment is:
6590 if sizeof_symbol_is_multiple_of_varobject_alignment is defined:
6591 varobject_alignment
6592 otherwise:
6593 alignof(symbol_) = alignment_long. */
6594 #if (varobject_alignment >= bit(3)) \
6595 && ((defined(sizeof_symbol_is_multiple_of_varobject_alignment) ? varobject_alignment : alignment_long) >= bit(3)) \
6596 && !defined(NO_SYMBOLFLAGS)
6597 /* Store them in the oint_addr part, not in the oint_type part. */
6598 #define oint_symbolflags_shift oint_addr_shift
6599 #else
6600 /* There's no space in the symbol for active_bit, dynam_bit, svar_bit.
6601 Use an extra word on the LISP-stack. */
6602 #define NO_symbolflags
6603 #endif
6604
6605 #ifndef IMMEDIATE_FFLOAT
6606 /* type is GC-invariant, if
6607 type-info-byte >=0, <= system_type or >= fixnum_type, < bignum_type. */
6608 #define gcinvariant_type_p(type) \
6609 (((type) & ~(BTB5|BTB1|BTB0)) == 0)
6610 #else
6611 /* type is GC-invariant, if
6612 type-info-byte is one of 0x00..0x03,0x20..0x23,0x26..0x27 ist. */
6613 #if (TB1==TB0+1) && (TB2==TB0+2) && (TB3==TB0+3) && (TB4==TB0+4) && (TB5==TB0+5)
6614 #define gcinvariant_type_p(type) \
6615 ((((type)>>(TB0+1))<0x14) && ((bit((type)>>(TB0+1)) & 0xFFF4FFFCUL) == 0))
6616 #else
6617 /* Test whether ((type)>>TB1) is one of
6618 0, 1, bit(TB5-TB1), bit(TB5-TB1) | 1, bit(TB5-TB1) | bit(TB2-TB1) | 1. */
6619 #define gcinvariant_type_p(type) gcinvariant_type_aux((type)>>TB1)
6620 #define gcinvariant_type_sum(type) \
6621 (((type) | ((type)>>(TB5-(TB2+1)))) & (((BTB2<<1)+BTB2+BTB1)>>TB1))
6622 #define gcinvariant_type_aux(type) \
6623 (((type) < ((BTB5+(BTB2<<1))>>TB1)) \
6624 && ((type) & ~((BTB5|BTB2|BTB1)>>TB1)) == 0 \
6625 && (bit(gcinvariant_type_sum(type)) \
6626 & ( bit(0) \
6627 | bit(1) \
6628 | bit(bit(TB2+1-TB1)) \
6629 | bit(bit(TB2+1-TB1) | 1) \
6630 | bit(bit(TB2+1-TB1) | bit(TB2-TB1) | 1))) != 0)
6631 #endif
6632 #endif
6633
6634 #endif /* STANDARD_8BIT_TYPECODES */
6635
6636 #if !(gcinvariant_type_p(ffloat_type) == defined(IMMEDIATE_FFLOAT))
6637 #error gcinvariant_type_p() incorrectly implemented!
6638 #endif
6639
6640 /* Test for gc-invariant object. (This includes immediate, machine, subr.)
6641 gcinvariant_object_p(obj) */
6642 #define gcinvariant_object_p(obj) \
6643 gcinvariant_type_p(typecode(obj))
6644 #define gcinvariant_oint_p(obj_o) \
6645 gcinvariant_type_p((tint)((obj_o) >> oint_type_shift) & (oint_type_mask >> oint_type_shift))
6646
6647 #else /* no TYPECODES */
6648
6649 /* Bits for symbols in VAR/FUN-Frames (on LISP-Stack):
6650 are not located in the oint_type-part, but in the oint_data-part. */
6651 #define active_bit 0 /* set: binding is active */
6652 #define dynam_bit 1 /* set: binding is dynamic */
6653 #define svar_bit 2 /* set: next parameter is supplied-p-parameter for this one */
6654 #define NO_symbolflags /* there's no space in the symbol for active_bit, dynam_bit, svar_bit */
6655
6656 /* Bits for symbols in the flags: */
6657 #define var_bit0_f 0 /* set if the symbol is proclaimed SPECIAL or constant */
6658 #define var_bit1_f 1 /* set if the symbol is a symbol-macro or constant */
6659
6660 #endif /* TYPECODES */
6661 %% #ifdef TYPECODES
6662 %% export_def(gcinvariant_type_p(type));
6663 %% export_def(gcinvariant_type_sum(type));
6664 %% export_def(gcinvariant_type_aux(type));
6665 %% export_def(gcinvariant_object_p(obj));
6666 %% export_def(gcinvariant_oint_p(obj_o));
6667 %% #endif
6668
6669
6670 /* What's really being sent from an address to the address-bus */
6671 #define hardware_addressbus_mask ~0UL /* Default: nothing is dropped */
6672 /* Clever memory-mapping spares us from masking out of certain
6673 bits before one accesses the address */
6674 #define addressbus_mask hardware_addressbus_mask
6675 #ifdef SINGLEMAP_MEMORY
6676 #if defined(DECALPHA) && defined(UNIX_OSF)
6677 /* Memory-mapping makes the bits 39..33 of an address redundant now. */
6678 #undef addressbus_mask
6679 #define addressbus_mask 0xFFFFFF01FFFFFFFFUL
6680 #elif !defined(WIDE_SOFT)
6681 /* Memory-mapping makes the bits 31..24 of an address redundant now. */
6682 #undef addressbus_mask
6683 #define addressbus_mask oint_addr_mask /* most of the time it's = 0x00FFFFFFUL */
6684 #endif
6685 #endif
6686 %% #if notused
6687 %% export_def(addressbus_mask);
6688 %% #endif
6689
6690
6691 #if defined(SINGLEMAP_MEMORY) && 1
6692 /* The STACK resides in a singlemap-area as well, Typinfo system_type. */
6693 #define SINGLEMAP_MEMORY_STACK
6694 #endif
6695
6696 #if defined(TRIVIALMAP_MEMORY) && 1
6697 /* The STACK region is allocated through mmap() or similar.
6698 This makes it possible to control the bits that are set in a STACK pointer
6699 and avoid collisions with frame_bit_o and (if TYPECODES) the type bits. */
6700 #define TRIVIALMAP_MEMORY_STACK
6701 #endif
6702
6703
6704 /* Verify the oint_addr_shift value w.r.t. the autoconfigured CODE_ADDRESS_RANGE
6705 and MALLOC_ADDRESS_RANGE values. */
6706 #if !defined(WIDE_SOFT)
6707 /* The CODE_ADDRESS_RANGE needs to be checked because we store code
6708 pointers in Lisp objects (cf. macro ThePseudofun).
6709 In case of TYPECODES, the typecode() of such pointers must be machine_type,
6710 otherwise gc_mark() gets confused and crashes. */
6711 #if (CODE_ADDRESS_RANGE >> addr_shift) & ~(oint_addr_mask >> oint_addr_shift)
6712 #error oint_addr_mask does not cover CODE_ADDRESS_RANGE !!
6713 #endif
6714 /* The MALLOC_ADDRESS_RANGE needs to be checked because
6715 1) if !defined(SINGLEMAP_MEMORY) && !defined(TRIVIALMAP_MEMORY),
6716 Lisp objects reside in memory allocated through mymalloc,
6717 2) if !defined(SINGLEMAP_MEMORY_STACK) && !defined(TRIVIALMAP_MEMORY_STACK),
6718 the STACK is allocated through mymalloc, and pointers into the STACK
6719 occur in frames (cf. macro framebottomword and function make_variable_frame)
6720 and in environments (cf. type environment_t). */
6721 #if !((defined(SINGLEMAP_MEMORY) && defined(SINGLEMAP_MEMORY_STACK)) \
6722 || (defined(TRIVIALMAP_MEMORY) && defined(TRIVIALMAP_MEMORY_STACK)))
6723 #if (MALLOC_ADDRESS_RANGE >> addr_shift) & ~(oint_addr_mask >> oint_addr_shift)
6724 #error oint_addr_mask does not cover MALLOC_ADDRESS_RANGE !!
6725 #endif
6726 #endif
6727 #endif
6728
6729
6730 #ifdef TYPECODES
6731
6732 /* You have to remove the typebits in order to access the components
6733 of an object.
6734 pointable(obj) does this, returning a void*.
6735 pointable_unchecked(obj) likewise, but without the DEBUG_GCSAFETY check.
6736 pointable_address_unchecked(obj_o) likewise, but takes an oint as argument
6737 and returns an aint. */
6738 #if !((oint_addr_shift==0) && (addr_shift==0))
6739 #define pointable_unchecked(obj) ((void*)upointer(obj))
6740 #define pointable_address_unchecked(obj_o) \
6741 (((aint)((obj_o) >> oint_addr_shift) & (aint)(oint_addr_mask >> oint_addr_shift)) << addr_shift)
6742 #else
6743 /* If oint_addr_shift=0 and addr_shift=0, you don't have to shift. */
6744 #define pointable_unchecked(obj) \
6745 ((void*)pointable_address_unchecked(as_oint(obj)))
6746 #if defined(SINGLEMAP_MEMORY)
6747 /* Through memory mapping, type bits must be sent to the address bus,
6748 together with the address. */
6749 #define pointable_address_unchecked(obj_o) (aint)(obj_o)
6750 #else
6751 #if !((tint_type_mask & (addressbus_mask>>oint_type_shift)) == 0)
6752 /* The general case. */
6753 #define pointable_address_unchecked(obj_o) \
6754 ((aint)(obj_o) & ((aint)oint_addr_mask | ~addressbus_mask))
6755 #else
6756 /* Moreover if oint_type_mask and addressbus_mask are disjoint
6757 (((tint_type_mask<<oint_type_shift) & addressbus_mask) == 0),
6758 no typebits are being sent to the address bus anyway.
6759 So there's nothing to be done: */
6760 #define pointable_address_unchecked(obj_o) (aint)(obj_o)
6761 #endif
6762 #endif
6763 #endif
6764 #ifdef DEBUG_GCSAFETY
6765 /* Check that obj has not been held in a GC-unsafe variable while a
6766 memory allocation was made. */
6767 static inline void* pointable (gcv_object_t obj) {
6768 return pointable_unchecked(obj);
6769 }
pointable(object obj)6770 static inline void* pointable (object obj) {
6771 return pointable_unchecked((gcv_object_t)obj); /* The cast does the check. */
6772 }
6773 #else
6774 #define pointable(obj) pointable_unchecked(obj)
6775 #endif
6776
6777 /* If you want to access an object with a known type-info whose
6778 set typebits are being swallowed by the address bus (the
6779 typebits, that are =0 don't matter), you can do without 'untype': */
6780 #if defined(DEBUG_GCSAFETY)
6781 #define type_pointable(type,obj) pointable(obj)
6782 #elif defined(WIDE_STRUCT)
6783 #define type_pointable(type,obj) ((void*)((obj).u.both.addr))
6784 #elif !((oint_addr_shift==0) && (addr_shift==0) && (((tint_type_mask<<oint_type_shift) & addressbus_mask) == 0))
6785 #if (addr_shift==0)
6786 #define type_pointable(type,obj) \
6787 ((oint_addr_shift==0) && ((type_zero_oint(type) & addressbus_mask) == 0) \
6788 ? (void*)(aint)as_oint(obj) \
6789 : (void*)(aint)pointable(obj) \
6790 )
6791 #elif !(addr_shift==0)
6792 /* Analogous, but here the macro 'optimized_upointer'
6793 assumes the role of the address bus: */
6794 #define type_pointable(type,obj) \
6795 ((optimized_upointer(type_data_object(type,0)) == 0) \
6796 ? (void*)(aint)optimized_upointer(obj) \
6797 : (void*)(aint)pointable(obj) \
6798 )
6799 #endif
6800 #else
6801 /* If pointable(obj) = obj, type_pointable() doesn't do anything as well: */
6802 #define type_pointable(type,obj) ((void*)(aint)as_oint(obj))
6803 #endif
6804
6805 /* If you want to access an object that has one of several known
6806 type infos, you can probably omit the 'untype'.
6807 The OR of the type infos is more authoritative. */
6808 #define types_pointable(ORed_types,obj) type_pointable(ORed_types,obj)
6809
6810 #else /* HEAPCODES */
6811
6812 #define pointable_address_unchecked(obj_o) \
6813 (((aint)((obj_o) >> oint_addr_shift) & (aint)(oint_addr_mask >> oint_addr_shift)) << addr_shift)
6814
6815 #endif
6816 %% #ifdef TYPECODES
6817 %% export_def(pointable_unchecked(obj));
6818 %% export_def(pointable_address_unchecked(obj_o));
6819 %% #ifdef DEBUG_GCSAFETY
6820 %% puts("static inline void* pointable (gcv_object_t obj) { return pointable_unchecked(obj); }");
6821 %% puts("static inline void* pointable (object obj) { return pointable_unchecked((gcv_object_t)obj); }");
6822 %% #else
6823 %% emit_define("pointable(obj)","pointable_unchecked(obj)");
6824 %% #endif
6825 %% #else /* HEAPCODES */
6826 %% export_def(pointable_address_unchecked(obj_o));
6827 %% #endif
6828
6829
6830 #ifdef oint_symbolflags_shift
6831 #if defined(SINGLEMAP_MEMORY) && (oint_symbolflags_shift==oint_type_shift)
6832 /* Since we can't multimap the symbol_tab, we can't use extrabits in
6833 a symbol's typecode. */
6834 #undef oint_symbolflags_shift
6835 #define NO_symbolflags
6836 #endif
6837 #endif
6838 #ifdef NO_symbolflags
6839 #define oint_symbolflags_shift -1 /* invalid value */
6840 #endif
6841
6842
6843 /* Whether we try to initialize subr_tab statically.
6844 (g++ 3.3 doesn't accept compound expressions as initializers:
6845 http://gcc.gnu.org/bugzilla/show_bug.cgi?id=12615
6846 g++ 3.4 similarly: http://gcc.gnu.org/bugzilla/show_bug.cgi?id=15180)
6847 With DEBUG_GCSAFETY, the initialization of subr_tab_data crashes in
6848 nonimmprobe. */
6849 #if !(defined(WIDE_SOFT) && !defined(WIDE_STRUCT)) && !(defined(__GNUG__) && (__GNUC__ == 3) && (__GNUC_MINOR__ == 3 || __GNUC_MINOR__ == 4) && defined(OBJECT_STRUCT)) && !(defined(DEBUG_GCSAFETY) && defined(SINGLEMAP_MEMORY))
6850 #define INIT_SUBR_TAB
6851 #endif
6852 /* NB: This has to be defined so external modules can work.
6853 When changed: do nothing */
6854
6855 /* Whether we try to initialize symbol_tab statically.
6856 (Make initialization easier, but there is not enough space for the
6857 compilation of SPVWTABS on some systems.
6858 EMX 0.9c (gcc-2.7.2.1) says "Virtual memory exhausted".
6859 g++ 3.3 doesn't accept compound expressions as initializers:
6860 http://gcc.gnu.org/bugzilla/show_bug.cgi?id=12615
6861 g++ 3.4 similarly: http://gcc.gnu.org/bugzilla/show_bug.cgi?id=15180)
6862 g++ 4.8 on 32-bit AIX/PowerPC produces code with invalid displacements.
6863 HP C on 64-bit HPPA in TYPECODES mode omits the type in references to NIL.
6864 With DEBUG_GCSAFETY, the initialization of symbol_tab_data crashes in
6865 nonimmprobe. */
6866 #if !(defined(WIDE_SOFT) && !defined(WIDE_STRUCT)) && !(defined(__GNUG__) && (__GNUC__ == 3) && (__GNUC_MINOR__ == 3 || __GNUC_MINOR__ == 4) && defined(OBJECT_STRUCT)) && !(defined(__GNUG__) && defined(UNIX_AIX) && defined(POWERPC)) && !(defined(UNIX_HPUX) && defined(HPPA64) && defined(TYPECODES) && !defined(GNU)) && !(defined(DEBUG_GCSAFETY) && defined(SINGLEMAP_MEMORY))
6867 #define INIT_SYMBOL_TAB
6868 #endif
6869 /* When changed: nothing to do */
6870
6871 /* Whether we try to initialize object_tab statically.
6872 (g++ 3.3 doesn't accept compound expressions as initializers:
6873 http://gcc.gnu.org/bugzilla/show_bug.cgi?id=12615
6874 g++ 3.4 similarly: http://gcc.gnu.org/bugzilla/show_bug.cgi?id=15180)
6875 With DEBUG_GCSAFETY, the initialization of object_tab crashes in
6876 nonimmprobe. */
6877 #if !(defined(WIDE_SOFT) && !defined(WIDE_STRUCT)) && !(defined(__GNUG__) && (__GNUC__ == 3) && (__GNUC_MINOR__ == 3 || __GNUC_MINOR__ == 4) && defined(OBJECT_STRUCT)) && !(defined(DEBUG_GCSAFETY) && defined(SINGLEMAP_MEMORY))
6878 #define INIT_OBJECT_TAB
6879 #endif
6880 /* When changed: do nothing */
6881
6882
6883 /* Set during the core of GC.
6884 When this is set, unexpected handle_fault() calls that can
6885 - if defined(MORRIS_GC) && defined(GENERATIONAL_GC) - copy
6886 Morris-chain backpointers from a cons cell to an old_new_pointer_t with set
6887 garcol_bit(!) into the heap, where they are guaranteed to lead to a crash
6888 later. So, uncontrolled memory accesses are forbidden while inside_gc. */
6889 extern bool inside_gc;
6890 %% exportV(bool,inside_gc);
6891
6892
6893 #ifdef DEBUG_GCSAFETY
6894
6895 /* Forward declarations. */
6896 static inline bool gcinvariant_symbol_p (object obj);
6897 #if defined(KERNELVOID32_HEAPCODES) || defined(GENERIC64_HEAPCODES)
6898 static inline bool nonimmsubrp (object obj);
6899 #else
6900 #define nonimmsubrp(obj) false
6901 #endif
6902
6903 /* Force a crash if a memory pointer points to nonexistent memory. */
6904 #define nonimmprobe(obj_o) \
6905 do { \
6906 /* Don't do probes inside GC. It leads to unexpected handle_fault() \
6907 calls that can - if defined(MORRIS_GC) && defined(GENERATIONAL_GC) - \
6908 copy Morris-chain backpointers from a cons cell to an old_new_pointer_t \
6909 with set garcol_bit(!) into the heap, where they are guaranteed to \
6910 lead to a crash later. */ \
6911 if (!inside_gc) \
6912 if (((obj_o) & wbit(garcol_bit_o)) == 0) /* exclude frame words from the STACK */ \
6913 if (!gcinvariant_oint_p(obj_o)) /* exclude immediate objects */ \
6914 /* Access a single char, without needing to subtract the bias. */ \
6915 *(volatile char *)pointable_address_unchecked(obj_o); \
6916 } while (0)
6917
6918 /* When a gcv_object_t is fetched from a GC visible location (in the heap or
6919 on the STACK) we can assume that GC has updated it. */
object()6920 inline gcv_object_t::operator object () const {
6921 nonimmprobe(one_o);
6922 return (object){ designated_init(one_o,one_o) INIT_ALLOCSTAMP };
6923 }
6924
6925 /* When an object is put into a GC visible location (in the heap or
6926 on the STACK) we check that it has not been held in a GC-unsafe variable
6927 while a memory allocation was made. */
gcv_object_t(object obj)6928 inline gcv_object_t::gcv_object_t (object obj) {
6929 if (!(gcinvariant_object_p(obj) || gcinvariant_symbol_p(obj)
6930 || obj.allocstamp == alloccount || nonimmsubrp(obj)))
6931 abort();
6932 one_o = as_oint(obj);
6933 nonimmprobe(one_o);
6934 }
6935 /* The only exception are fake gcv_objects. */
gcv_object_t(fake_gcv_object obj)6936 inline gcv_object_t::gcv_object_t (fake_gcv_object obj) {
6937 one_o = obj.fake_value;
6938 }
6939
6940 /* Uninitialized. */
gcv_object_t()6941 inline gcv_object_t::gcv_object_t () {
6942 }
6943
6944 /* Start of an area where no GC can be triggered. */
gcunsafe_object_t(object obj)6945 inline gcunsafe_object_t::gcunsafe_object_t (object obj)
6946 : gcv_object_t (obj), allocstamp (alloccount) {}
gcunsafe_object_t(gcv_object_t obj)6947 inline gcunsafe_object_t::gcunsafe_object_t (gcv_object_t obj)
6948 : gcv_object_t (obj), allocstamp (alloccount) {}
6949 /* End of an area where no GC can be triggered. */
~gcunsafe_object_t()6950 inline gcunsafe_object_t::~gcunsafe_object_t () {
6951 if (!(allocstamp == alloccount))
6952 abort();
6953 }
6954
6955 #endif
6956 %% #ifdef DEBUG_GCSAFETY
6957 %% puts("static inline bool gcinvariant_symbol_p (object obj);");
6958 %% #if defined(KERNELVOID32_HEAPCODES) || defined(GENERIC64_HEAPCODES)
6959 %% puts("static inline bool nonimmsubrp (object obj);");
6960 %% #else
6961 %% emit_define("nonimmsubrp(obj)","false");
6962 %% #endif
6963 %% export_def(nonimmprobe(obj_o));
6964 %% puts("inline gcv_object_t::operator object () const { nonimmprobe(one_o); return (object){ designated_init(one_o,one_o), designated_init(allocstamp,alloccount) }; }");
6965 %% puts("inline gcv_object_t::gcv_object_t (object obj) { if (!(gcinvariant_object_p(obj) || gcinvariant_symbol_p(obj) || obj.allocstamp == alloccount || nonimmsubrp(obj))) abort(); one_o = as_oint(obj); nonimmprobe(one_o); }");
6966 %% puts("inline gcv_object_t::gcv_object_t () {}");
6967 %% #endif
6968
6969
6970 /* Force a memory allocation for all functions which can trigger GC but
6971 sometimes do and sometimes don't. This makes DEBUG_GCSAFETY more efficient.
6972 GCTRIGGER() does a no-op memory allocation
6973 GCTRIGGER1(obj1) likewise, but saves obj1 temporarily
6974 GCTRIGGER2(obj1,obj2) likewise, but saves obj1, obj2 temporarily
6975 ...
6976 GCTRIGGER_IF(condition, statement)
6977 likewise, but only if the condition is fulfilled */
6978 #ifdef DEBUG_GCSAFETY
6979 /* When these macros are used in C macros, obj1, obj2 etc. can sometimes be
6980 expressions of type 'object' and sometimes of type 'gcv_object_t'. Need
6981 two implementations of inc_allocstamp. */
6982 inline void inc_allocstamp (object& obj) { obj.allocstamp++; }
inc_allocstamp(gcv_object_t & obj)6983 inline void inc_allocstamp (gcv_object_t& obj) { }
6984 #define GCTRIGGER() \
6985 (void)(alloccount++)
6986 #define GCTRIGGER1(obj1) \
6987 (void)(inc_allocstamp(obj1), alloccount++)
6988 #define GCTRIGGER2(obj1,obj2) \
6989 (void)(inc_allocstamp(obj1), inc_allocstamp(obj2), alloccount++)
6990 #define GCTRIGGER3(obj1,obj2,obj3) \
6991 (void)(inc_allocstamp(obj1), inc_allocstamp(obj2), inc_allocstamp(obj3), alloccount++)
6992 #define GCTRIGGER4(obj1,obj2,obj3,obj4) \
6993 (void)(inc_allocstamp(obj1), inc_allocstamp(obj2), inc_allocstamp(obj3), inc_allocstamp(obj4), alloccount++)
6994 #define GCTRIGGER5(obj1,obj2,obj3,obj4,obj5) \
6995 (void)(inc_allocstamp(obj1), inc_allocstamp(obj2), inc_allocstamp(obj3), inc_allocstamp(obj4), inc_allocstamp(obj5), alloccount++)
6996 #define GCTRIGGER6(obj1,obj2,obj3,obj4,obj5,obj6) \
6997 (void)(inc_allocstamp(obj1), inc_allocstamp(obj2), inc_allocstamp(obj3), inc_allocstamp(obj4), inc_allocstamp(obj5), inc_allocstamp(obj6), alloccount++)
6998 #define GCTRIGGER_IF(condition,statement) \
6999 if (condition) statement
7000 #else
7001 #define GCTRIGGER() (void)0
7002 #define GCTRIGGER1(obj1) (void)0
7003 #define GCTRIGGER2(obj1,obj2) (void)0
7004 #define GCTRIGGER3(obj1,obj2,obj3) (void)0
7005 #define GCTRIGGER4(obj1,obj2,obj3,obj4) (void)0
7006 #define GCTRIGGER5(obj1,obj2,obj3,obj4,obj5) (void)0
7007 #define GCTRIGGER6(obj1,obj2,obj3,obj4,obj5,obj6) (void)0
7008 #define GCTRIGGER_IF(condition,statement) (void)0
7009 #endif
7010
7011
7012 /* ################### Methods for memory management #####################
7013
7014 SPVW_BLOCKS : Memory management with few memory blocks
7015 SPVW_PAGES : Memory management with many memory blocks
7016 SPVW_MIXED : Objects of mixed types are possible on the same page or block
7017 SPVW_PURE : Every memory block/every memory page contains only objects
7018 of exactly one type */
7019 #if defined(SINGLEMAP_MEMORY) || defined(TRIVIALMAP_MEMORY)
7020 /* Multimapping of single pages isn't implemented yet.??
7021 Singlemapping of single pages isn't implemented yet.??
7022 If you use mmap() as malloc()-replacement, single pages aren't needed. */
7023 #define SPVW_BLOCKS
7024 #elif defined(VIRTUAL_MEMORY)
7025 /* On Unix-systems you can still fetch more memory afterwards,
7026 but you should concentrate the data - if possible - on few pages. */
7027 #define SPVW_PAGES
7028 #else
7029 #define SPVW_BLOCKS
7030 #endif
7031 #if defined(SINGLEMAP_MEMORY)
7032 /* SINGLEMAP_MEMORY -> Ony pure pages/blocks make sense, since
7033 the address of a page determines the type of the objects it contains. */
7034 #define SPVW_PURE
7035 #elif !defined(TYPECODES) || defined(SPVW_BLOCKS) || defined(TRIVIALMAP_MEMORY)
7036 /* !TYPECODES -> there aren't real typecodes, only Cons and Varobject.
7037 SPVW_BLOCKS -> SPVW_PURE_BLOCKS is only implemented for SINGLEMAP_MEMORY.
7038 TRIVIALMAP_MEMORY -> not many blocks available, small adress space. */
7039 #define SPVW_MIXED
7040 #else
7041 /* The decision among SPVW_PURE_PAGES and SPVW_MIXED_PAGES is quite
7042 arbitrary. */
7043 #if defined(PREFER_PURE_PAGES)
7044 #define SPVW_PURE
7045 #else
7046 #define SPVW_MIXED
7047 #endif
7048 #endif
7049 #if !(defined(SPVW_BLOCKS) || defined(SPVW_PAGES))
7050 #error readjust SPVW_BLOCKS/SPVW_PAGES!
7051 #endif
7052 #if !(defined(SPVW_MIXED) || defined(SPVW_PURE))
7053 #error readjust SPVW_MIXED/SPVW_PURE!
7054 #endif
7055 #if (defined(SPVW_BLOCKS) && defined(SPVW_PURE)) != defined(SINGLEMAP_MEMORY)
7056 #error SINGLEMAP_MEMORY <==> SPVW_PURE_BLOCKS!
7057 #endif
7058 #if (defined(SPVW_BLOCKS) && defined(SPVW_MIXED)) < defined(TRIVIALMAP_MEMORY)
7059 #error TRIVIALMAP_MEMORY ==> SPVW_MIXED_BLOCKS!
7060 #endif
7061 #if defined(SPVW_PURE) && !defined(TYPECODES)
7062 #error SPVW_PURE ==> TYPECODES!
7063 #endif
7064 #if (defined(SPVW_BLOCKS) && (defined(SPVW_PURE) || defined(SPVW_MIXED))) < defined(GENERATIONAL_GC)
7065 #error GENERATIONAL_GC ==> SPVW_PURE_BLOCKS or SPVW_MIXED_BLOCKS_STAGGERED or SPVW_MIXED_BLOCKS_OPPOSITE!
7066 #endif
7067
7068 /* The old GC algorithm does not support MULTITHREAD. */
7069 #if defined(OLD_GC) && defined(MULTITHREAD)
7070 #error OLD_GC does not support MULTITHREAD!
7071 #endif
7072
7073 /* Algorithm by Morris, that compacts Conses without mixing them up: */
7074 #if defined(SPVW_BLOCKS) && defined(VIRTUAL_MEMORY) && !defined(NO_MORRIS_GC) /* && !defined(MULTITHREAD) */
7075 /* Morris-GC is recommended, as it preserves the locality. */
7076 #define MORRIS_GC
7077 #endif
7078
7079
7080 /* ################# definitions by cases with respect to type codes ################# */
7081
7082 #ifdef TYPECODES
7083
7084 /* Has to start with switch (typecode(obj)), after that it's like a
7085 switch-statement with arbitrarily many case-labels.
7086 Example: switch (typecode(arg)) { case_string: ...; break; ... } */
7087 #define case_machine case machine_type /* machine-pointer */
7088 #define case_sstring case sstring_type /* Simple-String */
7089 #define case_ostring case string_type /* Other String */
7090 #define case_sbvector case sbvector_type /* Simple-Bit-Vector */
7091 #define case_obvector case bvector_type /* Other Bit-Vector */
7092 #define case_sb2vector case sb2vector_type /* Simple-2Bit-Vector */
7093 #define case_ob2vector case b2vector_type /* Other 2Bit-Vector */
7094 #define case_sb4vector case sb4vector_type /* Simple-4Bit-Vector */
7095 #define case_ob4vector case b4vector_type /* Other 4Bit-Vector */
7096 #define case_sb8vector case sb8vector_type /* Simple-8Bit-Vector */
7097 #define case_ob8vector case b8vector_type /* Other 8Bit-Vector */
7098 #define case_sb16vector case sb16vector_type /* Simple-16Bit-Vector */
7099 #define case_ob16vector case b16vector_type /* Other 16Bit-Vector */
7100 #define case_sb32vector case sb32vector_type /* Simple-32Bit-Vector */
7101 #define case_ob32vector case b32vector_type /* Other 32Bit-Vector */
7102 #define case_svector case svector_type /* Simple-(General-)Vector */
7103 #define case_ovector case vector_type /* Other (General-)Vector */
7104 #define case_mdarray case mdarray_type /* other Array */
7105 #define case_string case_sstring: case_ostring /* general string */
7106 #define case_bvector case_sbvector: case_obvector /* general bit vector */
7107 #define case_b2vector case_sb2vector: case_ob2vector /* general 2bit vector */
7108 #define case_b4vector case_sb4vector: case_ob4vector /* general 4bit vector */
7109 #define case_b8vector case_sb8vector: case_ob8vector /* general 8bit vector */
7110 #define case_b16vector case_sb16vector: case_ob16vector /* general 16bit vector */
7111 #define case_b32vector case_sb32vector: case_ob32vector /* general 32bit vector */
7112 #define case_vector case_svector: case_ovector /* general vector */
7113 #define case_array case_string: case_bvector: case_b2vector: case_b4vector: case_b8vector: case_b16vector: case_b32vector: case_vector: case_mdarray /* general Array */
7114 #define case_closure case closure_type /* Closure */
7115 #ifdef structure_type
7116 #define case_structure case structure_type /* Structure */
7117 #define _case_structure case_structure:
7118 #else
7119 #define structure_type orecord_type /* Structures are OtherRecords */
7120 #define _case_structure
7121 #endif
7122 #ifdef stream_type
7123 #define case_stream case stream_type /* Stream */
7124 #define _case_stream case_stream:
7125 #else
7126 #define stream_type orecord_type /* Streams are OtherRecords */
7127 #define _case_stream
7128 #endif
7129 #define case_orecord case orecord_type /* Other Record */
7130 #define case_instance case instance_type /* CLOS-Instance */
7131 #define case_lrecord case lrecord_type /* Long Record */
7132 #define case_char case char_type /* Character */
7133 #define case_subr case subr_type /* SUBR */
7134 #define case_system case system_type /* Frame-Pointer, Small-Read-Label, System */
7135 #define case_posfixnum case fixnum_type /* Fixnum >=0 */
7136 #define case_negfixnum case fixnum_type|bit(sign_bit_t) /* Fixnum <0 */
7137 #define case_fixnum case_posfixnum: case_negfixnum /* Fixnum */
7138 #define case_posbignum case bignum_type /* Bignum >0 */
7139 #define case_negbignum case bignum_type|bit(sign_bit_t) /* Bignum <0 */
7140 #define case_bignum case_posbignum: case_negbignum /* Bignum */
7141 #define case_integer case_fixnum: case_bignum /* Integer */
7142 #define case_ratio case ratio_type: case ratio_type|bit(sign_bit_t) /* Ratio */
7143 #ifdef SPVW_MIXED
7144 #define _case_ratio case_ratio:
7145 #else
7146 #define _case_ratio
7147 #endif
7148 #define case_rational case_integer: case_ratio /* Rational */
7149 #define case_sfloat case sfloat_type: case sfloat_type|bit(sign_bit_t) /* Short-Float */
7150 #define case_ffloat case ffloat_type: case ffloat_type|bit(sign_bit_t) /* Single-Float */
7151 #define case_dfloat case dfloat_type: case dfloat_type|bit(sign_bit_t) /* Double-Float */
7152 #define case_lfloat case lfloat_type: case lfloat_type|bit(sign_bit_t) /* Long-Float */
7153 #define case_float case_sfloat: case_ffloat: case_dfloat: case_lfloat /* Float */
7154 #define case_real case_rational: case_float /* Real */
7155 #define case_complex case complex_type /* Complex */
7156 #ifdef SPVW_MIXED
7157 #define _case_complex case_complex:
7158 #else
7159 #define _case_complex
7160 #endif
7161 #define case_number case_real: case_complex /* Number */
7162 #define case_symbol case symbol_type /* Symbol */
7163 #define case_sxrecord case_closure: _case_structure _case_stream _case_ratio _case_complex case_orecord: case_instance /* Srecord/Xrecord general */
7164 #define case_record case_sxrecord: case_lrecord /* Lrecord/Srecord/Xrecord general */
7165 #if /* !defined(NO_symbolflags) && */ (oint_symbolflags_shift==oint_type_shift)
7166 #define case_symbolflagged /* Symbol with Flags */\
7167 case symbol_type: \
7168 case symbol_type|bit(active_bit): \
7169 case symbol_type|bit(dynam_bit): \
7170 case symbol_type|bit(dynam_bit)|bit(active_bit): \
7171 case symbol_type|bit(svar_bit): \
7172 case symbol_type|bit(svar_bit)|bit(active_bit): \
7173 case symbol_type|bit(svar_bit)|bit(dynam_bit): \
7174 case symbol_type|bit(svar_bit)|bit(dynam_bit)|bit(active_bit)
7175 #else
7176 #define case_symbolflagged case_symbol /* Symbol with flags */
7177 #endif
7178 #define case_cons case cons_type /* Cons */
7179
7180 #else
7181
7182 #define _case_structure
7183 #define _case_stream
7184
7185 #endif
7186
7187
7188 /* ################## Structure of memory of LISP objects ###################
7189
7190 uintWC is the Integer type for the lengths of Bignum, Lfloat, Iarray.
7191 Subset relation: uintW <= uintWC <= uintC. */
7192 #ifdef TYPECODES
7193 #define intWCsize intCsize
7194 typedef uintC uintWC;
7195 typedef sintC sintWC;
7196 #else
7197 /* Type and sign are stored in the heap - only 16 bits for the length. */
7198 #define intWCsize intWsize
7199 typedef uintW uintWC;
7200 typedef sintW sintWC;
7201 #endif
7202 /* uintWCoverflow(x) checks, if there has been an overflow after the execution
7203 of an x++. */
7204 #define uintWCoverflow(x) ((intWCsize<intLsize) && ((uintWC)(x)==0))
7205
7206 /* ---------------------- Objects with two pointers ---------------------- #
7207 They contain just the two pointers, no header. The type must already be
7208 known when the object is accessed.
7209
7210 Normally, Cons, Ratio, Complex can all be considered as pairs. But if
7211 SPVW_MIXED, the heap statistics are a little unspecific if we mix the
7212 three types; therefore in that case we let Ratio and Complex be Varobjects. */
7213 #ifdef SPVW_MIXED
7214 #define case_pair case_cons
7215 #else
7216 #define case_pair case_cons: case_ratio: case_complex
7217 #endif
7218
7219 /* ---------------------- Objects of varying length ---------------------- #
7220 The first word is reserved for garbage collection. Outside of garbage
7221 collection, it contains a pointer to the object itself. Note that the
7222 GC, when it moves an object, takes care not to modify the typecode of
7223 this first word (except the GC bit, which it temporarily uses).
7224
7225 Type of the header flags: */
7226 #if (oint_type_len<=8) && (oint_type_shift/8 == (oint_type_shift+oint_type_len-1)/8) && !defined(DEBUG_GCSAFETY)
7227 /* Access to an individual byte is possible */
7228 #define hfintsize intBsize
7229 typedef uintB hfint;
7230 #else
7231 /* access to a full word */
7232 #define hfintsize pointer_bitsize
7233 typedef uintP hfint;
7234 #endif
7235 %% #if (oint_type_len<=8) && (oint_type_shift/8 == (oint_type_shift+oint_type_len-1)/8) && !defined(DEBUG_GCSAFETY)
7236 %% emit_typedef("uintB","hfint");
7237 %% #else
7238 %% emit_typedef("uintP","hfint");
7239 %% #endif
7240
7241 /* Objects with variable length */
7242 #ifdef TYPECODES
7243 #ifdef DEBUG_GCSAFETY
7244 #define VAROBJECT_HEADER \
7245 gcv_object_t _GCself; /* Self pointer for GC, contains flags */
7246 #else
7247 #define VAROBJECT_HEADER \
7248 union { \
7249 gcv_object_t _GCself; /* Self pointer for GC */\
7250 hfint flags[sizeof(gcv_object_t)/sizeof(hfint)]; /* Flags */\
7251 } header;
7252 #endif
7253 #else
7254 #define VAROBJECT_HEADER \
7255 gcv_object_t GCself; /* Self pointer for GC */\
7256 uintL tfl; /* type, flags, length */
7257 #endif
7258 typedef struct {
7259 VAROBJECT_HEADER
7260 } varobject_;
7261 typedef varobject_ * Varobject;
7262 #ifdef TYPECODES
7263 #ifdef DEBUG_GCSAFETY
7264 #define GCself _GCself
7265 #define header_flags _GCself.one_o
7266 #else
7267 #define GCself header._GCself
7268 /* The typecode can be found in the byte ((Varobject)p)->header_flags. */
7269 #if !(oint_type_len>=hfintsize ? oint_type_shift%hfintsize==0 : floor(oint_type_shift,hfintsize)==floor(oint_type_shift+oint_type_len-1,hfintsize))
7270 #error Bogus header_flags -- redefine header_flags!
7271 #endif
7272 #if BIG_ENDIAN_P
7273 #define header_flags header.flags[sizeof(gcv_object_t)/sizeof(hfint)-1-floor(oint_type_shift,hfintsize)]
7274 #else
7275 #define header_flags header.flags[floor(oint_type_shift,hfintsize)]
7276 #endif
7277 #endif
7278 /* it applies mtypecode(((Varobject)p)->GCself) =
7279 (((Varobject)p)->header_flags >> (oint_type_shift%hfintsize)) & tint_type_mask
7280 Bits for Symbols in the self pointer (see above):
7281 define var_bit0_t ... # set if the symbol is proclaimed SPECIAL or constant
7282 define var_bit1_t ... # set if the symbol is a symbol-macro or constant */
7283 #define var_bit0_hf (var_bit0_t+(oint_type_shift%hfintsize))
7284 #define var_bit1_hf (var_bit1_t+(oint_type_shift%hfintsize))
7285 #else
7286 /* Three possible layouts of type, flags, length:
7287 8 bits type, 24 bits length [Vrecord, Lrecord]
7288 8 bits type, 8 bits flags, 16 bits length [Srecord]
7289 8 bits type, 8 bits flags, 8 bits length, 8 bits xlength [Xrecord] */
7290 #define vrecord_tfl(type,length) \
7291 ((uintL)(uintB)(type)+((uintL)(length)<<8))
7292 #define lrecord_tfl(type,length) \
7293 ((uintL)(uintB)(type)+((uintL)(length)<<8))
7294 #define srecord_tfl(type,flags,length) \
7295 ((uintL)(uintB)(type)+((uintL)(uintB)(flags)<<8)+((uintL)(length)<<16))
7296 #define xrecord_tfl(type,flags,length,xlength) \
7297 ((uintL)(uintB)(type)+((uintL)(uintB)(flags)<<8)+((uintL)(uintB)(length)<<16)+((uintL)(uintB)(xlength)<<24))
7298 #define varobject_type(ptr) ((sintB)((ptr)->tfl & 0xFF))
7299 /* Bits for symbols in the flags: */
7300 #define header_flags tfl
7301 #define var_bit0_hf (var_bit0_f+8)
7302 #define var_bit1_hf (var_bit1_f+8)
7303 #endif
7304 %% export_def(VAROBJECT_HEADER);
7305 %% #ifndef TYPECODES
7306 %% export_def(GCself);
7307 %% export_def(varobject_type(ptr));
7308 %% #endif
7309
7310 /* Records
7311 These are varobjects with a one-byte type field in memory.
7312 There are three types of records:
7313 Vector-Records can have up to 16777215 elements, but have no flags and
7314 if TYPECODES also no type (because the type info is in the pointer).
7315 Long-Records can have up to 16777215 elements, but have no flags.
7316 Simple-Records can have up to 65535 elements,
7317 Extended-Records have room for up to 255 elements and 255 extra (non-Lisp)
7318 elements.
7319 Vector-Records are recognized by their type field:
7320 rectype == Rectype_Sbvector, Rectype_Sb[2|4|8|16|32]vector,
7321 Rectype_S[8|16|32]string, Rectype_Imm_S[8|16|32]string,
7322 Rectype_Svector.
7323 Long-Records are recognized by rectype >= rectype_longlimit, or if TYPECODES
7324 equivalently by their typecode lrecord_type.
7325 The others are partitioned into:
7326 - Simple-Records, if rectype < rectype_limit.
7327 - Extended-Records, if rectype >= rectype_limit. */
7328
7329 #ifdef TYPECODES
7330 #define RECORD_HEADER \
7331 VAROBJECT_HEADER /* self-pointer GC */ \
7332 sintB rectype; /* for OtherRecord and LongRecord: sub-type */ \
7333 uintB recflags; /* for OtherRecord: flags */ \
7334 uintW reclength; /* lengths and others */
7335 #else
7336 #define RECORD_HEADER \
7337 VAROBJECT_HEADER /* self-pointer for GC, tfl */
7338 #endif
7339 typedef struct {
7340 RECORD_HEADER
7341 gcv_object_t recdata[unspecified] _attribute_aligned_object_; /* elements */
7342 } record_;
7343 typedef record_ * Record;
7344 /* access to type, flags: */
7345 #ifdef TYPECODES
7346 #define record_type(ptr) ((ptr)->rectype)
7347 #else
7348 #define record_type(ptr) varobject_type(ptr)
7349 #endif
7350 #define Record_type(obj) record_type(TheRecord(obj))
7351 #ifdef TYPECODES
7352 #define record_flags(ptr) ((ptr)->recflags)
7353 #else
7354 #define record_flags(ptr) (((ptr)->tfl >> 8) & 0xFF)
7355 #endif
7356 #define Record_flags(obj) record_flags(TheRecord(obj))
7357 #ifdef TYPECODES
7358 #define record_flags_clr(ptr,bits) ((ptr)->recflags &= ~(bits))
7359 #define record_flags_set(ptr,bits) ((ptr)->recflags |= (bits))
7360 #define record_flags_replace(ptr,newflags) ((ptr)->recflags = (newflags))
7361 #else
7362 #define record_flags_clr(ptr,bits) ((ptr)->tfl &= ~((uintL)(bits) << 8))
7363 #define record_flags_set(ptr,bits) ((ptr)->tfl |= ((uintL)(bits) << 8))
7364 #define record_flags_replace(ptr,newflags) \
7365 ((ptr)->tfl ^= (((ptr)->tfl ^ (uintL)(newflags)<<8) & 0xFF00))
7366 #endif
7367 %% export_def(RECORD_HEADER);
7368 %% sprintf(buf,"struct { RECORD_HEADER gcv_object_t recdata[unspecified]%s; }",attribute_aligned_object);
7369 %% emit_typedef(buf,"record_");
7370 %% emit_typedef("record_ *","Record");
7371 %% export_def(record_type(ptr));
7372 %% export_def(Record_type(obj));
7373 %% export_def(record_flags(ptr));
7374 %% export_def(record_flags_set(ptr,bits));
7375 %% export_def(Record_flags(obj));
7376
7377 #ifdef TYPECODES
7378 #define VRECORD_HEADER \
7379 VAROBJECT_HEADER /* self-pointer for GC */\
7380 uintL length; /* length */
7381 #else
7382 #define VRECORD_HEADER \
7383 VAROBJECT_HEADER /* self-pointer for GC, tfl */
7384 #endif
7385 typedef struct {
7386 VRECORD_HEADER
7387 } vrecord_;
7388 typedef vrecord_ * Vrecord;
7389 #ifdef TYPECODES
7390 #define vrecord_length(ptr) ((ptr)->length)
7391 #else
7392 #define vrecord_length(ptr) ((ptr)->tfl >> 8)
7393 #endif
7394 %% export_def(VRECORD_HEADER);
7395 %% emit_typedef("struct { VRECORD_HEADER }","vrecord_");
7396 %% emit_typedef("vrecord_ *","Vrecord");
7397 %% export_def(vrecord_length(ptr));
7398
7399 #ifdef TYPECODES
7400 #define LRECORD_HEADER \
7401 VAROBJECT_HEADER /* self-pointer for GC */\
7402 uintL tfl; /* subtype (1 byte), then length (3 bytes) */
7403 #else
7404 #define LRECORD_HEADER \
7405 VAROBJECT_HEADER /* self-pointer for GC, tfl */
7406 #endif
7407 typedef struct {
7408 LRECORD_HEADER
7409 gcv_object_t recdata[unspecified] _attribute_aligned_object_; /* reclength elements */
7410 } lrecord_;
7411 typedef lrecord_ * Lrecord;
7412 #ifdef TYPECODES
7413 #if BIG_ENDIAN_P
7414 #define lrecord_tfl(type,length) \
7415 (((uintL)(uintB)(type)<<24)+(uintL)(length))
7416 #define lrecord_length(ptr) ((ptr)->tfl & 0xFFFFFF)
7417 #else
7418 #define lrecord_tfl(type,length) \
7419 ((uintL)(uintB)(type)+((uintL)(length)<<8))
7420 #define lrecord_length(ptr) ((ptr)->tfl >> 8)
7421 #endif
7422 #else
7423 #define lrecord_length(ptr) ((ptr)->tfl >> 8)
7424 #endif
7425 #define Lrecord_length(obj) lrecord_length(TheLrecord(obj))
7426
7427 #ifdef TYPECODES
7428 #define SRECORD_HEADER \
7429 VAROBJECT_HEADER /* self-pointer GC */\
7430 sintB rectype; /* subtype, < rectype_limit */\
7431 uintB recflags; /* flags */\
7432 uintW reclength; /* lengths in objects */
7433 #else
7434 #define SRECORD_HEADER \
7435 VAROBJECT_HEADER /* self-pointer for GC, tfl */
7436 #endif
7437 typedef struct {
7438 SRECORD_HEADER
7439 gcv_object_t recdata[unspecified] _attribute_aligned_object_; /* reclength elements */
7440 } srecord_;
7441 typedef srecord_ * Srecord;
7442 #ifdef TYPECODES
7443 #define srecord_length(ptr) ((ptr)->reclength)
7444 #else
7445 #define srecord_length(ptr) ((ptr)->tfl >> 16)
7446 #endif
7447 #define Srecord_length(obj) srecord_length(TheSrecord(obj))
7448 %% export_def(SRECORD_HEADER);
7449 %% sprintf(buf,"struct { SRECORD_HEADER gcv_object_t recdata[unspecified]%s; }",attribute_aligned_object);
7450 %% emit_typedef(buf,"srecord_");
7451 %% emit_typedef("srecord_ *","Srecord");
7452 %% export_def(srecord_length(ptr));
7453
7454 #ifdef TYPECODES
7455 #define XRECORD_HEADER \
7456 VAROBJECT_HEADER /* self-pointer for GC */\
7457 sintB rectype; /* subtype, >= rectype_limit */\
7458 uintB recflags; /* flags */\
7459 uintB reclength; /* lengths in objects */\
7460 uintB recxlength; /* lengths of the extra objects */
7461 #else
7462 #define XRECORD_HEADER \
7463 VAROBJECT_HEADER /* self-pointer for GC, tfl */
7464 #endif
7465 typedef struct {
7466 XRECORD_HEADER
7467 gcv_object_t recdata[unspecified] _attribute_aligned_object_; /* reclength elements */
7468 /* uintB recxdata[unspecified]; # recxlength extra elements */
7469 } xrecord_;
7470 typedef xrecord_ * Xrecord;
7471 #ifdef TYPECODES
7472 #define xrecord_length(ptr) ((ptr)->reclength)
7473 #define xrecord_xlength(ptr) ((ptr)->recxlength)
7474 #else
7475 #define xrecord_length(ptr) (((ptr)->tfl >> 16) & 0xFF)
7476 #define xrecord_xlength(ptr) ((ptr)->tfl >> 24)
7477 #endif
7478 #define Xrecord_length(obj) xrecord_length(TheXrecord(obj))
7479 #define Xrecord_xlength(obj) xrecord_xlength(TheXrecord(obj))
7480 %% export_def(XRECORD_HEADER);
7481 %% #if notused
7482 %% sprintf(buf,"struct { XRECORD_HEADER gcv_object_t recdata[unspecified]%s; }",attribute_aligned_object);
7483 %% emit_typedef(buf,"xrecord_");
7484 %% emit_typedef("xrecord_ *","Xrecord");
7485 %% #endif
7486
7487 /* *** Possible rectype values for records. *** */
7488 enum {
7489 enum_rectype_first = -4, /* Try to keep rectype_limit = 0. */
7490 Rectype_Closure,
7491 %% printf("#define Rectype_Closure %d\n",Rectype_Closure);
7492 Rectype_Structure, /* only used #ifndef case_structure */
7493 %% printf("#define Rectype_Structure %d\n",Rectype_Structure);
7494 Rectype_Instance,
7495 %% printf("#define Rectype_Instance %d\n",Rectype_Instance);
7496 rectype_limit, /* Here is the limit between Srecord and Xrecord. */
7497 Rectype_Hashtable = rectype_limit,
7498 %% printf("#define Rectype_Hashtable %d\n",Rectype_Hashtable);
7499 #ifndef TYPECODES
7500 %% #ifndef TYPECODES
7501 /* Rectype_vector is the bottom ARRAY & VECTOR */
7502 Rectype_vector, /* 1 -- Iarray, not Srecord/Xrecord */
7503 %% printf("#define Rectype_vector %d\n",Rectype_vector);
7504 Rectype_bvector, /* 2 -- Iarray, not Srecord/Xrecord */
7505 %% printf("#define Rectype_bvector %d\n",Rectype_bvector);
7506 Rectype_b2vector, /* 3 -- Iarray, not Srecord/Xrecord */
7507 %% printf("#define Rectype_b2vector %d\n",Rectype_b2vector);
7508 Rectype_b4vector, /* 4 -- Iarray, not Srecord/Xrecord */
7509 %% printf("#define Rectype_b4vector %d\n",Rectype_b4vector);
7510 Rectype_b8vector, /* 5 -- Iarray, not Srecord/Xrecord */
7511 %% printf("#define Rectype_b8vector %d\n",Rectype_b8vector);
7512 Rectype_b16vector, /* 6 -- Iarray, not Srecord/Xrecord */
7513 %% printf("#define Rectype_b16vector %d\n",Rectype_b16vector);
7514 Rectype_b32vector, /* 7 -- Iarray, not Srecord/Xrecord */
7515 %% printf("#define Rectype_b32vector %d\n",Rectype_b32vector);
7516 Rectype_unused1, /* 8 */
7517 /* Rectype_Svector is the bottom SIMPLE VECTOR */
7518 Rectype_Svector, /* 9 -- Svector, not Srecord/Xrecord */
7519 %% printf("#define Rectype_Svector %d\n",Rectype_Svector);
7520 Rectype_Sbvector, /* 10 -- Sbvector, not Srecord/Xrecord */
7521 %% printf("#define Rectype_Sbvector %d\n",Rectype_Sbvector);
7522 Rectype_Sb2vector, /* 11 -- Sbvector, not Srecord/Xrecord */
7523 %% printf("#define Rectype_Sb2vector %d\n",Rectype_Sb2vector);
7524 Rectype_Sb4vector, /* 12 -- Sbvector, not Srecord/Xrecord */
7525 %% printf("#define Rectype_Sb4vector %d\n",Rectype_Sb4vector);
7526 Rectype_Sb8vector, /* 13 -- Sbvector, not Srecord/Xrecord */
7527 %% printf("#define Rectype_Sb8vector %d\n",Rectype_Sb8vector);
7528 Rectype_Sb16vector, /* 14 -- Sbvector, not Srecord/Xrecord */
7529 %% printf("#define Rectype_Sb16vector %d\n",Rectype_Sb16vector);
7530 Rectype_Sb32vector, /* 15 -- Sbvector, not Srecord/Xrecord */
7531 %% printf("#define Rectype_Sb32vector %d\n",Rectype_Sb32vector);
7532 Rectype_unused2, /* 16 */
7533 /* Rectype_S8string is the bottom STRING */
7534 Rectype_S8string, /* 17 -- S8string, not Srecord/Xrecord */
7535 %% printf("#define Rectype_S8string %d\n",Rectype_S8string);
7536 Rectype_Imm_S8string, /* 18 -- immutable S8string, not Srecord/Xrecord */
7537 %% printf("#define Rectype_Imm_S8string %d\n",Rectype_Imm_S8string);
7538 Rectype_S16string, /* 19 -- S16string, not Srecord/Xrecord */
7539 %% printf("#define Rectype_S16string %d\n",Rectype_S16string);
7540 Rectype_Imm_S16string, /* 20 -- immutable S16string, not Srecord/Xrecord */
7541 %% printf("#define Rectype_Imm_S16string %d\n",Rectype_Imm_S16string);
7542 Rectype_S32string, /* 21 -- S32string, not Srecord/Xrecord */
7543 %% printf("#define Rectype_S32string %d\n",Rectype_S32string);
7544 Rectype_Imm_S32string, /* 22 -- immutable S32string, not Srecord/Xrecord */
7545 %% printf("#define Rectype_Imm_S32string %d\n",Rectype_Imm_S32string);
7546 Rectype_reallocstring, /* 23 -- reallocated simple string, an Sistring, only used #ifdef HAVE_SMALL_SSTRING */
7547 %% printf("#define Rectype_reallocstring %d\n",Rectype_reallocstring);
7548 /* Rectype_reallocstring is the top SIMPLE-STRING & SIMPLE-VECTOR */
7549 Rectype_string, /* 24 -- Iarray, not Srecord/Xrecord */
7550 %% printf("#define Rectype_string %d\n",Rectype_string);
7551 /* Rectype_string is the top STRING */
7552 Rectype_mdarray, /* 25 -- Iarray, not Srecord/Xrecord */
7553 %% printf("#define Rectype_mdarray %d\n",Rectype_mdarray);
7554 /* Rectype_mdarray is the top ARRAY
7555 Rectype_Bignum is the bottom NUMBER */
7556 Rectype_Bignum, /* Bignum, not Srecord/Xrecord */
7557 %% printf("#define Rectype_Bignum %d\n",Rectype_Bignum);
7558 Rectype_Lfloat, /* Lfloat, not Srecord/Xrecord */
7559 %% printf("#define Rectype_Lfloat %d\n",Rectype_Lfloat);
7560 Rectype_Dfloat,
7561 %% printf("#define Rectype_Dfloat %d\n",Rectype_Dfloat);
7562 Rectype_Ffloat,
7563 %% printf("#define Rectype_Ffloat %d\n",Rectype_Ffloat);
7564 %% #endif
7565 #endif /* TYPECODES */
7566 #ifdef SPVW_MIXED
7567 %% #ifdef SPVW_MIXED
7568 Rectype_Ratio,
7569 %% printf("#define Rectype_Ratio %d\n",Rectype_Ratio);
7570 Rectype_Complex,
7571 %% printf("#define Rectype_Complex %d\n",Rectype_Complex);
7572 %% #endif
7573 #endif /* SPVW_MIXED */
7574 /* *** Here the numbers end. *** */
7575 #ifndef TYPECODES
7576 %% #ifndef TYPECODES
7577 Rectype_Symbol,
7578 %% printf("#define Rectype_Symbol %d\n",Rectype_Symbol);
7579 %% #endif
7580 #endif /* TYPECODES */
7581 Rectype_Package,
7582 %% printf("#define Rectype_Package %d\n",Rectype_Package);
7583 Rectype_Readtable,
7584 %% printf("#define Rectype_Readtable %d\n",Rectype_Readtable);
7585 Rectype_Pathname,
7586 %% printf("#define Rectype_Pathname %d\n",Rectype_Pathname);
7587 Rectype_Logpathname,
7588 %% printf("#define Rectype_Logpathname %d\n",Rectype_Logpathname);
7589 Rectype_Random_State,
7590 %% printf("#define Rectype_Random_State %d\n",Rectype_Random_State);
7591 Rectype_Stream,
7592 %% printf("#define Rectype_Stream %d\n",Rectype_Stream);
7593 Rectype_Byte,
7594 %% printf("#define Rectype_Byte %d\n",Rectype_Byte);
7595 Rectype_Subr,
7596 %% printf("#define Rectype_Subr %d\n",Rectype_Subr);
7597 Rectype_Fsubr,
7598 %% printf("#define Rectype_Fsubr %d\n",Rectype_Fsubr);
7599 Rectype_Loadtimeeval,
7600 %% printf("#define Rectype_Loadtimeeval %d\n",Rectype_Loadtimeeval);
7601 Rectype_Symbolmacro,
7602 %% printf("#define Rectype_Symbolmacro %d\n",Rectype_Symbolmacro);
7603 Rectype_GlobalSymbolmacro,
7604 %% printf("#define Rectype_GlobalSymbolmacro %d\n",Rectype_GlobalSymbolmacro);
7605 Rectype_Macro,
7606 %% printf("#define Rectype_Macro %d\n",Rectype_Macro);
7607 Rectype_FunctionMacro,
7608 %% printf("#define Rectype_FunctionMacro %d\n",Rectype_FunctionMacro);
7609 Rectype_BigReadLabel,
7610 %% printf("#define Rectype_BigReadLabel %d\n",Rectype_BigReadLabel);
7611 Rectype_Encoding,
7612 %% printf("#define Rectype_Encoding %d\n",Rectype_Encoding);
7613 Rectype_Fpointer, /* only used #ifdef FOREIGN */
7614 %% printf("#define Rectype_Fpointer %d\n",Rectype_Fpointer);
7615 #ifdef DYNAMIC_FFI
7616 %% #ifdef DYNAMIC_FFI
7617 Rectype_Faddress,
7618 %% printf("#define Rectype_Faddress %d\n",Rectype_Faddress);
7619 Rectype_Fvariable,
7620 %% printf("#define Rectype_Fvariable %d\n",Rectype_Fvariable);
7621 Rectype_Ffunction,
7622 %% printf("#define Rectype_Ffunction %d\n",Rectype_Ffunction);
7623 %% #endif
7624 #endif /* DYNAMIC_FFI */
7625 Rectype_Weakpointer,
7626 %% printf("#define Rectype_Weakpointer %d\n",Rectype_Weakpointer);
7627 Rectype_MutableWeakList,
7628 %% printf("#define Rectype_MutableWeakList %d\n",Rectype_MutableWeakList);
7629 Rectype_MutableWeakAlist,
7630 %% printf("#define Rectype_MutableWeakAlist %d\n",Rectype_MutableWeakAlist);
7631 Rectype_Weakmapping,
7632 %% printf("#define Rectype_Weakmapping %d\n",Rectype_Weakmapping);
7633 Rectype_Finalizer,
7634 %% printf("#define Rectype_Finalizer %d\n",Rectype_Finalizer);
7635 #ifdef SOCKET_STREAMS
7636 %% #ifdef SOCKET_STREAMS
7637 Rectype_Socket_Server,
7638 %% printf("#define Rectype_Socket_Server %d\n",Rectype_Socket_Server);
7639 %% #endif
7640 #endif /* SOCKET_STREAMS */
7641 #ifdef MULTITHREAD
7642 %% #ifdef MULTITHREAD
7643 Rectype_Thread,
7644 %% printf("#define Rectype_Thread %d\n",Rectype_Thread);
7645 Rectype_Mutex,
7646 %% printf("#define Rectype_Mutex %d\n",Rectype_Mutex);
7647 Rectype_Exemption,
7648 %% printf("#define Rectype_Exemption %d\n",Rectype_Exemption);
7649 %% #endif
7650 #endif
7651 #ifdef YET_ANOTHER_RECORD
7652 %% #ifdef YET_ANOTHER_RECORD
7653 Rectype_Yetanother,
7654 %% printf("#define Rectype_Yetanother %d\n",Rectype_Yetanother);
7655 %% #endif
7656 #endif /* YET_ANOTHER_RECORD */
7657 rectype_longlimit, /* the boundary between Srecord/Xrecord and Lrecord. */
7658 Rectype_WeakList,
7659 %% printf("#define Rectype_WeakList %d\n",Rectype_WeakList);
7660 Rectype_WeakAnd,
7661 %% printf("#define Rectype_WeakAnd %d\n",Rectype_WeakAnd);
7662 Rectype_WeakOr,
7663 %% printf("#define Rectype_WeakOr %d\n",Rectype_WeakOr);
7664 Rectype_WeakAndMapping,
7665 %% printf("#define Rectype_WeakAndMapping %d\n",Rectype_WeakAndMapping);
7666 Rectype_WeakOrMapping,
7667 %% printf("#define Rectype_WeakOrMapping %d\n",Rectype_WeakOrMapping);
7668 Rectype_WeakAlist_Key,
7669 %% printf("#define Rectype_WeakAlist_Key %d\n",Rectype_WeakAlist_Key);
7670 Rectype_WeakAlist_Value,
7671 %% printf("#define Rectype_WeakAlist_Value %d\n",Rectype_WeakAlist_Value);
7672 Rectype_WeakAlist_Either,
7673 %% printf("#define Rectype_WeakAlist_Either %d\n",Rectype_WeakAlist_Either);
7674 Rectype_WeakAlist_Both,
7675 %% printf("#define Rectype_WeakAlist_Both %d\n",Rectype_WeakAlist_Both);
7676 Rectype_WeakHashedAlist_Key,
7677 %% printf("#define Rectype_WeakHashedAlist_Key %d\n",Rectype_WeakHashedAlist_Key);
7678 Rectype_WeakHashedAlist_Value,
7679 %% printf("#define Rectype_WeakHashedAlist_Value %d\n",Rectype_WeakHashedAlist_Value);
7680 Rectype_WeakHashedAlist_Either,
7681 %% printf("#define Rectype_WeakHashedAlist_Either %d\n",Rectype_WeakHashedAlist_Either);
7682 Rectype_WeakHashedAlist_Both,
7683 %% printf("#define Rectype_WeakHashedAlist_Both %d\n",Rectype_WeakHashedAlist_Both);
7684 /* when adding a new built-in type, do not forget to ...
7685 add a def-atomic-type to type.lisp;
7686 and a case in describe.lisp:describe-object;
7687 add an enum_hg_<newtype> in predtype.d and update heap_statistics_mapper,
7688 TYPE-OF and CLASS-OF */
7689 rectype_for_broken_compilers_that_dont_like_trailing_commas
7690 };
7691
7692 /* -------------------------- the various types -------------------------- */
7693
7694 /* Cons */
7695 typedef struct {
7696 gcv_object_t cdr _attribute_aligned_object_; /* CDR */
7697 gcv_object_t car _attribute_aligned_object_; /* CAR */
7698 } cons_;
7699 typedef cons_ * Cons;
7700 %% sprintf(buf,"struct { gcv_object_t cdr%s; gcv_object_t car%s; }",attribute_aligned_object,attribute_aligned_object);
7701 %% emit_typedef(buf,"cons_");
7702 %% emit_typedef("cons_ *","Cons");
7703
7704 /* Ratio */
7705 typedef struct {
7706 #ifdef SPVW_MIXED
7707 XRECORD_HEADER
7708 #endif
7709 gcv_object_t rt_num _attribute_aligned_object_; /* numerator, Integer */
7710 gcv_object_t rt_den _attribute_aligned_object_; /* denominator, Integer >0 */
7711 } ratio_;
7712 typedef ratio_ * Ratio;
7713 %% #if notused
7714 %% #ifdef SPVW_MIXED
7715 %% sprintf(buf,"struct { XRECORD_HEADER gcv_object_t rt_num%s; gcv_object_t rt_den%s; }",attribute_aligned_object,attribute_aligned_object);
7716 %% #else
7717 %% sprintf(buf,"struct { gcv_object_t rt_num%s; gcv_object_t rt_den%s; }",attribute_aligned_object,attribute_aligned_object);
7718 %% #endif
7719 %% emit_typedef(buf,"ratio_");
7720 %% emit_typedef("ratio_ *","Ratio");
7721 %% #endif
7722
7723 /* Complex */
7724 typedef struct {
7725 #ifdef SPVW_MIXED
7726 XRECORD_HEADER
7727 #endif
7728 gcv_object_t c_real _attribute_aligned_object_; /* real part, real number */
7729 gcv_object_t c_imag _attribute_aligned_object_; /* imaginary part, real number */
7730 } complex_;
7731 typedef complex_ * Complex;
7732 %% #if notused
7733 %% #ifdef SPVW_MIXED
7734 %% sprintf(buf,"struct { XRECORD_HEADER gcv_object_t c_real%s; gcv_object_t c_imag%s; }",attribute_aligned_object,attribute_aligned_object);
7735 %% #else
7736 %% sprintf(buf,"struct { gcv_object_t c_real%s; gcv_object_t c_imag%s; }",attribute_aligned_object,attribute_aligned_object);
7737 %% #endif
7738 %% emit_typedef(buf,"complex_");
7739 %% emit_typedef("complex_ *","Complex");
7740 %% #endif
7741
7742 /* Symbol */
7743 typedef struct {
7744 VAROBJECT_HEADER
7745 gcv_object_t symvalue _attribute_aligned_object_; /* value cell */
7746 gcv_object_t symfunction _attribute_aligned_object_; /* function definition cell */
7747 gcv_object_t hashcode _attribute_aligned_object_; /* hash code */
7748 gcv_object_t proplist _attribute_aligned_object_; /* property list */
7749 gcv_object_t pname _attribute_aligned_object_; /* Printname */
7750 gcv_object_t homepackage _attribute_aligned_object_; /* Home-Package or NIL */
7751 #define symbol_length 6
7752 /* If necessary, add a filler here to ensure sizeof_symbol_is_multiple_of_varobject_alignment. */
7753 #if defined(sizeof_symbol_is_multiple_of_varobject_alignment)
7754 #if ((((defined(TYPECODES) ? 1 : 2) + symbol_length) * pointer_bitsize/8) % varobject_alignment) != 0
7755 gcv_object_t symfiller _attribute_aligned_object_; /* never accessed, not subject to GC */
7756 #define symbol_has_symfiller
7757 #endif
7758 #endif
7759 #if defined(MULTITHREAD)
7760 /* the first symvalue in thread is dummy - for faster Symbol_value*/
7761 #define SYMBOL_TLS_INDEX_NONE ((aint)0)
7762 #define SYMVALUE_EMPTY make_system(0xEEEEEFUL)
7763 aint tls_index _attribute_aligned_object_; /* TLS index */
7764 #endif
7765 } symbol_;
7766 typedef symbol_ * Symbol;
7767 #if defined(sizeof_symbol_is_multiple_of_varobject_alignment)
7768 /* Compile-time check: sizeof(symbol_) is a multiple of varobject_alignment. */
7769 typedef int symbol_size_check[1 - 2 * (int)(sizeof(symbol_) % varobject_alignment)];
7770 #endif
7771 #define symbol_objects_offset offsetof(symbol_,symvalue)
7772 #define symbol_xlength (sizeof(*(Symbol)0)-symbol_objects_offset-symbol_length*sizeof(gcv_object_t))
7773 %% sprintf(buf,"struct { VAROBJECT_HEADER gcv_object_t symvalue%s; gcv_object_t symfunction%s; gcv_object_t hashcode%s; gcv_object_t proplist%s; gcv_object_t pname%s; gcv_object_t homepackage%s; ",attribute_aligned_object,attribute_aligned_object,attribute_aligned_object,attribute_aligned_object,attribute_aligned_object,attribute_aligned_object);
7774 %% #if defined(symbol_has_symfiller)
7775 %% sprintf(buf+strlen(buf),"gcv_object_t symfiller%s; ",attribute_aligned_object);
7776 %% #endif
7777 %% #if defined(MULTITHREAD)
7778 %% sprintf(buf+strlen(buf)," aint tls_index%s;",attribute_aligned_object);
7779 %% #endif
7780 %% sprintf(buf+strlen(buf),"}");
7781 %% emit_typedef(buf,"symbol_");
7782 %% emit_typedef("symbol_ *","Symbol");
7783
7784 /* Every keyword is a constant. */
7785
7786 /* Tests whether a symbol is a keyword: */
7787 #define keywordp(sym) \
7788 (eq(TheSymbol(sym)->homepackage,O(keyword_package)))
7789
7790 /* For constants, the special-bit is meaningless (since constants
7791 can't be bound lexically nor dynamically). */
7792
7793 /* Tests whether a symbol is a constant: */
7794 #define constant_var_p(sym) \
7795 (((bit(var_bit0_hf)|bit(var_bit1_hf)) & ~((sym)->header_flags)) == 0)
7796
7797 /* Tests whether a symbol is a SPECIAL-proclaimed variable or a constant: */
7798 #define special_var_p(sym) (((sym)->header_flags) & bit(var_bit0_hf))
7799
7800 /* Tests whether a symbol is a symbol-macro: */
7801 #define symmacro_var_p(sym) \
7802 ((((sym)->header_flags) & bit(var_bit1_hf)) \
7803 && ((((sym)->header_flags) & bit(var_bit0_hf)) == 0))
7804
7805 /* Set the constant-flag of a non-symbol-macro symbol: */
7806 #define set_const_flag(sym) \
7807 (((sym)->header_flags) |= bit(var_bit0_hf)|bit(var_bit1_hf))
7808
7809 /* Delete the constant-flag of a symbol that is a constant:
7810 (Symbol must not be a Keyword, comp. spvw.d:case_symbolwithflags) */
7811 #define clear_const_flag(sym) \
7812 (((sym)->header_flags) &= ~(bit(var_bit0_hf)|bit(var_bit1_hf)))
7813
7814 /* Set the special-flag of a non-symbol-macro symbol: */
7815 #define set_special_flag(sym) \
7816 (((sym)->header_flags) |= bit(var_bit0_hf))
7817
7818 /* Delete the special-flag of a symbol that is special and non-constant: */
7819 #define clear_special_flag(sym) \
7820 (((sym)->header_flags) &= ~bit(var_bit0_hf))
7821
7822 /* Set the symbol-macro-flag of a non-special/constant symbol: */
7823 #define set_symmacro_flag(sym) \
7824 (((sym)->header_flags) |= bit(var_bit1_hf))
7825
7826 /* Delete the symbol-macro-flag of a symbol that is a symbol-macro: */
7827 #define clear_symmacro_flag(sym) \
7828 (((sym)->header_flags) &= ~bit(var_bit1_hf))
7829
7830 /* Define symbol as constant with given value val.
7831 val must not trigger the GC! */
7832 #define define_constant(sym,val) \
7833 do { var Symbol sym_from_define_constant = TheSymbol(sym); \
7834 set_const_flag(sym_from_define_constant); \
7835 sym_from_define_constant->symvalue = (val); \
7836 } while(0)
7837
7838 /* Define symbol as variable and initialize it with a given value val.
7839 val must not trigger the GC! */
7840 #define define_variable(sym,val) \
7841 do { var Symbol sym_from_define_variable = TheSymbol(sym); \
7842 set_special_flag(sym_from_define_variable); \
7843 sym_from_define_variable->symvalue = (val); \
7844 } while(0)
7845
7846 /* Remove flag-bits of a symbol: */
7847 #if defined(NO_symbolflags)
7848 #define symbol_without_flags(symbol) symbol
7849 #elif (oint_symbolflags_shift==oint_type_shift)
7850 #define symbol_without_flags(symbol) \
7851 as_object(as_oint(symbol) & (type_zero_oint(symbol_type) | oint_addr_mask))
7852 #else
7853 #define symbol_without_flags(symbol) \
7854 as_object(as_oint(symbol) & ~((wbit(active_bit)|wbit(dynam_bit)|wbit(svar_bit))<<oint_symbolflags_shift))
7855 #endif
7856 /* add a flag to the object */
7857 #define SET_BIT(o,b) as_object(as_oint(o) | wbit(b))
7858 /* remove a flag from the object */
7859 #define CLR_BIT(o,b) as_object(as_oint(o) & ~wbit(b))
7860
7861 /* Characters */
7862
7863 /* Integer type holding the data of a character: */
7864 #ifdef ENABLE_UNICODE
7865 #define char_int_len 24 /* anything between 21 and 32 will do */
7866 #define char_int_limit 0x110000UL
7867 #else
7868 #define char_int_len 8
7869 #define char_int_limit 0x100UL
7870 #endif
7871 typedef unsigned_int_with_n_bits(char_int_len) cint;
7872 #define char_code_limit char_int_limit
7873 /* Converting an integral code to a character: */
7874 #define int_char(int_from_int_char) \
7875 type_data_object(char_type,(aint)(cint)(int_from_int_char))
7876 /* Converting a character to an integral code: */
7877 #if !((oint_data_shift==0) && (char_int_len<=oint_data_len) && (exact_uint_size_p(char_int_len)))
7878 #ifdef TYPECODES
7879 #define char_int(char_from_char_int) \
7880 ((cint)(untype(char_from_char_int)))
7881 #else
7882 #if (char_type>>oint_data_shift)==0 || (char_int_len<=16)
7883 #define char_int(char_from_char_int) \
7884 ((cint)(as_oint(char_from_char_int)>>oint_data_shift))
7885 #else
7886 #define char_int(char_from_char_int) \
7887 ((cint)((as_oint(char_from_char_int)>>oint_data_shift)&(bitm(oint_data_len)-1)))
7888 #endif
7889 #endif
7890 #else
7891 /* If oint_data_shift=0, untype does not need to shift. If also
7892 char_int_len<=oint_data_len, and if a cint has exactly char_int_len
7893 bits, untype does not need to AND. */
7894 #define char_int(char_from_char_int) \
7895 ((cint)as_oint(char_from_char_int))
7896 #endif
7897 /* Characters can therefore be compared for equality using EQ, this is an
7898 oint comparison, among the characters a comparison of their integral code. */
7899 %% sprintf(buf,"uint%d",char_int_len); emit_typedef(buf,"cint");
7900 %% export_def(int_char(int_from_int_char));
7901 %% export_def(char_int(char_from_char_int));
7902
7903 /* A standalone character. Prefer `chart' to `cint' wherever possible because
7904 it is typesafe. sizeof(chart) = sizeof(cint). */
7905 #ifdef CHART_STRUCT
7906 #ifdef __cplusplus
chartchart7907 struct chart { chart() {} chart(int c) : one_c(c) {} cint one_c; };
7908 #else
7909 typedef struct { cint one_c; } chart;
7910 #endif
7911 #else
7912 typedef cint chart;
7913 #endif
7914 /* Conversions between both:
7915 as_cint(ch) chart --> cint
7916 as_chart(c) cint --> chart */
7917 #ifdef CHART_STRUCT
7918 #define as_cint(ch) ((ch).one_c)
7919 #if 1
7920 #ifdef __cplusplus
as_chart(int c)7921 inline chart as_chart(int c) { return chart(c); }
7922 #else
7923 #define as_chart(c) ((chart){designated_init(one_c,(c))})
7924 #endif
7925 #else
as_chart(register cint c)7926 extern __inline__ chart as_chart (register cint c)
7927 { register chart ch; ch.one_c = c; return ch; }
7928 #endif
7929 #else
7930 #define as_cint(ch) (ch)
7931 #define as_chart(c) (c)
7932 #endif
7933 /* Conversion chart --> object. */
7934 #define code_char(ch) int_char(as_cint(ch))
7935 /* Conversion object --> chart. */
7936 #define char_code(obj) as_chart(char_int(obj))
7937 /* Comparison operations. */
7938 #define chareq(ch1,ch2) (as_cint(ch1) == as_cint(ch2))
7939 #define charlt(ch1,ch2) (as_cint(ch1) < as_cint(ch2))
7940 #define chargt(ch1,ch2) (as_cint(ch1) > as_cint(ch2))
7941 %% #ifdef CHART_STRUCT
7942 %% emit_typedef("struct { cint one_c; }","chart");
7943 %% #else
7944 %% emit_typedef("cint","chart");
7945 %% #endif
7946 %% export_def(as_cint(ch));
7947 %% export_def(as_chart(c));
7948 %% export_def(code_char(ch));
7949 %% export_def(char_code(obj));
7950
7951 /* Conversion standard char (in ASCII encoding) --> chart. */
7952 #define ascii(x) as_chart((uintB)(x))
7953 /* Conversion standard char (in ASCII encoding) --> object. */
7954 #define ascii_char(x) code_char(ascii(x))
7955
7956 /* Test for STANDARD-CHAR. */
7957 #define standard_cint_p(x) ((('~' >= (x)) && ((x) >= ' ')) || ((x) == NL))
7958
7959 /* Whether to use three different kinds of string representations. */
7960 #if defined(ENABLE_UNICODE) && (defined(GNU) || (defined(UNIX) && !defined(NO_ALLOCA) && !defined(SPARC)) || defined(MICROSOFT)) && !defined(NO_SMALL_SSTRING)
7961 #define HAVE_SMALL_SSTRING
7962 #endif
7963
7964 #ifdef HAVE_SMALL_SSTRING
7965 #define if_HAVE_SMALL_SSTRING(statement) statement
7966 /* We have three kinds of simple strings, with 8-bit codes (ISO-8859-1
7967 strings), with 16-bit codes (UCS-2 strings) and with 32-bit codes
7968 (UCS-4/UTF-32 strings). */
7969 typedef uint8 cint8;
7970 #define cint8_limit (1UL<<8)
7971 typedef uint16 cint16;
7972 #define cint16_limit (1UL<<16)
7973 typedef uint32 cint32;
7974 #define cint32_limit 0x110000UL
7975 #else
7976 #define if_HAVE_SMALL_SSTRING(statement) /*nop*/
7977 /* Only one kind of simple strings. */
7978 typedef cint cint8;
7979 #define cint8_limit char_int_limit
7980 typedef cint cint16;
7981 #define cint16_limit char_int_limit
7982 typedef cint cint32;
7983 #define cint32_limit char_int_limit
7984 #endif
7985 %% #ifdef HAVE_SMALL_SSTRING
7986 %% emit_typedef("uint8","cint8");
7987 %% emit_typedef("uint16","cint16");
7988 %% emit_typedef("uint32","cint32");
7989 %% #endif
7990
7991 /* Base characters. */
7992 #define base_char_int_len char_int_len
7993 #define base_char_code_limit char_code_limit
7994 /* The BASE-CHAR type is defined as
7995 (upgraded-array-element-type 'standard-char),
7996 i.e. the element-type of arrays created with (make-array 'standard-char ...).
7997 Since it defeats the purpose of ENABLE_UNICODE to have different 8-bit, 16-bit
7998 and 24-bit character types, we define BASE-CHAR=CHARACTER. */
7999
8000 /* Fixnums */
8001
8002 /* fixnum(x) is a fixnum with value x>=0.
8003 x is an expression with 0 <= x < 2^oint_data_len.
8004 (Should really be called posfixnum(x).) */
8005 #define fixnum(x) type_data_object(fixnum_type,x)
8006 %% export_def(fixnum(x));
8007
8008 /* Fixnum_0 is the number 0, Fixnum_1 is the number 1,
8009 Fixnum_minus1 is the number -1 */
8010 #define Fixnum_0 fixnum(0)
8011 #define Fixnum_1 fixnum(1)
8012 #define Fixnum_minus1 type_data_object( fixnum_type | bit(sign_bit_t), vbitm(oint_data_len)-1 )
8013 %% export_def(Fixnum_0);
8014 %% export_def(Fixnum_1);
8015 %% export_def(Fixnum_minus1);
8016
8017 /* Value of a non-negative fixnum:
8018 posfixnum_to_V(obj)
8019 result is >= 0, < 2^oint_data_len. */
8020 #if !defined(SPARC)
8021 #define posfixnum_to_V(obj) \
8022 ((uintV)((as_oint(obj)&((oint)wbitm(oint_data_len+oint_data_shift)-1))>>oint_data_shift))
8023 #else
8024 /* Long constants are slower than shifts on a SPARC-processor: */
8025 #if (oint_data_len+oint_data_shift<=intVsize)
8026 #define posfixnum_to_V(obj) \
8027 (((uintV)as_oint(obj) << (intVsize-oint_data_len-oint_data_shift)) >> (intVsize-oint_data_len))
8028 #else
8029 #define posfixnum_to_V(obj) \
8030 ((uintV)(as_oint(obj) >> (oint_data_len+oint_data_shift-intVsize)) >> (intVsize-oint_data_len))
8031 #endif
8032 #endif
8033 %% export_def(posfixnum_to_V(obj));
8034
8035 /* Value of a negative fixnum:
8036 negfixnum_to_V(obj)
8037 Result is >= - 2^oint_data_len, < 0. */
8038 #define negfixnum_to_V(obj) (posfixnum_to_V(obj) | (-vbitm(oint_data_len)))
8039 %% #if notused
8040 %% export_def(negfixnum_to_V(obj));
8041 %% #endif
8042
8043 /* Absolute value of a negative fixnum:
8044 negfixnum_abs_V(obj)
8045 Result is > 0, <= 2^oint_data_len.
8046 Beware: Possible wraparound at oint_data_len=intVsize! */
8047 #define negfixnum_abs_V(obj) \
8048 ((uintV)((as_oint(fixnum_inc(Fixnum_minus1,1))-as_oint(obj))>>oint_data_shift))
8049
8050 /* Value of a fixnum, obj should be a variable:
8051 fixnum_to_V(obj)
8052 Result is >= - 2^oint_data_len, < 2^oint_data_len and of Type sintV.
8053 This macro should only be used for oint_data_len+1 <= intLsize! */
8054 #if (oint_data_len>=intVsize)
8055 /* No space left for the sign-bit, thus fixnum_to_V = posfixnum_to_V = negfixnum_to_V ! */
8056 #define fixnum_to_V(obj) (sintV)posfixnum_to_V(obj)
8057 #elif (sign_bit_o == oint_data_len+oint_data_shift)
8058 #define fixnum_to_V(obj) \
8059 (((sintV)as_oint(obj) << (intVsize-1-sign_bit_o)) >> (intVsize-1-sign_bit_o+oint_data_shift))
8060 #else
8061 #if !defined(SPARC)
8062 #define fixnum_to_V(obj) \
8063 (sintV)( ((((sintV)as_oint(obj) >> sign_bit_o) << (intVsize-1)) >> (intVsize-1-oint_data_len)) \
8064 |((uintV)((as_oint(obj) & ((oint)wbitm(oint_data_len+oint_data_shift)-1)) >> oint_data_shift)) \
8065 )
8066 #else
8067 /* Long constants are slower than shifts on a SPARC-processor: */
8068 #if (oint_data_len+oint_data_shift<=intVsize)
8069 #define fixnum_to_V(obj) \
8070 (sintV)( ((((sintV)(as_oint(obj) >> sign_bit_o)) << (intVsize-1)) >> (intVsize-1-oint_data_len)) \
8071 |(((uintV)as_oint(obj) << (intVsize-oint_data_len-oint_data_shift)) >> (intVsize-oint_data_len)) \
8072 )
8073 #else
8074 #define fixnum_to_V(obj) \
8075 (sintV)( ((((sintV)(as_oint(obj) >> sign_bit_o)) << (intVsize-1)) >> (intVsize-1-oint_data_len)) \
8076 |((uintV)(as_oint(obj) >> (oint_data_len+oint_data_shift-intVsize)) >> (intVsize-oint_data_len)) \
8077 )
8078 #endif
8079 #endif
8080 #endif
8081 %% export_def(fixnum_to_V(obj));
8082
8083 #ifdef intQsize
8084 /* Value of a fixnum, obj should be a variable:
8085 fixnum_to_Q(obj)
8086 Result is >= - 2^oint_data_len, < 2^oint_data_len. */
8087 #if (sign_bit_o == oint_data_len+oint_data_shift)
8088 #define fixnum_to_Q(obj) \
8089 (((sintQ)as_oint(obj) << (intQsize-1-sign_bit_o)) >> (intQsize-1-sign_bit_o+oint_data_shift))
8090 #else
8091 #define fixnum_to_Q(obj) \
8092 (sintQ)( ((((sintQ)as_oint(obj) >> sign_bit_o) << (intQsize-1)) >> (intQsize-1-oint_data_len)) \
8093 |((uintQ)((as_oint(obj) & (wbitm(oint_data_len+oint_data_shift)-1)) >> oint_data_shift)) \
8094 )
8095 #endif
8096 #endif
8097
8098 /* Add a constant to a non-negative fixnum, given that
8099 the result is a non-negative fixnum as well:
8100 fixnum_inc(obj,delta)
8101 > obj: a fixnum
8102 > delta: a constant
8103 < result: incremented fixnum */
8104 #define fixnum_inc(obj,delta) \
8105 objectplus(obj, (soint)(delta) << oint_data_shift)
8106 %% export_def(fixnum_inc(obj,delta));
8107
8108 /* posfixnum(x) is a fixnum with value x>=0. */
8109 #define posfixnum(x) fixnum_inc(Fixnum_0,x)
8110 %% export_def(posfixnum(x));
8111
8112 /* negfixnum(x) is a fixnum with value x<0.
8113 (Beware if x is unsigned!) */
8114 #define negfixnum(x) fixnum_inc(fixnum_inc(Fixnum_minus1,1),x)
8115 %% export_def(negfixnum(x));
8116
8117 /* sfixnum(x) is a fixnum with value x,
8118 x is a constant-expression with -2^oint_data_len <= x < 2^oint_data_len. */
8119 #define sfixnum(x) ((x)>=0 ? posfixnum(x) : negfixnum(x))
8120 %% export_def(sfixnum(x));
8121
8122 /* Convert a character into a fixnum >=0 (the same as for char-int): */
8123 #ifdef WIDE_STRUCT
8124 #define char_to_fixnum(obj) \
8125 type_data_object(fixnum_type,untype(obj))
8126 #else
8127 #define char_to_fixnum(obj) \
8128 objectplus(obj,type_zero_oint(fixnum_type)-type_zero_oint(char_type))
8129 #endif
8130
8131 /* Make a character from a fitting fixnum >=0 (the same as for int-char): */
8132 #ifdef WIDE_STRUCT
8133 #define fixnum_to_char(obj) \
8134 type_data_object(char_type,untype(obj))
8135 #else
8136 #define fixnum_to_char(obj) \
8137 objectplus(obj,type_zero_oint(char_type)-type_zero_oint(fixnum_type))
8138 #endif
8139
8140 /* Bignums */
8141 typedef struct {
8142 VAROBJECT_HEADER /* self-pointer for GC */
8143 #ifdef TYPECODES
8144 uintC length; /* length in digits */
8145 #endif
8146 uintD data[unspecified]; /* number as its two's complement representation */
8147 } bignum_;
8148 typedef bignum_ * Bignum;
8149 /* The length is actually an uintWC. */
8150 #ifdef TYPECODES
8151 #define bignum_length(ptr) ((ptr)->length)
8152 #else
8153 #define bignum_length(ptr) srecord_length(ptr)
8154 #endif
8155 #define Bignum_length(obj) bignum_length(TheBignum(obj))
8156 %% #ifdef TYPECODES
8157 %% emit_typedef("struct { VAROBJECT_HEADER uintC length; uintD data[unspecified]; }","bignum_");
8158 %% #else
8159 %% emit_typedef("struct { VAROBJECT_HEADER uintD data[unspecified]; }","bignum_");
8160 %% #endif
8161 %% emit_typedef("bignum_ *","Bignum");
8162 %% export_def(bignum_length(ptr));
8163 %% export_def(Bignum_length(obj));
8164
8165 /* Single-Floats */
8166 typedef uint32 ffloat; /* 32-Bit-Float in IEEE-format */
8167 typedef union {
8168 ffloat eksplicit; /* Value, explicit */
8169 #ifdef FAST_FLOAT
8170 float machine_float; /* Value, as C-'float' */
8171 #endif
8172 } ffloatjanus;
8173 #if !defined(IMMEDIATE_FFLOAT)
8174 typedef struct {
8175 VAROBJECT_HEADER /* self-pointer for GC */
8176 ffloatjanus representation; /* Value */
8177 } ffloat_;
8178 typedef ffloat_ * Ffloat;
8179 #define ffloat_value(obj) (TheFfloat(obj)->float_value)
8180 #else
8181 /* The float-value is stored in the pointer itself, like short-floats. */
8182 #define ffloat_value(obj) ((ffloat)untype(obj))
8183 #endif
8184 %% emit_typedef("uint32","ffloat");
8185 %% emit_typedef("union { ffloat eksplicit; }","ffloatjanus");
8186
8187 /* Double-Floats */
8188 typedef /* 64-Bit-Float in IEEE-format: */
8189 #ifdef intQsize
8190 /* Sign/Exponent/Mantissa */
8191 uint64
8192 #else
8193 /* Sign/Exponent/MantissaHigh and MantissaLow */
8194 #if BIG_ENDIAN_P || (defined(ARM) && !defined(__ARM_EABI__))
8195 struct {uint32 semhi,mlo;}
8196 #else
8197 struct {uint32 mlo,semhi;}
8198 #endif
8199 #endif
8200 dfloat;
8201 typedef union {
8202 dfloat eksplicit _attribute_in_misaligned_varobjects_; /* Value, explicit */
8203 #ifdef FAST_DOUBLE
8204 double machine_double _attribute_in_misaligned_varobjects_; /* Value, as C-'double' */
8205 #endif
8206 } dfloatjanus;
8207 typedef struct {
8208 VAROBJECT_HEADER /* self-pointer for GC */
8209 dfloatjanus representation _attribute_in_misaligned_varobjects_; /* value */
8210 } dfloat_;
8211 typedef dfloat_ * Dfloat;
8212 %% #ifdef intQsize
8213 %% emit_typedef("uint64","dfloat");
8214 %% #else
8215 %% #if BIG_ENDIAN_P || (defined(ARM) && !defined(__ARM_EABI__))
8216 %% emit_typedef("struct {uint32 semhi,mlo;}","dfloat");
8217 %% #else
8218 %% emit_typedef("struct {uint32 mlo,semhi;}","dfloat");
8219 %% #endif
8220 %% #endif
8221 %% #ifdef FAST_DOUBLE
8222 %% sprintf(buf,"union { dfloat eksplicit%s; double machine_double%s; }",attribute_in_misaligned_varobjects,attribute_in_misaligned_varobjects);
8223 %% emit_typedef(buf,"dfloatjanus");
8224 %% #else
8225 %% sprintf(buf,"union { dfloat eksplicit%s; }",attribute_in_misaligned_varobjects);
8226 %% emit_typedef(buf,"dfloatjanus");
8227 %% #endif
8228
8229 /* Single- and Double-Floats */
8230 #define float_value representation.eksplicit
8231
8232 /* Long-Floats */
8233 typedef struct {
8234 VAROBJECT_HEADER /* Self-pointer for GC */
8235 #ifdef TYPECODES
8236 uintC len; /* length of the mantissa in digits */
8237 #endif
8238 uint32 expo; /* exponent */
8239 uintD data[unspecified]; /* mantissa */
8240 } lfloat_;
8241 typedef lfloat_ * Lfloat;
8242 /* The length is actually an uintWC. */
8243 #ifdef TYPECODES
8244 #define lfloat_length(ptr) ((ptr)->len)
8245 #else
8246 #define lfloat_length(ptr) srecord_length(ptr)
8247 #endif
8248 #define Lfloat_length(obj) lfloat_length(TheLfloat(obj))
8249
8250 /* simple array (cover simple linear arrays: simple bit vector, simple vector) */
8251 typedef struct {
8252 VRECORD_HEADER /* Self-pointer for GC, length in elements */
8253 } sarray_;
8254 typedef sarray_ * Sarray;
8255 #define sarray_length(ptr) vrecord_length(ptr)
8256 #define Sarray_length(obj) sarray_length(TheSarray(obj))
8257 %% #if notused
8258 %% emit_typedef("struct { VRECORD_HEADER }","sarray_");
8259 %% emit_typedef("sarray_ *","Sarray");
8260 %% #endif
8261 %% export_def(sarray_length(ptr));
8262 %% export_def(Sarray_length(obj));
8263
8264 /* simple bit vector */
8265 typedef struct {
8266 VRECORD_HEADER /* self-pointer for GC, length in bits */
8267 uint8 data[unspecified]; /* Bits, divided into bytes */
8268 } sbvector_;
8269 typedef sbvector_ * Sbvector;
8270 #define sbvector_length(ptr) sarray_length(ptr)
8271 #define Sbvector_length(obj) sbvector_length(TheSbvector(obj))
8272 %% emit_typedef("struct { VRECORD_HEADER uint8 data[unspecified]; }","sbvector_");
8273 %% emit_typedef("sbvector_ *","Sbvector");
8274 %% export_def(sbvector_length(ptr));
8275 %% export_def(Sbvector_length(obj));
8276
8277 /* simple string template */
8278 #ifdef TYPECODES
8279 #define SSTRING_HEADER \
8280 VAROBJECT_HEADER /* self-pointer for GC */\
8281 uintL tfl; /* type, flags, length */
8282 #else
8283 #define SSTRING_HEADER \
8284 VAROBJECT_HEADER /* self-pointer for GC, tfl */
8285 #endif
8286 typedef struct {
8287 SSTRING_HEADER
8288 } sstring_;
8289 typedef sstring_ * Sstring;
8290 #define STRUCT_SSTRING(cint_type) \
8291 struct { \
8292 SSTRING_HEADER /* self-pointer for GC, type+flags, length in characters */ \
8293 cint_type data[unspecified]; /* characters */ \
8294 }
8295 #ifdef HAVE_SMALL_SSTRING
8296 typedef STRUCT_SSTRING(cint8) s8string_;
8297 typedef s8string_ * S8string;
8298 typedef STRUCT_SSTRING(cint16) s16string_;
8299 typedef s16string_ * S16string;
8300 typedef STRUCT_SSTRING(cint32) s32string_;
8301 typedef s32string_ * S32string;
8302 #else
8303 /* Only one kind of simple strings. */
8304 #ifdef ENABLE_UNICODE
8305 typedef STRUCT_SSTRING(cint32) s32string_;
8306 typedef s32string_ * S32string;
8307 /* Aliases. */
8308 typedef s32string_ s16string_;
8309 typedef S32string S16string;
8310 typedef s32string_ s8string_;
8311 typedef S32string S8string;
8312 #else
8313 typedef STRUCT_SSTRING(cint8) s8string_;
8314 typedef s8string_ * S8string;
8315 /* Aliases. */
8316 typedef s8string_ s16string_;
8317 typedef S8string S16string;
8318 typedef s8string_ s32string_;
8319 typedef S8string S32string;
8320 #endif
8321 #endif
8322 /* A "normal simple string" is one of maximum-width element type.
8323 It cannot be reallocated. Only strings with smaller element type
8324 (called "small simple strings") can be reallocated. */
8325 typedef STRUCT_SSTRING(chart) snstring_;
8326 typedef snstring_ * Snstring;
8327 /* These accessors work on any simple string, except reallocated simple-strings. */
8328 #ifdef TYPECODES
8329 #define sstring_length(ptr) ((ptr)->tfl >> 6)
8330 #else
8331 #define sstring_length(ptr) ((ptr)->tfl >> 10)
8332 #endif
8333 #define Sstring_length(obj) sstring_length(TheSstring(obj))
8334 /* Maximum allowed simple-string length: */
8335 #ifdef TYPECODES
8336 #define stringsize_limit_1 ((uintL)(bit(intLsize-6)-1))
8337 #else
8338 #define stringsize_limit_1 ((uintL)(bit(intLsize-10)-1))
8339 #endif
8340 /* Constructing the tfl word: */
8341 #ifdef TYPECODES
8342 #define sstring_tfl(eltype,imm,flags,length) \
8343 (((length) << 6) + ((eltype) << 4) + ((imm) << 3) + (flags))
8344 #else
8345 /* This must be consistent with vrecord_tfl. */
8346 #define sstringrecord_tfl(rectype,flags,length) \
8347 (((length) << 10) + ((flags) << 8) + (rectype))
8348 #define sstring_tfl(eltype,imm,flags,length) \
8349 sstringrecord_tfl(Rectype_S8string + ((eltype) << 1) + (imm),flags,length)
8350 #endif
8351 /* Test whether a simple string is reallocated: */
8352 #ifdef HAVE_SMALL_SSTRING
8353 #ifdef TYPECODES
8354 #define sstringflags_forwarded_B bit(2)
8355 #define sstring_reallocatedp(ptr) ((ptr)->tfl & sstringflags_forwarded_B)
8356 #else
8357 #define sstring_reallocatedp(ptr) (record_type(ptr) == Rectype_reallocstring)
8358 #endif
8359 #else
8360 #define sstring_reallocatedp(ptr) 0
8361 #endif
8362 /* Extract the element type of a not-reallocated simple string: */
8363 #ifdef TYPECODES
8364 #define sstring_eltype(ptr) (((ptr)->tfl >> 4) & 3)
8365 #else
8366 #define sstring_eltype(ptr) ((record_type(ptr) - Rectype_S8string) >> 1)
8367 #endif
8368 /* Possible values of sstring_eltype: */
8369 #define Sstringtype_8Bit 0
8370 #define Sstringtype_16Bit 1
8371 #define Sstringtype_32Bit 2
8372 /* Extract the immutable bit of a simple string (reallocated or not): */
8373 #ifdef TYPECODES
8374 #define sstring_immutable(ptr) (((ptr)->tfl >> 3) & 1)
8375 #else
8376 #define sstring_immutable(ptr) ((record_type(ptr) - Rectype_S8string) & 1)
8377 #endif
8378 /* Extract the flags of a simple string (reallocated or not): */
8379 #ifdef TYPECODES
8380 /* Three bits, containing also sstringflags_forwarded_B. */
8381 #define sstring_flags(ptr) ((ptr)->tfl & 7)
8382 #define sstring_flags_clr(ptr,bits) ((ptr)->tfl &= ~(uintL)(bits))
8383 #define sstring_flags_set(ptr,bits) ((ptr)->tfl |= (uintL)(bits))
8384 #else
8385 #define sstring_flags(ptr) (((ptr)->tfl >> 8) & 3)
8386 #define sstring_flags_clr(ptr,bits) ((ptr)->tfl &= ~((uintL)(bits) << 8))
8387 #define sstring_flags_set(ptr,bits) ((ptr)->tfl |= ((uintL)(bits) << 8))
8388 #endif
8389 /* Bit masks in the flags. Only used during garbage collection. */
8390 #define sstringflags_backpointer_B bit(0)
8391 #define sstringflags_relocated_B bit(1)
8392 #define mark_sstring_clean(ptr) \
8393 sstring_flags_clr(ptr,sstringflags_backpointer_B|sstringflags_relocated_B)
8394 %% export_def(SSTRING_HEADER);
8395 %% emit_typedef("struct { SSTRING_HEADER }","sstring_");
8396 %% emit_typedef("sstring_ *","Sstring");
8397 %% #ifdef HAVE_SMALL_SSTRING
8398 %% export_def(STRUCT_SSTRING(cint_type));
8399 %% emit_typedef("STRUCT_SSTRING(cint8)","s8string_");
8400 %% emit_typedef("s8string_ *","S8string");
8401 %% emit_typedef("STRUCT_SSTRING(cint16)","s16string_");
8402 %% emit_typedef("s16string_ *","S16string");
8403 %% emit_typedef("STRUCT_SSTRING(cint32)","s32string_");
8404 %% emit_typedef("s32string_ *","S32string");
8405 %% #endif
8406 %% emit_typedef("struct { SSTRING_HEADER chart data[unspecified]; }","snstring_");
8407 %% emit_typedef("snstring_*","Snstring");
8408 %% export_def(sstring_length(ptr));
8409 %% export_def(Sstring_length(obj));
8410 %% export_def(sstring_eltype(ptr));
8411
8412 /* simple vector */
8413 typedef struct {
8414 VRECORD_HEADER /* self-pointer for GC, length in objects */
8415 gcv_object_t data[unspecified] _attribute_aligned_object_; /* elements */
8416 } svector_;
8417 typedef svector_ * Svector;
8418 #define svector_length(ptr) sarray_length(ptr)
8419 #define Svector_length(obj) svector_length(TheSvector(obj))
8420 %% sprintf(buf,"struct { VRECORD_HEADER gcv_object_t data[unspecified]%s; }",attribute_aligned_object);
8421 %% emit_typedef(buf,"svector_");
8422 %% emit_typedef("svector_ *","Svector");
8423
8424 /* simple indirect string */
8425 typedef struct {
8426 SSTRING_HEADER /* self-pointer for GC, tfl */
8427 gcv_object_t data _attribute_aligned_object_; /* data vector */
8428 } sistring_;
8429 typedef sistring_ * Sistring;
8430 #define sistring_data_offset offsetof(sistring_,data)
8431
8432 /* non-simple indirect Array */
8433 typedef struct {
8434 VAROBJECT_HEADER /* self-pointer for GC */
8435 #ifdef TYPECODES
8436 uintB flags; /* flags */
8437 uintC rank; /* rank n */
8438 #endif
8439 gcv_object_t data _attribute_aligned_object_; /* data vector */
8440 uintL totalsize; /* totalsize = product of the n dimensions */
8441 uintL dims[unspecified]; /* poss. displaced-offset, n dimensions, poss. fill-pointer */
8442 } iarray_;
8443 typedef iarray_ * Iarray;
8444 #define iarray_data_offset offsetof(iarray_,data)
8445 /* The rank is actually an uintWC.
8446 access Rang, Flags: */
8447 #ifdef TYPECODES
8448 #define iarray_rank(ptr) ((ptr)->rank)
8449 #else
8450 #define iarray_rank(ptr) srecord_length(ptr)
8451 #endif
8452 #define Iarray_rank(obj) iarray_rank(TheIarray(obj))
8453 #ifdef TYPECODES
8454 #define iarray_flags(ptr) ((ptr)->flags)
8455 #else
8456 #define iarray_flags(ptr) record_flags(ptr)
8457 #endif
8458 #define Iarray_flags(obj) iarray_flags(TheIarray(obj))
8459 #ifdef TYPECODES
8460 #define iarray_flags_clr(ptr,bits) ((ptr)->flags &= ~(bits))
8461 #define iarray_flags_set(ptr,bits) ((ptr)->flags |= (bits))
8462 #define iarray_flags_replace(ptr,newflags) ((ptr)->flags = (newflags))
8463 #else
8464 #define iarray_flags_clr(ptr,bits) record_flags_clr(ptr,bits)
8465 #define iarray_flags_set(ptr,bits) record_flags_set(ptr,bits)
8466 #define iarray_flags_replace(ptr,newflags) record_flags_replace(ptr,newflags)
8467 #endif
8468 /* Bits in the Flags: */
8469 #define arrayflags_adjustable_bit 7 /* set, if array is adjustable */
8470 #define arrayflags_fillp_bit 6 /* set, if a fill-pointer exists (only possible for n=1) */
8471 #define arrayflags_displaced_bit 5 /* set, if array is displaced */
8472 #define arrayflags_dispoffset_bit 4 /* set, if there is space for the
8473 displaced-offset
8474 (<==> array adjustable or displaced) */
8475 #define arrayflags_atype_mask 0x0F /* mask for the element-type */
8476 /* Element-types of arrays in Bits 3..0 of its flags:
8477 The first ones are chosen, so that 2^Atype_nBit = n. */
8478 #define Atype_Bit 0 /* storage vector is of type sbvector_type */
8479 #define Atype_2Bit 1 /* storage vector is of type sb2vector_type */
8480 #define Atype_4Bit 2 /* storage vector is of type sb4vector_type */
8481 #define Atype_8Bit 3 /* storage vector is of type sb8vector_type */
8482 #define Atype_16Bit 4 /* storage vector is of type sb16vector_type */
8483 #define Atype_32Bit 5 /* storage vector is of type sb32vector_type */
8484 #define Atype_T 6 /* storage vector is of type svector_type */
8485 #define Atype_Char 7 /* storage vector is of type sstring_type */
8486 #define Atype_NIL 8 /* storage vector is NIL */
8487 %% export_def(Atype_Bit);
8488 %% export_def(Atype_8Bit);
8489 %% export_def(Atype_32Bit);
8490 %% export_def(Atype_T);
8491
8492 /* array-types */
8493 #ifdef TYPECODES
8494 #define Array_type(obj) typecode(obj)
8495 #define Array_type_bvector bvector_type /* Iarray */
8496 #define Array_type_b2vector b2vector_type /* Iarray */
8497 #define Array_type_b4vector b4vector_type /* Iarray */
8498 #define Array_type_b8vector b8vector_type /* Iarray */
8499 #define Array_type_b16vector b16vector_type /* Iarray */
8500 #define Array_type_b32vector b32vector_type /* Iarray */
8501 #define Array_type_string string_type /* Iarray */
8502 #define Array_type_vector vector_type /* Iarray */
8503 #define Array_type_mdarray mdarray_type /* Iarray */
8504 #define Array_type_sbvector sbvector_type /* Sbvector */
8505 #define Array_type_sb2vector sb2vector_type /* Sbvector */
8506 #define Array_type_sb4vector sb4vector_type /* Sbvector */
8507 #define Array_type_sb8vector sb8vector_type /* Sbvector */
8508 #define Array_type_sb16vector sb16vector_type /* Sbvector */
8509 #define Array_type_sb32vector sb32vector_type /* Sbvector */
8510 #define Array_type_sstring sstring_type /* Sstring */
8511 #define Array_type_svector svector_type /* Svector */
8512 #define Array_type_snilvector symbol_type /* Symbol NIL */
8513 /* Array_type_simple_bit_vector(atype)
8514 maps Atype_[n]Bit to Array_type_sb[n]vector. Depends on TB0, TB1, TB2.
8515 The formula works because there are only 4 possible cases:
8516 (TB0,TB1,TB2) formula
8517 (0, 1, 2) atype
8518 (0, 1, 3) atype + (atype & -4)
8519 (0, 2, 3) atype + (atype & -2)
8520 (1, 2, 3) atype + (atype & -1) = atype << 1 */
8521 #define Array_type_simple_bit_vector(atype) \
8522 (Array_type_sbvector + ((atype)<<TB0) + ((atype)&(bit(TB0+1)-bit(TB1))) + ((atype)&(bit(TB1+1)-bit(TB2))))
8523 #else
8524 #define Array_type(obj) Record_type(obj)
8525 #define Array_type_bvector Rectype_bvector /* Iarray */
8526 #define Array_type_b2vector Rectype_b2vector /* Iarray */
8527 #define Array_type_b4vector Rectype_b4vector /* Iarray */
8528 #define Array_type_b8vector Rectype_b8vector /* Iarray */
8529 #define Array_type_b16vector Rectype_b16vector /* Iarray */
8530 #define Array_type_b32vector Rectype_b32vector /* Iarray */
8531 #define Array_type_string Rectype_string /* Iarray */
8532 #define Array_type_vector Rectype_vector /* Iarray */
8533 #define Array_type_mdarray Rectype_mdarray /* Iarray */
8534 #define Array_type_sbvector Rectype_Sbvector /* Sbvector */
8535 #define Array_type_sb2vector Rectype_Sb2vector /* Sbvector */
8536 #define Array_type_sb4vector Rectype_Sb4vector /* Sbvector */
8537 #define Array_type_sb8vector Rectype_Sb8vector /* Sbvector */
8538 #define Array_type_sb16vector Rectype_Sb16vector /* Sbvector */
8539 #define Array_type_sb32vector Rectype_Sb32vector /* Sbvector */
8540 #define Array_type_sstring Rectype_S8string: case Rectype_Imm_S8string: case Rectype_S16string: case Rectype_Imm_S16string: case Rectype_S32string: case Rectype_Imm_S32string: case Rectype_reallocstring /* S[8|16|32]string, reallocated string */
8541 #define Array_type_svector Rectype_Svector /* Svector */
8542 #define Array_type_snilvector Rectype_Symbol /* Symbol NIL */
8543 #endif
8544 /* Determining the atype of a [simple-]bit-array: */
8545 #define sbNvector_atype(obj) \
8546 type_bits_to_atype(Array_type(obj) - Array_type_sbvector)
8547 #define bNvector_atype(obj) \
8548 type_bits_to_atype(Array_type(obj) - Array_type_bvector)
8549 #ifdef TYPECODES
8550 /* There are only 4 cases:
8551 (TB0,TB1,TB2) formula
8552 (0, 1, 2) type
8553 (0, 1, 3) (type + (type & 3)) >> 1 = type - ((type & -8) >> 1)
8554 (0, 2, 3) (type + (type & 1)) >> 1 = type - ((type & -4) >> 1)
8555 (1, 2, 3) type >> 1 = type - ((type & -2) >> 1) */
8556 #if TB2 > 2
8557 #define type_bits_to_atype(type) \
8558 (((type) + ((type)&(bit(6-TB0-TB1-TB2)-1))) >> 1)
8559 #else
8560 #define type_bits_to_atype(type) (type)
8561 #endif
8562 #else
8563 #define type_bits_to_atype(type) (type)
8564 #endif
8565 %% #ifdef TYPECODES
8566 %% export_def(Array_type_simple_bit_vector(atype));
8567 %% #endif
8568
8569 /* Packages */
8570 typedef struct {
8571 XRECORD_HEADER
8572 gcv_object_t pack_external_symbols _attribute_aligned_object_;
8573 gcv_object_t pack_internal_symbols _attribute_aligned_object_;
8574 gcv_object_t pack_shadowing_symbols _attribute_aligned_object_;
8575 gcv_object_t pack_use_list _attribute_aligned_object_;
8576 gcv_object_t pack_used_by_list _attribute_aligned_object_;
8577 gcv_object_t pack_name _attribute_aligned_object_;
8578 gcv_object_t pack_nicknames _attribute_aligned_object_;
8579 gcv_object_t pack_docstring _attribute_aligned_object_;
8580 gcv_object_t pack_shortest_name _attribute_aligned_object_;
8581 #ifdef MULTITHREAD
8582 gcv_object_t pack_mutex _attribute_aligned_object_;
8583 #endif
8584 } * Package;
8585 #define package_length ((sizeof(*(Package)0)-offsetofa(record_,recdata))/sizeof(gcv_object_t))
8586 /* Some packages are case-sensitive. */
8587 #define mark_pack_casesensitive(obj) record_flags_set(ThePackage(obj),bit(0))
8588 #define mark_pack_caseinsensitive(obj) record_flags_clr(ThePackage(obj),bit(0))
8589 #define pack_casesensitivep(obj) (record_flags(ThePackage(obj)) & bit(0))
8590 /* Some packages are case-inverted. */
8591 #define mark_pack_caseinverted(obj) record_flags_set(ThePackage(obj),bit(1))
8592 #define mark_pack_casepreserved(obj) record_flags_clr(ThePackage(obj),bit(1))
8593 #define pack_caseinvertedp(obj) (record_flags(ThePackage(obj)) & bit(1))
8594 /* Some packages, such as COMMON-LISP, are locked. */
8595 #define mark_pack_locked(obj) record_flags_set(ThePackage(obj),bit(2))
8596 #define mark_pack_unlocked(obj) record_flags_clr(ThePackage(obj),bit(2))
8597 #define pack_locked_p(obj) (record_flags(ThePackage(obj)) & bit(2))
8598 /* Do not do anything with deleted packages. */
8599 #define mark_pack_deleted(obj) record_flags_set(ThePackage(obj),bit(7))
8600 #define pack_deletedp(obj) (record_flags(ThePackage(obj)) & bit(7))
8601 %% #if notused
8602 %% sprintf(buf,"struct { XRECORD_HEADER gcv_object_t pack_external_symbols%s; gcv_object_t pack_internal_symbols%s; gcv_object_t pack_shadowing_symbols%s; gcv_object_t pack_use_list%s; gcv_object_t pack_used_by_list%s; gcv_object_t pack_name%s; gcv_object_t pack_nicknames%s; gcv_object_t pack_docstring%s; gcv_object_t pack_shortest_name%s; %s %s %s %s } *",attribute_aligned_object,attribute_aligned_object,attribute_aligned_object,attribute_aligned_object,attribute_aligned_object,attribute_aligned_object,attribute_aligned_object,attribute_aligned_object,
8603 %% #ifdef MULTITHREAD
8604 %% "gcv_object_t", "pack_mutex", attribute_aligned_object, ";");
8605 %% #else
8606 %% "", "", "", "");
8607 %% #endif
8608 %% emit_typedef(buf,"Package");
8609 %% #endif
8610
8611 /* Hash-Tables */
8612 typedef struct {
8613 XRECORD_HEADER
8614 #ifdef GENERATIONAL_GC
8615 gcv_object_t ht_lastrehash _attribute_aligned_object_;
8616 #endif
8617 gcv_object_t ht_maxcount _attribute_aligned_object_;
8618 gcv_object_t ht_kvtable _attribute_aligned_object_;
8619 gcv_object_t ht_lookupfn _attribute_aligned_object_;
8620 gcv_object_t ht_hashcodefn _attribute_aligned_object_;
8621 gcv_object_t ht_testfn _attribute_aligned_object_;
8622 gcv_object_t ht_gcinvariantfn _attribute_aligned_object_;
8623 gcv_object_t ht_rehash_size _attribute_aligned_object_;
8624 gcv_object_t ht_mincount_threshold _attribute_aligned_object_;
8625 gcv_object_t ht_mincount _attribute_aligned_object_;
8626 gcv_object_t ht_test _attribute_aligned_object_; /* hash-table-test - for define-hash-table-test */
8627 gcv_object_t ht_hash _attribute_aligned_object_; /* hash function */
8628 uintL ht_size;
8629 } * Hashtable;
8630 #ifdef GENERATIONAL_GC
8631 #define hashtable_length 12
8632 #else
8633 #define hashtable_length 11
8634 #endif
8635 #define hashtable_xlength (sizeof(*(Hashtable)0)-offsetofa(record_,recdata)-hashtable_length*sizeof(gcv_object_t))
8636 /* Mark a Hash Table as now to reorganize
8637 set_ht_invalid(TheHashtable(ht));
8638 mark_ht_invalid(TheHashtable(ht));
8639 A bit that is set when the list structure is invalid and a rehash is needed. */
8640 #define htflags_invalid_B bit(7)
8641 /* A bit that is set if the table has a key whose hash code is not GC-invariant. */
8642 #define htflags_gc_rehash_B bit(6)
8643 #ifdef GENERATIONAL_GC
8644 #define mark_ht_invalid(ptr) \
8645 (record_flags_set(ptr,htflags_invalid_B), \
8646 (ptr)->ht_lastrehash = unbound)
8647 #define mark_ht_valid(ptr) \
8648 (record_flags_clr(ptr,htflags_invalid_B), \
8649 (ptr)->ht_lastrehash = O(gc_count))
8650 #define ht_validp(ptr) \
8651 ((record_flags(ptr) & htflags_invalid_B) == 0 \
8652 && ((record_flags(ptr) & htflags_gc_rehash_B) == 0 \
8653 || eq((ptr)->ht_lastrehash,O(gc_count))))
8654 #else
8655 #define mark_ht_invalid(ptr) record_flags_set(ptr,htflags_invalid_B)
8656 #define mark_ht_valid(ptr) record_flags_clr(ptr,htflags_invalid_B)
8657 #define ht_validp(ptr) ((record_flags(ptr) & htflags_invalid_B) == 0)
8658 #endif
8659 #ifdef GENERATIONAL_GC
8660 #define set_ht_invalid(ptr) mark_ht_invalid(ptr)
8661 #define set_ht_valid(ptr) mark_ht_valid(ptr)
8662 #else
8663 extern bool hash_lookup_builtin (object ht, object obj, bool allowgc, gcv_object_t** KVptr_, gcv_object_t** Iptr_);
8664 extern bool hash_lookup_builtin_with_rehash (object ht, object obj, bool allowgc, gcv_object_t** KVptr_, gcv_object_t** Iptr_);
8665 #define set_ht_invalid(ptr) \
8666 (mark_ht_invalid(ptr), \
8667 eq((ptr)->ht_lookupfn,P(hash_lookup_builtin)) \
8668 ? ((ptr)->ht_lookupfn = P(hash_lookup_builtin_with_rehash), 0) : 0)
8669 #define set_ht_valid(ptr) \
8670 (mark_ht_valid(ptr), \
8671 eq((ptr)->ht_lookupfn,P(hash_lookup_builtin_with_rehash)) \
8672 ? ((ptr)->ht_lookupfn = P(hash_lookup_builtin), 0) : 0)
8673 #endif
8674 #define set_ht_invalid_if_needed(ptr) \
8675 if (record_flags(ptr) & htflags_gc_rehash_B) \
8676 set_ht_invalid(ptr)/*;*/
8677 /* A bit that indicates whether to warn about this situation. */
8678 #define htflags_warn_gc_rehash_B bit(5)
8679 /* Extract the part of the flags that encodes the test. */
8680 #define ht_test_code(flags) \
8681 (flags & (bit(0) | bit(1) | bit(2) | bit(3)))
8682 /* Tests whether a test code indicates a user-defined test function. */
8683 #define ht_test_code_user_p(test_code) \
8684 (((test_code) & bit(2)) != 0)
8685 /* Test whether a hash table is weak. */
8686 #define ht_weak_p(ht) \
8687 !simple_vector_p(TheHashtable(ht)->ht_kvtable)
8688 /* The kvtable array is either a HashedAlist or a WeakHashedAlist.
8689 Both share the same layout, i.e.
8690 &((HashedAlist)0)->hal_data == &((WeakHashedAlist)0)->whal_data. */
8691 typedef struct {
8692 VRECORD_HEADER /* self-pointer for GC, length in objects */
8693 gcv_object_t hal_filler _attribute_aligned_object_; /* for consistency with WeakHashedAlist */
8694 gcv_object_t hal_itable _attribute_aligned_object_; /* index-vector */
8695 gcv_object_t hal_count _attribute_aligned_object_; /* remaining pairs */
8696 gcv_object_t hal_freelist _attribute_aligned_object_; /* start index of freelist */
8697 gcv_object_t hal_data[unspecified] _attribute_aligned_object_; /* (key, value, next) triples */
8698 } * HashedAlist;
8699 /* TheHashedAlist is used to access both HashedAlist and WeakHashedAlist. */
8700 #define TheHashedAlist(obj) ((HashedAlist)TheVarobject(obj))
8701
8702 /* Readtables */
8703 typedef struct {
8704 XRECORD_HEADER
8705 gcv_object_t readtable_syntax_table _attribute_aligned_object_;
8706 gcv_object_t readtable_macro_table _attribute_aligned_object_;
8707 gcv_object_t readtable_case _attribute_aligned_object_;
8708 } * Readtable;
8709 #define readtable_length ((sizeof(*(Readtable)0)-offsetofa(record_,recdata))/sizeof(gcv_object_t))
8710
8711 /* Pathnames */
8712 typedef struct {
8713 XRECORD_HEADER
8714 #if HAS_HOST
8715 gcv_object_t pathname_host _attribute_aligned_object_;
8716 #endif
8717 #if HAS_DEVICE
8718 gcv_object_t pathname_device _attribute_aligned_object_;
8719 #endif
8720 #if 1
8721 gcv_object_t pathname_directory _attribute_aligned_object_;
8722 gcv_object_t pathname_name _attribute_aligned_object_;
8723 gcv_object_t pathname_type _attribute_aligned_object_;
8724 gcv_object_t pathname_version _attribute_aligned_object_;
8725 #endif
8726 } * Pathname;
8727 #define pathname_length ((sizeof(*(Pathname)0)-offsetofa(record_,recdata))/sizeof(gcv_object_t))
8728
8729 /* Logical Pathnames */
8730 typedef struct {
8731 XRECORD_HEADER
8732 gcv_object_t pathname_host _attribute_aligned_object_;
8733 gcv_object_t pathname_directory _attribute_aligned_object_;
8734 gcv_object_t pathname_name _attribute_aligned_object_;
8735 gcv_object_t pathname_type _attribute_aligned_object_;
8736 gcv_object_t pathname_version _attribute_aligned_object_;
8737 } * Logpathname;
8738 #define logpathname_length ((sizeof(*(Logpathname)0)-offsetofa(record_,recdata))/sizeof(gcv_object_t))
8739
8740 /* Random-States */
8741 typedef struct {
8742 XRECORD_HEADER
8743 gcv_object_t random_state_seed _attribute_aligned_object_;
8744 } * Random_state;
8745 #define random_state_length ((sizeof(*(Random_state)0)-offsetofa(record_,recdata))/sizeof(gcv_object_t))
8746
8747 /* Bytes */
8748 typedef struct {
8749 XRECORD_HEADER
8750 gcv_object_t byte_size _attribute_aligned_object_;
8751 gcv_object_t byte_position _attribute_aligned_object_;
8752 } * Byte;
8753 #define byte_length ((sizeof(*(Byte)0)-offsetofa(record_,recdata))/sizeof(gcv_object_t))
8754
8755 /* Fsubrs */
8756 typedef struct {
8757 XRECORD_HEADER
8758 gcv_object_t name _attribute_aligned_object_;
8759 gcv_object_t argtype _attribute_aligned_object_;
8760 void* function; /* actually a fsubr_function_t* */
8761 } * Fsubr;
8762 #define fsubr_length 2
8763 #define fsubr_xlength (sizeof(*(Fsubr)0)-offsetofa(record_,recdata)-fsubr_length*sizeof(gcv_object_t))
8764
8765 /* Load-time-evals */
8766 typedef struct {
8767 XRECORD_HEADER
8768 gcv_object_t loadtimeeval_form _attribute_aligned_object_;
8769 } * Loadtimeeval;
8770 #define loadtimeeval_length ((sizeof(*(Loadtimeeval)0)-offsetofa(record_,recdata))/sizeof(gcv_object_t))
8771
8772 /* Symbol-macros */
8773 typedef struct {
8774 XRECORD_HEADER
8775 gcv_object_t symbolmacro_expansion _attribute_aligned_object_;
8776 } * Symbolmacro;
8777 #define symbolmacro_length ((sizeof(*(Symbolmacro)0)-offsetofa(record_,recdata))/sizeof(gcv_object_t))
8778
8779 /* Global-Symbol-macros */
8780 typedef struct {
8781 XRECORD_HEADER
8782 gcv_object_t globalsymbolmacro_definition _attribute_aligned_object_;
8783 } * GlobalSymbolmacro;
8784 #define globalsymbolmacro_length ((sizeof(*(GlobalSymbolmacro)0)-offsetofa(record_,recdata))/sizeof(gcv_object_t))
8785
8786 /* Macros */
8787 typedef struct {
8788 XRECORD_HEADER
8789 gcv_object_t macro_expander _attribute_aligned_object_;
8790 gcv_object_t macro_lambda_list _attribute_aligned_object_;
8791 } * Macro;
8792 #define macro_length ((sizeof(*(Macro)0)-offsetofa(record_,recdata))/sizeof(gcv_object_t))
8793
8794 /* FunctionMacros */
8795 typedef struct {
8796 XRECORD_HEADER
8797 gcv_object_t functionmacro_macro_expander _attribute_aligned_object_;
8798 gcv_object_t functionmacro_function _attribute_aligned_object_;
8799 } * FunctionMacro;
8800 #define functionmacro_length ((sizeof(*(FunctionMacro)0)-offsetofa(record_,recdata))/sizeof(gcv_object_t))
8801
8802 /* BigReadLabel */
8803 typedef struct {
8804 XRECORD_HEADER
8805 gcv_object_t brl_value _attribute_aligned_object_;
8806 } * BigReadLabel;
8807 #define bigreadlabel_length ((sizeof(*(BigReadLabel)0)-offsetofa(record_,recdata))/sizeof(gcv_object_t))
8808
8809 /* Encoding */
8810 typedef struct {
8811 XRECORD_HEADER
8812 gcv_object_t enc_eol _attribute_aligned_object_; /* line termination, a keyword (:UNIX, :MAC, :DOS) */
8813 gcv_object_t enc_towcs_error _attribute_aligned_object_; /* input error action, :ERROR or :IGNORE or a character */
8814 gcv_object_t enc_tombs_error _attribute_aligned_object_; /* output error action, :ERROR or :IGNORE or a character or an uint8 */
8815 #ifdef ENABLE_UNICODE
8816 gcv_object_t enc_charset _attribute_aligned_object_; /* character set, a symbol in the CHARSET package or a simple-string */
8817 /* Functions to convert bytes to characters. */
8818 gcv_object_t enc_mblen _attribute_aligned_object_; /* uintL (*) (object encoding, const uintB* src, const uintB* srcend); */
8819 gcv_object_t enc_mbstowcs _attribute_aligned_object_; /* void (*) (object encoding, object stream, const uintB* *srcp, const uintB* srcend, chart* *destp, chart* destend); */
8820 /* Functions to convert characters to bytes. */
8821 gcv_object_t enc_wcslen _attribute_aligned_object_; /* uintL (*) (object encoding, const chart* src, const chart* srcend); */
8822 gcv_object_t enc_wcstombs _attribute_aligned_object_; /* void (*) (object encoding, object stream, const chart* *srcp, const chart* srcend, uintB* *destp, uintB* destend); */
8823 /* Function to return the set of defined characters in the range [start,end],
8824 as a simple-string of intervals #(start1 end1 ... startm endm). */
8825 gcv_object_t enc_range _attribute_aligned_object_; /* object (*) (object encoding, uintL start, uintL end, uintL maxintervals); */
8826 /* An auxiliary pointer. */
8827 gcv_object_t enc_table _attribute_aligned_object_;
8828 /* Minimum number of bytes needed to represent a character
8829 caveat: correct only for some encodings, defaults to 1 */
8830 uintL min_bytes_per_char;
8831 /* Maximum number of bytes needed to represent a character
8832 caveat: correct only for some encodings, defaults to 8 */
8833 uintL max_bytes_per_char;
8834 #endif
8835 } * Encoding;
8836 #ifdef ENABLE_UNICODE
8837 #define encoding_length 10
8838 #else
8839 #define encoding_length 3
8840 #endif
8841 #define encoding_xlength (sizeof(*(Encoding)0)-offsetofa(record_,recdata)-encoding_length*sizeof(gcv_object_t))
8842 #ifdef ENABLE_UNICODE
8843 #define Encoding_mblen(encoding) ((uintL (*) (object, const uintB*, const uintB*)) ThePseudofun(TheEncoding(encoding)->enc_mblen))
8844 #define Encoding_mbstowcs(encoding) ((void (*) (object, object, const uintB**, const uintB*, chart**, chart*)) ThePseudofun(TheEncoding(encoding)->enc_mbstowcs))
8845 #define Encoding_wcslen(encoding) ((uintL (*) (object, const chart*, const chart*)) ThePseudofun(TheEncoding(encoding)->enc_wcslen))
8846 #define Encoding_wcstombs(encoding) ((void (*) (object, object, const chart**, const chart*, uintB**, uintB*)) ThePseudofun(TheEncoding(encoding)->enc_wcstombs))
8847 #define Encoding_range(encoding) ((object (*) (object, uintL, uintL, uintL)) ThePseudofun(TheEncoding(encoding)->enc_range))
8848 #endif
8849 #ifdef ENABLE_UNICODE
8850 #define cslen(encoding,src,srclen) \
8851 Encoding_wcslen(encoding)(encoding,src,(src)+(srclen))
8852 #define cstombs_help_(encoding,src,srclen,dest,destlen,asserter) \
8853 do { var const chart* _srcptr = (src); \
8854 var const chart* _srcendptr = _srcptr+(srclen); \
8855 var uintB* _destptr = (dest); \
8856 var uintB* _destendptr = _destptr+(destlen); \
8857 Encoding_wcstombs(encoding)(encoding,nullobj,&_srcptr,_srcendptr,&_destptr,_destendptr); \
8858 asserter((_srcptr == _srcendptr) && (_destptr == _destendptr)); \
8859 } while(0)
8860 #else
8861 #define cslen(encoding,src,srclen) (srclen)
8862 #define cstombs_help_(encoding,src,srclen,dest,destlen,asserter) \
8863 do { asserter((srclen) == (destlen)); \
8864 begin_system_call(); memcpy(dest,src,srclen); end_system_call(); \
8865 } while(0)
8866 #endif
8867 #define cstombs(encoding,src,srclen,dest,destlen) cstombs_help_(encoding,src,srclen,dest,destlen,ASSERT)
8868 %% sprintf(buf,"struct { XRECORD_HEADER gcv_object_t enc_eol%s; gcv_object_t enc_towcs_error%s; gcv_object_t enc_tombs_error%s;",attribute_aligned_object,attribute_aligned_object,attribute_aligned_object);
8869 %% #ifdef ENABLE_UNICODE
8870 %% sprintf(buf+strlen(buf)," gcv_object_t enc_charset%s; gcv_object_t enc_mblen%s; gcv_object_t enc_mbstowcs%s; gcv_object_t enc_wcslen%s; gcv_object_t enc_wcstombs%s; gcv_object_t enc_range%s; gcv_object_t enc_table%s; uintL min_bytes_per_char; uintL max_bytes_per_char;",attribute_aligned_object,attribute_aligned_object,attribute_aligned_object,attribute_aligned_object,attribute_aligned_object,attribute_aligned_object,attribute_aligned_object);
8871 %% #endif
8872 %% strcat(buf," } *");
8873 %% emit_typedef(buf,"Encoding");
8874 %% #ifdef ENABLE_UNICODE
8875 %% export_def(Encoding_mblen(encoding));
8876 %% export_def(Encoding_wcslen(encoding));
8877 %% export_def(Encoding_wcstombs(encoding));
8878 %% #endif
8879 %% export_def(cslen(encoding,src,srclen));
8880 %% export_def(cstombs_help_(encoding,src,srclen,dest,destlen,asserter));
8881 %% puts("#define cstombs(encoding,src,srclen,dest,destlen) cstombs_help_(encoding,src,srclen,dest,destlen,ASSERT)");
8882
8883 #ifdef FOREIGN
8884 /* foreign pointer wrap */
8885 typedef struct {
8886 XRECORD_HEADER
8887 void* fp_pointer;
8888 } * Fpointer;
8889 #define fpointer_length 0
8890 #define fpointer_xlength (sizeof(*(Fpointer)0)-offsetofa(record_,recdata)-fpointer_length*sizeof(gcv_object_t))
8891 #define mark_fp_invalid(ptr) record_flags_set(ptr,bit(7))
8892 #define mark_fp_valid(ptr) record_flags_clr(ptr,bit(7))
8893 #define fp_validp(ptr) ((record_flags(ptr) & bit(7)) == 0)
8894 #else
8895 #define mark_fp_invalid(ptr)
8896 #endif
8897 %% #ifdef FOREIGN
8898 %% emit_typedef("struct { XRECORD_HEADER void* fp_pointer;} *","Fpointer");
8899 %% export_def(fp_validp(ptr));
8900 %% export_def(mark_fp_invalid(ptr));
8901 %% export_def(mark_fp_valid(ptr));
8902 %% #endif
8903
8904 #ifdef DYNAMIC_FFI
8905
8906 /* foreign adresses */
8907 typedef struct {
8908 XRECORD_HEADER
8909 gcv_object_t fa_base _attribute_aligned_object_;
8910 sintP fa_offset;
8911 } * Faddress;
8912 #define faddress_length 1
8913 #define faddress_xlength (sizeof(*(Faddress)0)-offsetofa(record_,recdata)-faddress_length*sizeof(gcv_object_t))
8914
8915 /* foreign variables */
8916 typedef struct {
8917 XRECORD_HEADER
8918 gcv_object_t fv_name _attribute_aligned_object_;
8919 gcv_object_t fv_version _attribute_aligned_object_;
8920 gcv_object_t fv_address _attribute_aligned_object_;
8921 gcv_object_t fv_size _attribute_aligned_object_;
8922 gcv_object_t fv_type _attribute_aligned_object_;
8923 } * Fvariable;
8924 #define fvariable_length ((sizeof(*(Fvariable)0)-offsetofa(record_,recdata))/sizeof(gcv_object_t))
8925
8926 /* foreign functions */
8927 typedef struct {
8928 XRECORD_HEADER
8929 gcv_object_t ff_name _attribute_aligned_object_;
8930 gcv_object_t ff_version _attribute_aligned_object_;
8931 gcv_object_t ff_address _attribute_aligned_object_;
8932 gcv_object_t ff_resulttype _attribute_aligned_object_;
8933 gcv_object_t ff_argtypes _attribute_aligned_object_;
8934 gcv_object_t ff_flags _attribute_aligned_object_;
8935 gcv_object_t ff_properties _attribute_aligned_object_;
8936 } * Ffunction;
8937 #define ffunction_length ((sizeof(*(Ffunction)0)-offsetofa(record_,recdata))/sizeof(gcv_object_t))
8938
8939 #endif
8940
8941 /* weak pointer */
8942 typedef struct {
8943 XRECORD_HEADER
8944 gcv_object_t wp_cdr _attribute_aligned_object_; /* active weak-pointers form a chained list */
8945 gcv_object_t wp_value _attribute_aligned_object_; /* the referenced object */
8946 } * Weakpointer;
8947 /* Both wp_cdr and wp_value are invisible to gc_mark routines.
8948 When the weak-pointer becomes inactive, both fields are turned to unbound.
8949 When wp_value is GC-invariant, WP does not have to be on the
8950 O(all_weakpointers) list! WP is on the list <==> ( wp_cdr != unbound ) */
8951 #define weakpointer_length ((sizeof(*(Weakpointer)0)-offsetofa(record_,recdata))/sizeof(gcv_object_t))
8952 #define weakpointer_broken_p(wp) (!boundp(TheWeakpointer(wp)->wp_value))
8953
8954 /* weak list */
8955 typedef struct {
8956 LRECORD_HEADER
8957 gcv_object_t wp_cdr _attribute_aligned_object_; /* active weak-pointers form a chained list */
8958 gcv_object_t wl_count _attribute_aligned_object_; /* remaining objects */
8959 gcv_object_t wl_elements[unspecified] _attribute_aligned_object_; /* the referenced objects */
8960 } * WeakList;
8961
8962 /* mutable weak list */
8963 typedef struct {
8964 XRECORD_HEADER
8965 gcv_object_t mwl_list _attribute_aligned_object_;
8966 } * MutableWeakList;
8967 #define mutableweaklist_length ((sizeof(*(MutableWeakList)0)-offsetofa(record_,recdata))/sizeof(gcv_object_t))
8968
8969 /* weak "and" relation */
8970 typedef struct {
8971 LRECORD_HEADER
8972 gcv_object_t wp_cdr _attribute_aligned_object_; /* active weak-pointers form a chained list */
8973 gcv_object_t war_keys_list _attribute_aligned_object_; /* list to copy the keys into */
8974 gcv_object_t war_keys[unspecified] _attribute_aligned_object_; /* the referenced objects */
8975 } * WeakAnd;
8976
8977 /* weak "or" relation */
8978 typedef struct {
8979 LRECORD_HEADER
8980 gcv_object_t wp_cdr _attribute_aligned_object_; /* active weak-pointers form a chained list */
8981 gcv_object_t wor_keys_list _attribute_aligned_object_; /* list to copy the keys into */
8982 gcv_object_t wor_keys[unspecified] _attribute_aligned_object_; /* the referenced objects */
8983 } * WeakOr;
8984
8985 /* weak mapping */
8986 typedef struct {
8987 XRECORD_HEADER
8988 gcv_object_t wp_cdr _attribute_aligned_object_; /* active weak-pointers form a chained list */
8989 gcv_object_t wm_value _attribute_aligned_object_; /* the dependent referenced object */
8990 gcv_object_t wm_key _attribute_aligned_object_; /* the weak referenced object */
8991 } * Weakmapping;
8992 #define weakmapping_length ((sizeof(*(Weakmapping)0)-offsetofa(record_,recdata))/sizeof(gcv_object_t))
8993
8994 /* weak "and" mapping */
8995 typedef struct {
8996 LRECORD_HEADER
8997 gcv_object_t wp_cdr _attribute_aligned_object_; /* active weak-pointers form a chained list */
8998 gcv_object_t wam_value _attribute_aligned_object_; /* the dependent referenced object */
8999 gcv_object_t wam_keys_list _attribute_aligned_object_; /* list to copy the keys into */
9000 gcv_object_t wam_keys[unspecified] _attribute_aligned_object_; /* the referenced objects */
9001 } * WeakAndMapping;
9002
9003 /* weak "or" mapping */
9004 typedef struct {
9005 LRECORD_HEADER
9006 gcv_object_t wp_cdr _attribute_aligned_object_; /* active weak-pointers form a chained list */
9007 gcv_object_t wom_value _attribute_aligned_object_; /* the dependent referenced object */
9008 gcv_object_t wom_keys_list _attribute_aligned_object_; /* list to copy the keys into */
9009 gcv_object_t wom_keys[unspecified] _attribute_aligned_object_; /* the referenced objects */
9010 } * WeakOrMapping;
9011
9012 /* weak alist (rectype = Rectype_WeakAlist_{Key,Value,Either,Both}) */
9013 typedef struct {
9014 LRECORD_HEADER
9015 gcv_object_t wp_cdr _attribute_aligned_object_; /* active weak-pointers form a chained list */
9016 gcv_object_t wal_count _attribute_aligned_object_; /* remaining pairs */
9017 gcv_object_t wal_data[unspecified] _attribute_aligned_object_; /* key, value alternating */
9018 } * WeakAlist;
9019
9020 /* mutable weak alist */
9021 typedef struct {
9022 XRECORD_HEADER
9023 gcv_object_t mwal_list _attribute_aligned_object_;
9024 } * MutableWeakAlist;
9025 #define mutableweakalist_length ((sizeof(*(MutableWeakAlist)0)-offsetofa(record_,recdata))/sizeof(gcv_object_t))
9026
9027 /* weak hashed alist (rectype = Rectype_WeakHashedAlist_{Key,Value,Either,Both}) */
9028 typedef struct {
9029 LRECORD_HEADER
9030 gcv_object_t wp_cdr _attribute_aligned_object_; /* active weak-pointers form a chained list */
9031 gcv_object_t whal_itable _attribute_aligned_object_; /* index-vector */
9032 gcv_object_t whal_count _attribute_aligned_object_; /* remaining pairs */
9033 gcv_object_t whal_freelist _attribute_aligned_object_; /* start index of freelist */
9034 gcv_object_t whal_data[unspecified] _attribute_aligned_object_; /* (key, value, next) triples */
9035 } * WeakHashedAlist;
9036
9037 /* Finalizer */
9038 typedef struct {
9039 XRECORD_HEADER
9040 gcv_object_t fin_alive _attribute_aligned_object_; /* only if this object is alive */
9041 gcv_object_t fin_trigger _attribute_aligned_object_; /* wait for the death of this object */
9042 gcv_object_t fin_function _attribute_aligned_object_; /* then this function is called */
9043 gcv_object_t fin_cdr _attribute_aligned_object_;
9044 } * Finalizer;
9045 #define finalizer_length ((sizeof(*(Finalizer)0)-offsetofa(record_,recdata))/sizeof(gcv_object_t))
9046
9047 #ifdef SOCKET_STREAMS
9048 /* Socket-Server */
9049 typedef struct {
9050 XRECORD_HEADER
9051 gcv_object_t socket_handle _attribute_aligned_object_; /* socket handle */
9052 gcv_object_t host _attribute_aligned_object_; /* host string */
9053 gcv_object_t port _attribute_aligned_object_; /* port number */
9054 } * Socket_server;
9055 #define socket_server_length ((sizeof(*(Socket_server)0)-offsetofa(record_,recdata))/sizeof(gcv_object_t))
9056
9057 /* Information about any of the two ends of a socket connection. */
9058 #ifndef MAXHOSTNAMELEN
9059 #define MAXHOSTNAMELEN 64
9060 #endif
9061 typedef struct host_data_t {
9062 char hostname[45+1]; /* IP address in presentable, printable format
9063 (IPv4 max. 15 characters, IPv6 max. 45 characters) */
9064 char truename[MAXHOSTNAMELEN+1]; /* hostname, with or without domain name */
9065 unsigned int port;
9066 } host_data_t;
9067 #endif
9068
9069 #ifdef YET_ANOTHER_RECORD
9070
9071 /* Yet another record */
9072 typedef struct {
9073 XRECORD_HEADER
9074 gcv_object_t yetanother_x _attribute_aligned_object_;
9075 gcv_object_t yetanother_y _attribute_aligned_object_;
9076 gcv_object_t yetanother_z _attribute_aligned_object_;
9077 } * Yetanother;
9078 #define yetanother_length ((sizeof(*(Yetanother)0)-offsetofa(record_,recdata))/sizeof(gcv_object_t))
9079
9080 #endif
9081
9082 /* Streams with metaclass BUILT-IN-CLASS */
9083 typedef struct {
9084 XRECORD_HEADER
9085 /* Because of space requirements, I have to put strmflags and strmtype
9086 into a fixnum in recdata[0]. */
9087 union {
9088 /* Use a union, so that we have fast access to strmflags and strmtype.
9089 With DEBUG_GCSAFETY and C++ prior to -std=gnu++11, we cannot put a
9090 gcv_object_t in a union. */
9091 #if defined(OBJECT_STRUCT) || defined(WIDE_STRUCT)
9092 struct { INNARDS_OF_GCV_OBJECT } recdata0_o _attribute_aligned_object_;
9093 #else
9094 gcv_object_t recdata0_o _attribute_aligned_object_;
9095 #endif
9096 struct {
9097 #if !((oint_addr_len+oint_addr_shift>=24) && (8>=oint_addr_shift))
9098 #error No room for stream flags -- re-accommodate Stream-Flags!!
9099 #endif
9100 #if defined(WIDE) && BIG_ENDIAN_P
9101 uintL r0_filler0;
9102 #endif
9103 uintB r0_filler1;
9104 uintB r0_flags; /* Flags */
9105 uintB r0_type; /* Subtype */
9106 uintB r0_filler2;
9107 #if defined(WIDE) && !BIG_ENDIAN_P
9108 uintL r0_filler0;
9109 #endif
9110 } recdata0_decomposed;
9111 } strm_recdata0;
9112 #define strmflags strm_recdata0.recdata0_decomposed.r0_flags
9113 #define strmtype strm_recdata0.recdata0_decomposed.r0_type
9114 gcv_object_t strm_rd_by _attribute_aligned_object_;
9115 gcv_object_t strm_rd_by_array _attribute_aligned_object_;
9116 gcv_object_t strm_wr_by _attribute_aligned_object_;
9117 gcv_object_t strm_wr_by_array _attribute_aligned_object_;
9118 gcv_object_t strm_rd_ch _attribute_aligned_object_;
9119 gcv_object_t strm_pk_ch _attribute_aligned_object_;
9120 gcv_object_t strm_rd_ch_array _attribute_aligned_object_;
9121 gcv_object_t strm_rd_ch_last _attribute_aligned_object_;
9122 gcv_object_t strm_wr_ch _attribute_aligned_object_;
9123 gcv_object_t strm_wr_ch_array _attribute_aligned_object_;
9124 gcv_object_t strm_wr_ch_npnl _attribute_aligned_object_;
9125 gcv_object_t strm_wr_ch_array_npnl _attribute_aligned_object_;
9126 gcv_object_t strm_wr_ch_lpos _attribute_aligned_object_;
9127 gcv_object_t strm_other[unspecified] _attribute_aligned_object_; /* type-specific components */
9128 } * Stream;
9129 /* The macro TheStream actually means TheBuiltinStream. */
9130 #define strm_len ((sizeof(*(Stream)0)-offsetofa(record_,recdata))/sizeof(gcv_object_t)-unspecified)
9131 #define stream_length(ptr) xrecord_length(ptr)
9132 #define stream_xlength(ptr) xrecord_xlength(ptr)
9133 #define Stream_length(obj) stream_length(TheStream(obj))
9134 #define Stream_xlength(obj) stream_xlength(TheStream(obj))
9135 /* Bit-masks in the Flags: */
9136 #define strmflags_open_bit_B 0 /* set, if the Stream is open */
9137 #define strmflags_immut_bit_B 1 /* set if read literals are immutable */
9138 #define strmflags_fasl_bit_B 2 /* Read-Eval is permitted; \r=#\Return */
9139 #define strmflags_rd_by_bit_B 4 /* set, if READ-BYTE is possible */
9140 #define strmflags_wr_by_bit_B 5 /* set, if WRITE-BYTE is possible */
9141 #define strmflags_rd_ch_bit_B 6 /* set, if READ-CHAR is possible */
9142 #define strmflags_wr_ch_bit_B 7 /* set, if WRITE-CHAR is possible */
9143 #define strmflags_open_B bit(strmflags_open_bit_B)
9144 #define strmflags_rd_by_B bit(strmflags_rd_by_bit_B)
9145 #define strmflags_wr_by_B bit(strmflags_wr_by_bit_B)
9146 #define strmflags_rd_ch_B bit(strmflags_rd_ch_bit_B)
9147 #define strmflags_wr_ch_B bit(strmflags_wr_ch_bit_B)
9148 #define strmflags_rd_B (strmflags_rd_by_B | strmflags_rd_ch_B)
9149 #define strmflags_wr_B (strmflags_wr_by_B | strmflags_wr_ch_B)
9150 /* approach Typinfo: */
9151 enum { /* The ordered values of this enumeration are 0,1,2,... */
9152 /* First the OS independent streams. */
9153 enum_strmtype_synonym,
9154 #define strmtype_synonym (uintB)enum_strmtype_synonym
9155 enum_strmtype_broad,
9156 #define strmtype_broad (uintB)enum_strmtype_broad
9157 enum_strmtype_concat,
9158 #define strmtype_concat (uintB)enum_strmtype_concat
9159 enum_strmtype_twoway,
9160 #define strmtype_twoway (uintB)enum_strmtype_twoway
9161 enum_strmtype_echo,
9162 #define strmtype_echo (uintB)enum_strmtype_echo
9163 enum_strmtype_str_in,
9164 #define strmtype_str_in (uintB)enum_strmtype_str_in
9165 enum_strmtype_str_out,
9166 #define strmtype_str_out (uintB)enum_strmtype_str_out
9167 enum_strmtype_str_push,
9168 #define strmtype_str_push (uintB)enum_strmtype_str_push
9169 enum_strmtype_pphelp,
9170 #define strmtype_pphelp (uintB)enum_strmtype_pphelp
9171 enum_strmtype_buff_in,
9172 #define strmtype_buff_in (uintB)enum_strmtype_buff_in
9173 enum_strmtype_buff_out,
9174 #define strmtype_buff_out (uintB)enum_strmtype_buff_out
9175 #ifdef GENERIC_STREAMS
9176 enum_strmtype_generic,
9177 #define strmtype_generic (uintB)enum_strmtype_generic
9178 #endif
9179 /* Then the OS dependent streams. */
9180 enum_strmtype_file,
9181 #define strmtype_file (uintB)enum_strmtype_file
9182 #ifdef KEYBOARD
9183 enum_strmtype_keyboard,
9184 #define strmtype_keyboard (uintB)enum_strmtype_keyboard
9185 #endif
9186 enum_strmtype_terminal,
9187 #define strmtype_terminal (uintB)enum_strmtype_terminal
9188 #ifdef SCREEN
9189 enum_strmtype_window,
9190 #define strmtype_window (uintB)enum_strmtype_window
9191 #endif
9192 #ifdef PRINTER
9193 enum_strmtype_printer,
9194 #define strmtype_printer (uintB)enum_strmtype_printer
9195 #endif
9196 #ifdef PIPES
9197 enum_strmtype_pipe_in,
9198 #define strmtype_pipe_in (uintB)enum_strmtype_pipe_in
9199 enum_strmtype_pipe_out,
9200 #define strmtype_pipe_out (uintB)enum_strmtype_pipe_out
9201 #endif
9202 #ifdef X11SOCKETS
9203 enum_strmtype_x11socket,
9204 #define strmtype_x11socket (uintB)enum_strmtype_x11socket
9205 #endif
9206 #ifdef SOCKET_STREAMS
9207 enum_strmtype_socket,
9208 #define strmtype_socket (uintB)enum_strmtype_socket
9209 enum_strmtype_twoway_socket,
9210 #define strmtype_twoway_socket (uintB)enum_strmtype_twoway_socket
9211 #endif
9212 enum_strmtype_dummy
9213 };
9214 /* When this table is changed, also adapt
9215 - the 12 jumptables for STREAM-ELEMENT-TYPE, SET-STREAM-ELEMENT-TYPE,
9216 STREAM-EXTERNAL-FORMAT, SET-STREAM-EXTERNAL-FORMAT, INTERACTIVE-STREAM-P,
9217 CLOSE, LISTEN-CHAR, CLEAR_INPUT, LISTEN-BYTE, FINISH_OUTPUT,
9218 FORCE_OUTPUT, CLEAR_OUTPUT in STREAM.D and
9219 - the name-table in CONSTOBJ.D and
9220 - the jumptable for PR_STREAM in IO.D and
9221 - the pseudo-function-table in PSEUDOFUN.D */
9222
9223 /* more type-specific components: */
9224 #define strm_eltype strm_other[0] /* CHARACTER or ([UN]SIGNED-BYTE n) */
9225 #define strm_encoding strm_other[1] /* an encoding */
9226 #define strm_file_name strm_other[6] /* filename, a pathname or NIL */
9227 #define strm_file_truename strm_other[7] /* truename, a non-logical pathname or NIL */
9228 #define strm_buffered_channel strm_other[5] /* packed Handle */
9229 #define strm_synonym_symbol strm_other[0]
9230 #define strm_broad_list strm_other[0] /* list of Streams */
9231 #define strm_concat_list strm_other[0] /* list of Streams */
9232 #define strm_pphelp_lpos strm_wr_ch_lpos /* Line Position (Fixnum>=0) */
9233 #define strm_pphelp_strings strm_other[0] /* Semi-Simple-Strings for Output */
9234 #define strm_pphelp_modus strm_other[1] /* Mode (NIL=Single line, T=multiple lines) */
9235 #define strm_pphelp_miserp strm_other[2] /* miser mode indicator */
9236 #define strm_pphelp_offset strm_other[3] /* initial line offset (indent) */
9237 #define strm_buff_in_fun strm_other[0] /* read function */
9238 #define strm_buff_out_fun strm_other[0] /* output function */
9239 #define strm_twoway_input strm_other[0] /* stream for input */
9240 #define strm_twoway_output strm_other[1] /* stream for output */
9241 #ifdef PIPES
9242 #define strm_pipe_pid strm_other[6] /* process-Id, a Fixnum >=0 */
9243 #endif
9244 #ifdef X11SOCKETS
9245 #define strm_x11socket_connect strm_other[6] /* List (host display) */
9246 #endif
9247 #ifdef SOCKET_STREAMS
9248 #define strm_socket_port strm_other[6] /* port, a fixnum >=0 */
9249 #define strm_socket_host strm_other[7] /* host, NIL or a string */
9250 #define strm_twoway_socket_input strm_other[0] /* input side, a socket stream */
9251 #endif
9252 #ifdef GENERIC_STREAMS
9253 #define strm_controller_object strm_other[0] /* Controller (usually a CLOS-instance) */
9254 #endif
9255 #define strm_buffered_bufflen 4096 /* buffer length, a power of 2, <2^16 */
9256 /* is used by stream.d, pathname.d, io.d */
9257 %% export_def(strm_buffered_bufflen);
9258
9259 /* Structures */
9260 typedef Srecord Structure;
9261 #define structure_types recdata[0]
9262 #define structure_length(ptr) srecord_length(ptr)
9263 #define Structure_length(obj) structure_length(TheStructure(obj))
9264 %% emit_typedef("Srecord","Structure");
9265 %% export_def(structure_types);
9266
9267 /* CLOS class-versions, see clos.lisp */
9268 typedef struct {
9269 VRECORD_HEADER
9270 gcv_object_t cv_newest_class _attribute_aligned_object_; /* the CLASS object describing the newest available version */
9271 gcv_object_t cv_class _attribute_aligned_object_; /* the CLASS object describing the slots */
9272 gcv_object_t cv_shared_slots _attribute_aligned_object_; /* simple-vector with the values of all shared slots, or nil */
9273 gcv_object_t cv_serial _attribute_aligned_object_; /* serial number of this class version */
9274 gcv_object_t cv_next _attribute_aligned_object_; /* next class-version, or nil */
9275 gcv_object_t cv_slotlists_valid_p _attribute_aligned_object_; /* true if the following fields are already computed */
9276 gcv_object_t cv_kept_slot_locations _attribute_aligned_object_; /* plist of old and new slot locations of those slots that remain local or were shared and become local */
9277 gcv_object_t cv_added_slots _attribute_aligned_object_; /* list of local slots that are added in the next version */
9278 gcv_object_t cv_discarded_slots _attribute_aligned_object_; /* list of local slots that are removed or become shared in the next version */
9279 gcv_object_t cv_discarded_slot_locations _attribute_aligned_object_; /* plist of local slots and their old slot locations that are removed or become shared in the next version */
9280 } * ClassVersion;
9281 #define classversion_length ((sizeof(*(ClassVersion)0)-offsetofa(svector_,data))/sizeof(gcv_object_t))
9282
9283 /* CLOS-instances */
9284 typedef struct {
9285 SRECORD_HEADER
9286 gcv_object_t inst_class_version _attribute_aligned_object_; /* indirect pointer to a CLOS-class */
9287 gcv_object_t other[unspecified] _attribute_aligned_object_;
9288 } * Instance;
9289 /* Bit masks in the flags: */
9290 #define instflags_forwarded_B bit(0)
9291 #define instflags_beingupdated_B bit(3)
9292 /* The following are only used during garbage collection. */
9293 #define instflags_backpointer_B bit(1)
9294 #define instflags_relocated_B bit(2)
9295 #define mark_inst_clean(ptr) \
9296 record_flags_clr(ptr,instflags_backpointer_B|instflags_relocated_B)
9297 %% sprintf(buf,"struct { SRECORD_HEADER gcv_object_t inst_class_version%s; gcv_object_t other[unspecified]%s; } *",attribute_aligned_object,attribute_aligned_object);
9298 %% emit_typedef(buf,"Instance");
9299
9300 /* Structures that inherit from <structure-stablehash> */
9301 typedef struct {
9302 SRECORD_HEADER
9303 gcv_object_t _structure_types _attribute_aligned_object_;
9304 gcv_object_t stablehashcode _attribute_aligned_object_;
9305 gcv_object_t other[unspecified] _attribute_aligned_object_;
9306 } * StablehashStructure;
9307
9308 /* CLOS instances that inherit from <standard-stablehash> */
9309 typedef struct {
9310 SRECORD_HEADER
9311 gcv_object_t inst_class_version _attribute_aligned_object_; /* indirect pointer to a CLOS-class */
9312 gcv_object_t stablehashcode _attribute_aligned_object_;
9313 gcv_object_t other[unspecified] _attribute_aligned_object_;
9314 } * StablehashInstance;
9315
9316 /* Slot definitions (= instances of <slot-definition>, see clos-slotdef1.lisp */
9317 typedef struct {
9318 SRECORD_HEADER
9319 gcv_object_t inst_class_version _attribute_aligned_object_;
9320 gcv_object_t slotdef_name _attribute_aligned_object_;
9321 gcv_object_t slotdef_initargs _attribute_aligned_object_;
9322 gcv_object_t slotdef_type _attribute_aligned_object_;
9323 gcv_object_t slotdef_allocation _attribute_aligned_object_;
9324 gcv_object_t slotdef_inheritable_initer _attribute_aligned_object_;
9325 gcv_object_t slotdef_inheritable_doc _attribute_aligned_object_;
9326 /* from here on only for subclasses of <effective-slot-definition> */
9327 gcv_object_t slotdef_location _attribute_aligned_object_;
9328 gcv_object_t slotdef_efm_svuc _attribute_aligned_object_;
9329 gcv_object_t slotdef_efm_ssvuc _attribute_aligned_object_;
9330 gcv_object_t slotdef_efm_sbuc _attribute_aligned_object_;
9331 gcv_object_t slotdef_efm_smuc _attribute_aligned_object_;
9332 } * SlotDefinition;
9333
9334 /* CLOS-Classes (= instances of <class>), see clos-class1.lisp */
9335 typedef struct {
9336 SRECORD_HEADER
9337 gcv_object_t inst_class_version _attribute_aligned_object_; /* indirect pointer to a CLOS-class */
9338 gcv_object_t hashcode _attribute_aligned_object_; /* GC invariant hash code */
9339 gcv_object_t direct_methods _attribute_aligned_object_; /* set of methods that use this specializer */
9340 gcv_object_t classname _attribute_aligned_object_; /* a symbol */
9341 gcv_object_t direct_subclasses _attribute_aligned_object_; /* weak-list or weak-hash-table of all direct subclasses */
9342 /* from here on only for subclasses of <defined-class> */
9343 gcv_object_t direct_superclasses _attribute_aligned_object_; /* direct superclasses */
9344 gcv_object_t all_superclasses _attribute_aligned_object_; /* all superclasses, including itself */
9345 gcv_object_t precedence_list _attribute_aligned_object_; /* ordered list of all superclasses */
9346 gcv_object_t direct_slots _attribute_aligned_object_;
9347 gcv_object_t slots _attribute_aligned_object_;
9348 gcv_object_t slot_location_table _attribute_aligned_object_; /* hashtable slotname -> where the slot is located */
9349 gcv_object_t direct_default_initargs _attribute_aligned_object_;
9350 gcv_object_t default_initargs _attribute_aligned_object_;
9351 gcv_object_t documentation _attribute_aligned_object_; /* string or NIL */
9352 gcv_object_t listeners _attribute_aligned_object_; /* list of objects to be notified upon a change */
9353 gcv_object_t initialized _attribute_aligned_object_; /* describes which parts of the class are initialized */
9354 /* from here on only for subclasses of <standard-class> or <funcallable-standard-class> or <structure-class> */
9355 gcv_object_t subclass_of_stablehash_p _attribute_aligned_object_; /* true if <standard-stablehash> or <structure-stablehash> is among the superclasses */
9356 gcv_object_t generic_accessors _attribute_aligned_object_;
9357 gcv_object_t direct_accessors _attribute_aligned_object_;
9358 gcv_object_t valid_initargs_from_slots _attribute_aligned_object_;
9359 gcv_object_t instance_size _attribute_aligned_object_;
9360 /* from here on only for subclasses of <standard-class> or <funcallable-standard-class> */
9361 gcv_object_t current_version _attribute_aligned_object_; /* most recent class-version, points back to this class */
9362 gcv_object_t funcallablep _attribute_aligned_object_;
9363 gcv_object_t fixed_slot_locations _attribute_aligned_object_;
9364 gcv_object_t instantiated _attribute_aligned_object_;
9365 gcv_object_t direct_instance_specializers _attribute_aligned_object_;
9366 gcv_object_t finalized_direct_subclasses _attribute_aligned_object_; /* weak-list or weak-hash-table of all finalized direct subclasses */
9367 gcv_object_t prototype _attribute_aligned_object_; /* class prototype - an instance or NIL */
9368 /* from here on only for subclasses of <standard-class> */
9369 gcv_object_t other[unspecified] _attribute_aligned_object_;
9370 } * Class;
9371
9372 /* Length of a <defined-class>. */
9373 #define defined_class_length ((((aint)&((Class)0)->initialized-offsetofa(record_,recdata))/sizeof(gcv_object_t))+1)
9374 /* Length of a <built-in-class>. */
9375 #define built_in_class_length (defined_class_length+1) /* = clos::*<built-in-class>-instance-size* */
9376
9377 /* Closures */
9378 typedef struct {
9379 SRECORD_HEADER
9380 gcv_object_t clos_name_or_class_version _attribute_aligned_object_;
9381 gcv_object_t clos_codevec _attribute_aligned_object_;
9382 gcv_object_t other[unspecified] _attribute_aligned_object_;
9383 } * Closure;
9384 /* interpreted Closure: */
9385 typedef struct {
9386 SRECORD_HEADER
9387 gcv_object_t clos_name _attribute_aligned_object_;
9388 gcv_object_t clos_form _attribute_aligned_object_;
9389 gcv_object_t clos_docstring _attribute_aligned_object_;
9390 gcv_object_t clos_body _attribute_aligned_object_;
9391 gcv_object_t clos_var_env _attribute_aligned_object_;
9392 gcv_object_t clos_fun_env _attribute_aligned_object_;
9393 gcv_object_t clos_block_env _attribute_aligned_object_;
9394 gcv_object_t clos_go_env _attribute_aligned_object_;
9395 gcv_object_t clos_decl_env _attribute_aligned_object_;
9396 gcv_object_t clos_vars _attribute_aligned_object_;
9397 gcv_object_t clos_varflags _attribute_aligned_object_;
9398 gcv_object_t clos_spec_count _attribute_aligned_object_;
9399 gcv_object_t clos_req_count _attribute_aligned_object_;
9400 gcv_object_t clos_opt_count _attribute_aligned_object_;
9401 gcv_object_t clos_opt_inits _attribute_aligned_object_;
9402 gcv_object_t clos_key_count _attribute_aligned_object_;
9403 gcv_object_t clos_keywords _attribute_aligned_object_;
9404 gcv_object_t clos_key_inits _attribute_aligned_object_;
9405 gcv_object_t clos_allow_flag _attribute_aligned_object_;
9406 gcv_object_t clos_rest_flag _attribute_aligned_object_;
9407 gcv_object_t clos_aux_count _attribute_aligned_object_;
9408 gcv_object_t clos_aux_inits _attribute_aligned_object_;
9409 } * Iclosure;
9410 #define iclos_length ((sizeof(*(Iclosure)0)-offsetofa(record_,recdata))/sizeof(gcv_object_t))
9411 /* compiled Closure: */
9412 typedef struct {
9413 SRECORD_HEADER
9414 gcv_object_t clos_name_or_class_version _attribute_aligned_object_;
9415 gcv_object_t clos_codevec _attribute_aligned_object_;
9416 gcv_object_t clos_consts[unspecified] _attribute_aligned_object_; /* Closure-constants */
9417 } cclosure_;
9418 typedef cclosure_ * Cclosure;
9419 #define cclosure_length(ptr) srecord_length(ptr)
9420 #define Cclosure_length(obj) cclosure_length(TheCclosure(obj))
9421 /* Flags in a closure. They must be disjoint from the instflags_* bits. */
9422 #ifdef TYPECODES
9423 #define closure_flags(ptr) ((ptr)->recflags)
9424 #else
9425 #define closure_flags(ptr) record_flags(ptr)
9426 #endif
9427 #define Closure_flags(obj) closure_flags(TheClosure(obj))
9428 #define Cclosure_seclass(obj) ((Closure_flags(obj) >> 4) & 0x07)
9429 #define Cclosure_set_seclass(obj,se) \
9430 (record_flags_clr(TheCclosure(obj),0x07<<4), \
9431 record_flags_set(TheCclosure(obj),(se)<<4))
9432 #define closflags_instance_B bit(7)
9433 #define closure_instancep(ptr) (closure_flags(ptr) & closflags_instance_B)
9434 #define Closure_instancep(obj) closure_instancep(TheClosure(obj))
9435 /* Closed-over environment, as a set of nested simple-vectors. */
9436 #define clos_venv clos_consts[0]
9437 /* The function's name. Depends on whether instancep or not. */
9438 #define Closure_name(obj) \
9439 (Closure_instancep(obj) \
9440 ? TheCclosure(obj)->clos_consts[1] \
9441 : TheClosure(obj)->clos_name_or_class_version)
9442 typedef struct {
9443 VRECORD_HEADER /* self-pointer for GC, length in bits */
9444 /* Here: Content of the Bitvector. */
9445 uintW ccv_spdepth_1; /* maximal SP-depth, 1-part */
9446 uintW ccv_spdepth_jmpbufsize; /* maximal SP-depth, jmpbufsize-part */
9447 uintW ccv_numreq; /* number of required parameters */
9448 uintW ccv_numopt; /* number of optional parameters */
9449 uintB ccv_flags; /* Flags: Bit 0: &REST - parameter given?
9450 Bit 1: full lambda list at the end of const vec
9451 Bit 2: docstring at the end of const vec
9452 Bit 3: generic function with call-inhibition?
9453 Bit 4: generic function?
9454 Bit 5: JITC code at the end of const vec
9455 Bit 6: &ALLOW-OTHER-KEYS-Flag
9456 Bit 7: keyword-parameter given? */
9457 uintB ccv_signature; /* abbreviated argument type, for faster FUNCALL */
9458 /* If keyword-parameters are given: */
9459 uintW ccv_numkey; /* Number of keyword-parameters */
9460 uintW ccv_keyconsts; /* Offset in FUNC of the keywords */
9461 } * Codevec;
9462 #define CCV_SPDEPTH_1 0
9463 #define CCV_SPDEPTH_JMPBUFSIZE 2
9464 #define CCV_NUMREQ 4
9465 #define CCV_NUMOPT 6
9466 #define CCV_FLAGS 8
9467 #define CCV_SIGNATURE 9
9468 #define CCV_NUMKEY 10
9469 #define CCV_KEYCONSTS 12
9470 #define CCV_START_NONKEY 10
9471 #define CCV_START_KEY 14
9472 /* Compiled closures, where Bit 4 has been set in the flags of clos_codevec
9473 are generic functions. */
9474 %% export_def(closure_flags(ptr));
9475 %% export_def(closure_instancep(ptr));
9476 %% export_def(Closure_instancep(obj));
9477
9478 /* the position of the last const (or doc or lalist!) */
9479 #define Cclosure_last_const(obj) (Cclosure_length(obj) - 1 - \
9480 (offsetofa(cclosure_,clos_consts)-offsetofa(srecord_,recdata))/sizeof(gcv_object_t))
9481 #define ccv_flags_lambda_list_p(ccv_flags) (((ccv_flags) & bit(1)) != 0)
9482 #define ccv_flags_documentation_p(ccv_flags) (((ccv_flags) & bit(2)) != 0)
9483 #define ccv_flags_jitc_p(ccv_flags) (((ccv_flags) & bit(5)) != 0)
9484 #define cclosure_jitc(closure) TheCclosure(closure)->clos_consts[Cclosure_last_const(closure)]
9485 #define cclosure_jitc_p(closure) ccv_flags_jitc_p(TheCodevec(TheCclosure(closure)->clos_codevec)->ccv_flags)
9486
9487 /* A compiled LISP-function gets its arguments on the STACK
9488 and returns its values in MULTIPLE_VALUE_SPACE.
9489 It does not return a value as a C-function. */
9490 /* Return of multiple values is completely done through
9491 MULTIPLE_VALUE_SPACE. As C-function: result-type Values. */
9492 #ifndef Values
9493 typedef void Values;
9494 #endif
9495 /* To pass a type of the value Values: return_Values(...); */
9496 #define return_Values return_void
9497 /* A Lisp-function is a pointer to a C-function without returned value. */
9498 typedef Values (*lisp_function_t)();
9499 /* If this is changed, every call of a C-function with the result type
9500 'Values' (especially 'funcall', 'apply', 'eval') is to be checked. */
9501 %% puts("typedef void Values;"); /* emit_typedef useless: no sizeof(void) */
9502 %% emit_typedef_f("Values (*%s)()","lisp_function_t");
9503
9504 /* FSUBRs
9505 As C-functions: of type fsubr_function_t (no arguments, no value): */
9506 typedef Values fsubr_function_t (void);
9507 /* The addesses of these C-functions are jumped to directly
9508 For SAVEMEM/LOADMEM there is a table containing all FSUBRs. */
9509 typedef fsubr_function_t * fsubr_t;
9510 /* Signature of FSUBRs in the Lisp-way:
9511 argtype short for the argument type fsubr_argtype_t
9512 req_count number of required parameters uintW
9513 opt_count number of optional parameters uintW
9514 body_flag Body-Flag fsubr_body_t
9515 The component body_flag contains one uintW, but we mean: */
9516 typedef enum {
9517 fsubr_nobody,
9518 fsubr_body
9519 } fsubr_body_t;
9520 /* The component argtype contains a Fixnum, but it's supposed to be: */
9521 typedef enum {
9522 fsubr_argtype_1_0_nobody,
9523 fsubr_argtype_2_0_nobody,
9524 fsubr_argtype_1_1_nobody,
9525 fsubr_argtype_2_1_nobody,
9526 fsubr_argtype_0_body,
9527 fsubr_argtype_1_body,
9528 fsubr_argtype_2_body
9529 } fsubr_argtype_t;
9530 /* conversion: see SPVW:
9531 extern fsubr_argtype_t fsubr_argtype (uintW req_count, uintW opt_count, fsubr_body_t body_flag); */
9532
9533 /* SUBRs
9534 SUBR table entry: */
9535 typedef struct {
9536 XRECORD_HEADER
9537 gcv_object_t name _attribute_aligned_object_; /* name */
9538 gcv_object_t keywords _attribute_aligned_object_; /* NIL or vector with the keywords */
9539 lisp_function_t function; /* function */
9540 uintW argtype; /* short for the argument-type */
9541 uintW req_count; /* number of required parameters */
9542 uintW opt_count; /* number of optional parameters */
9543 uintB rest_flag; /* flag for arbitrary number of arguments */
9544 uintB key_flag; /* flag for keywords */
9545 uintW key_count; /* number of keyword parameter */
9546 uintB seclass; /* side-effect class */
9547 uintB fastcmp; /* fast comparison method */
9548 /* If necessary, add fillers here to ensure sizeof(subr_t)
9549 is a multiple of varobject_alignment. */
9550 } subr_t
9551 #if defined(GENERIC64_HEAPCODES) && (alignment_long < 8) && defined(GNU)
9552 /* Force all Subrs to be allocated with a 8-byte alignment. GC needs this. */
9553 __attribute__ ((aligned (8)))
9554 #elif defined(HEAPCODES) && (alignment_long < 4) && defined(GNU)
9555 /* Force all Subrs to be allocated with a 4-byte alignment. GC needs this. */
9556 __attribute__ ((aligned (4)))
9557 #endif
9558 ;
9559 typedef subr_t * Subr;
9560 /* Compile-time check: sizeof(subr_t) is a multiple of varobject_alignment. */
9561 typedef int subr_size_check[1 - 2 * (int)(sizeof(subr_t) % varobject_alignment)];
9562 /* GC needs information where objects are in here: */
9563 #define subr_length 2
9564 #define subr_xlength (sizeof(*(Subr)0)-offsetofa(record_,recdata)-subr_length*sizeof(gcv_object_t))
9565 /* the rest_flag component is a uintB, while we really mean: */
9566 typedef enum {
9567 subr_norest,
9568 subr_rest
9569 } subr_rest_t;
9570 /* the key_flag component is a uintB, while we really mean: */
9571 typedef enum {
9572 subr_nokey,
9573 subr_key,
9574 subr_key_allow
9575 } subr_key_t;
9576 /* the argtype component is a uintW, while we really mean: */
9577 typedef enum {
9578 subr_argtype_0_0,
9579 subr_argtype_1_0,
9580 subr_argtype_2_0,
9581 subr_argtype_3_0,
9582 subr_argtype_4_0,
9583 subr_argtype_5_0,
9584 subr_argtype_6_0,
9585 subr_argtype_0_1,
9586 subr_argtype_1_1,
9587 subr_argtype_2_1,
9588 subr_argtype_3_1,
9589 subr_argtype_4_1,
9590 subr_argtype_0_2,
9591 subr_argtype_1_2,
9592 subr_argtype_2_2,
9593 subr_argtype_3_2,
9594 subr_argtype_0_3,
9595 subr_argtype_1_3,
9596 subr_argtype_2_3,
9597 subr_argtype_0_4,
9598 subr_argtype_0_5,
9599 subr_argtype_0_0_rest,
9600 subr_argtype_1_0_rest,
9601 subr_argtype_2_0_rest,
9602 subr_argtype_3_0_rest,
9603 subr_argtype_0_0_key,
9604 subr_argtype_1_0_key,
9605 subr_argtype_2_0_key,
9606 subr_argtype_3_0_key,
9607 subr_argtype_4_0_key,
9608 subr_argtype_0_1_key,
9609 subr_argtype_1_1_key,
9610 subr_argtype_1_2_key
9611 } subr_argtype_t;
9612 /* Conversion: see SPVW:
9613 extern subr_argtype_t subr_argtype (uintW req_count, uintW opt_count, subr_rest_t rest_flag, subr_key_t key_flag); */
9614 %% sprintf(buf,"struct { XRECORD_HEADER gcv_object_t name%s; gcv_object_t keywords%s; lisp_function_t function; uintW argtype; uintW req_count; uintW opt_count; uintB rest_flag; uintB key_flag; uintW key_count; uintB seclass; uintB fastcmp; } %%s",attribute_aligned_object,attribute_aligned_object);
9615 %% #if defined(HEAPCODES) && (alignment_long < 4) && defined(GNU)
9616 %% strcat(buf," __attribute__ ((aligned (4)))");
9617 %% #endif
9618 %% emit_typedef_f(buf,"subr_t");
9619 %% emit_typedef("subr_t *","Subr");
9620 %% emit_typedef("enum { subr_norest, subr_rest }","subr_rest_t");
9621 %% emit_typedef("enum { subr_nokey, subr_key, subr_key_allow }","subr_key_t");
9622
9623 /* side-effect class is really seclass_t: */
9624 typedef enum {
9625 seclass_foldable, /* the function allows Constant-Folding:
9626 two calls with identical arguments give the same result,
9627 and calls with constant arguments can be evaluated at compile time.
9628 In particular, no side effects, do not depend on global variables or such,
9629 do not even look "inside" their arguments */
9630 seclass_no_se, /* no side effects, do not depend on global variables or such,
9631 do not even look "inside" their arguments, but not "foldable". */
9632 seclass_read, /* no side effects, but depend on global variables
9633 or look "inside" their arguments. */
9634 seclass_rd_sig, /* same as read,
9635 but is also advertised to have "Exceptional situations" in unsafe code */
9636 seclass_write, /* only side effects: does not read anything,
9637 just sets some global variables. */
9638 seclass_default /* may do side effects */
9639 } seclass_t;
9640 %% puts("enum { seclass_foldable, seclass_no_se, seclass_read, seclass_rd_sig, seclass_write, seclass_default};");
9641
9642 /* fast comparison method is really fastcmp_t:
9643 when you want to make another comparison function bypass FUNCALL in
9644 :TEST/:TEST-NOT sequence functions, you need to
9645 -- add fastcmp_FOO here and
9646 -- augment funarg.d:check_test_args(), and
9647 -- add call_test_FOO and call_test_not_FOO in funarg.d */
9648 typedef enum {
9649 fastcmp_none=0, /* no special tricks */
9650 fastcmp_eq, /* EQ */
9651 fastcmp_eql, /* EQL */
9652 fastcmp_equal, /* EQUAL */
9653 fastcmp_equalp, /* EQUALP */
9654 fastcmp_for_broken_compilers_that_dont_like_trailing_commas
9655 } fastcmp_t;
9656
9657 /* Small-Read-Label */
9658 #ifdef TYPECODES
9659 #define make_small_read_label(n) \
9660 type_data_object(system_type, ((uintV)(n)<<1) + bit(0))
9661 #define small_read_label_integer_p(obj) \
9662 (posfixnump(obj) && (posfixnum_to_V(obj) < vbit(oint_data_len-2)))
9663 #define small_read_label_value(obj) \
9664 fixnum((as_oint(obj) >> (oint_data_shift+1)) & (vbit(oint_data_len-2)-1))
9665 #else
9666 #define make_small_read_label(n) \
9667 type_data_object(small_read_label_type, (uintV)(n))
9668 #define small_read_label_integer_p(obj) posfixnump(obj)
9669 #define small_read_label_value(obj) \
9670 fixnum((as_oint(obj) >> oint_data_shift) & (vbit(oint_data_len)-1))
9671 #endif
9672
9673 /* Machine pointers:
9674 make_machine(ptr)
9675 ptr must be a multiple of PSEUDODATA_ALIGNMENT. */
9676 #ifdef TYPECODES
9677 #define make_machine(ptr) type_pointer_object(machine_type,ptr)
9678 #else
9679 #define make_machine(ptr) as_object((oint)(ptr)+machine_bias)
9680 #endif
9681 %% export_def(make_machine(ptr));
9682
9683 #ifdef MULTITHREAD
9684 /* load the multithread stuff and export parts required by modules */
9685 #include "xthread.c"
9686 %% #ifdef MULTITHREAD
9687 %% #if defined(POSIX_THREADS)
9688 %% puts("#include <pthread.h>");
9689 %% puts("#include <sched.h>");
9690 %% #endif
9691 %% export_def(xthread_t);
9692 %% export_def(xthread_key_t);
9693 %% export_def(xmutex_raw_t);
9694 %% export_def(spinlock_t);
9695 %% #endif
9696
9697 /* forward declaration */
9698 struct clisp_thread_t;
9699
9700 typedef struct {
9701 XRECORD_HEADER
9702 gcv_object_t xth_name _attribute_aligned_object_; /* name */
9703 gcv_object_t xth_join_lock _attribute_aligned_object_; /* lock for thread-join waiting */
9704 gcv_object_t xth_join_exemption _attribute_aligned_object_; /* exemption for thread-join waiting */
9705 gcv_object_t xth_values _attribute_aligned_object_; /* return values */
9706 struct clisp_thread_t *xth_globals; /* all thread specific things */
9707 xthread_t xth_system; /* OS object */
9708 uintL xth_flags; /* flags for various thread features */
9709 } * Thread;
9710 #define thread_length 4
9711 #define thread_xlength (sizeof(*(Thread)0)-offsetofa(record_,recdata)-thread_length*sizeof(gcv_object_t))
9712
9713 /* has the thread exited normally? */
9714 #define thread_flag_normal_exit 0x0001
9715 #define thread_killedp(obj) (!(TheThread(obj)->xth_flags & thread_flag_normal_exit))
9716
9717 typedef struct {
9718 XRECORD_HEADER
9719 gcv_object_t xmu_name _attribute_aligned_object_; /* name */
9720 gcv_object_t xmu_owner _attribute_aligned_object_; /* owner (thread) */
9721 uintL xmu_flags; /* mutex flags - recursive? (by default - no)*/
9722 uintL xmu_recurse_count; /* how many times we have obtained the mutex */
9723 /* following is pointer to malloc()-ed memory. it's location should not
9724 change across GC since we may wait on it while GC is working.
9725 another option is to pin the mutex record but this leads to heap
9726 fragmentation and there should not be so many many mutex objects
9727 anyway */
9728 xmutex_t *xmu_system; /* OS object */
9729 } * Mutex;
9730 #define mutex_length 2
9731 #define mutex_xlength (sizeof(*(Mutex)0)-offsetofa(record_,recdata)-mutex_length*sizeof(gcv_object_t))
9732
9733 #define mutex_flag_recursive 0x0001
9734 #define mutex_recursivep(obj) (TheMutex(obj)->xmu_flags & mutex_flag_recursive)
9735
9736 typedef struct {
9737 XRECORD_HEADER
9738 gcv_object_t xco_name _attribute_aligned_object_; /* name */
9739 /* following is malloc()-ed. see Mutex comment */
9740 xcondition_t *xco_system; /* OS object */
9741 } * Exemption;
9742 #define exemption_length 1
9743 #define exemption_xlength (sizeof(*(Exemption)0)-offsetofa(record_,recdata)-exemption_length*sizeof(gcv_object_t))
9744
9745 #endif
9746
9747 /* Pointer to machine code
9748 make_machine_code(ptr)
9749 ptr must be a multiple of PSEUDOCODE_ALIGNMENT.
9750 make_machine_code_unchecked(ptr) does the same thing, without alignment check.
9751 */
9752 #if PSEUDODATA_ALIGNMENT <= C_CODE_ALIGNMENT
9753 #define PSEUDOCODE_ALIGNMENT C_CODE_ALIGNMENT
9754 #define log2_PSEUDOCODE_ALIGNMENT log2_C_CODE_ALIGNMENT
9755 /* The C_CODE_ALIGNMENT implies the PSEUDODATA_ALIGNMENT. */
9756 #define make_machine_code_unchecked(ptr) make_machine(ptr)
9757 #elif defined(HPPA) && !defined(HPPA64) && PSEUDODATA_ALIGNMENT == 4
9758 /* Assume that all function pointers are == 2 mod 4. */
9759 #define PSEUDOCODE_ALIGNMENT 4
9760 #define log2_PSEUDOCODE_ALIGNMENT 2
9761 #define make_machine_code_unchecked(ptr) make_machine((uintP)(ptr)&~(uintP)3)
9762 #elif !defined(NO_ADDRESS_SPACE_ASSUMPTIONS) \
9763 && (CODE_ADDRESS_RANGE < (oint_data_mask >> oint_data_shift >> (log2_PSEUDODATA_ALIGNMENT-log2_C_CODE_ALIGNMENT))) \
9764 && (MALLOC_ADDRESS_RANGE < (oint_data_mask >> oint_data_shift >> (log2_PSEUDODATA_ALIGNMENT-log2_C_CODE_ALIGNMENT))) \
9765 && (SHLIB_ADDRESS_RANGE < (oint_data_mask >> oint_data_shift >> (log2_PSEUDODATA_ALIGNMENT-log2_C_CODE_ALIGNMENT))) \
9766 && (STACK_ADDRESS_RANGE < (oint_data_mask >> oint_data_shift >> (log2_PSEUDODATA_ALIGNMENT-log2_C_CODE_ALIGNMENT)))
9767 /* We can shift addresses left by log2_PSEUDODATA_ALIGNMENT-log2_C_CODE_ALIGNMENT
9768 bits, and they will still fit into the data part of an oint. */
9769 #define PSEUDOCODE_ALIGNMENT C_CODE_ALIGNMENT
9770 #define log2_PSEUDOCODE_ALIGNMENT log2_C_CODE_ALIGNMENT
9771 #define make_machine_code_unchecked(ptr) make_machine((uintP)(ptr)<<(log2_PSEUDODATA_ALIGNMENT-log2_C_CODE_ALIGNMENT))
9772 #else
9773 /* An alignment of PSEUDODATA_ALIGNMENT is also necessary for the C functions.
9774 When using gcc, this may require adding -falign-functions=4 or
9775 -falign-functions=8, respectively, to the FALIGNFLAGS in the Makefile. */
9776 #define PSEUDOCODE_ALIGNMENT PSEUDODATA_ALIGNMENT
9777 #define log2_PSEUDOCODE_ALIGNMENT log2_PSEUDODATA_ALIGNMENT
9778 #define make_machine_code_unchecked(ptr) make_machine(ptr)
9779 #endif
9780 #if (SAFETY < 2) || (PSEUDOCODE_ALIGNMENT == 1)
9781 #define make_machine_code(ptr) make_machine_code_unchecked(ptr)
9782 #else
9783 extern _Noreturn void error_pseudocode_alignment (uintP address, const char* prefix, const char* name);
9784 #define make_machine_code(ptr) \
9785 (((((uintP)(void*)(ptr)-C_FUNCTION_POINTER_BIAS) & (PSEUDOCODE_ALIGNMENT-1)) \
9786 ? (error_pseudocode_alignment((uintP)(void*)(ptr),"",#ptr), 0) \
9787 : 0), \
9788 make_machine_code_unchecked(ptr))
9789 #endif
9790
9791 /* System-Pointer */
9792 #define make_system(data) \
9793 type_data_object(system_type, vbit(oint_data_len-1) | bit(0) | ((vbitm(oint_data_len)-1) & (data)))
9794 /* all such go into the special print routine io.d:pr_system() */
9795 %% export_def(make_system(data));
9796
9797 /* missing value */
9798 #define unbound make_system(0xFFFFFFUL)
9799 %% export_def(unbound);
9800
9801 /* missing object (internal use only): */
9802 #define nullobj make_machine(0) /* = as_object((oint)0) */
9803 #ifdef DEBUG_GCSAFETY
9804 #define gcv_nullobj (gcv_object_t)nullobj
9805 #else
9806 #define gcv_nullobj nullobj
9807 #endif
9808 %% export_def(nullobj);
9809 %% export_def(gcv_nullobj);
9810
9811
9812 /* cgci_pointable(obj) converts a certainly GC-invariant object to an aint.
9813 pgci_pointable(obj) converts a possibly GC-invariant object to an aint.
9814 ngci_pointable(obj) converts a not GC-invariant object to an aint. */
9815 #if defined(DEBUG_GCSAFETY)
cgci_pointable(object obj)9816 static inline aint cgci_pointable (object obj) {
9817 return obj.one_o;
9818 }
cgci_pointable(gcv_object_t obj)9819 static inline aint cgci_pointable (gcv_object_t obj) {
9820 return obj.one_o;
9821 }
pgci_pointable(object obj)9822 static inline aint pgci_pointable (object obj) {
9823 if (!(gcinvariant_object_p(obj) || gcinvariant_symbol_p(obj)
9824 || obj.allocstamp == alloccount || nonimmsubrp(obj)))
9825 abort();
9826 nonimmprobe(pointable_address_unchecked(obj.one_o));
9827 return obj.one_o;
9828 }
pgci_pointable(gcv_object_t obj)9829 static inline aint pgci_pointable (gcv_object_t obj) {
9830 nonimmprobe(pointable_address_unchecked(obj.one_o));
9831 return obj.one_o;
9832 }
ngci_pointable(object obj)9833 static inline aint ngci_pointable (object obj) {
9834 if (!(gcinvariant_symbol_p(obj)
9835 || obj.allocstamp == alloccount || nonimmsubrp(obj)))
9836 abort();
9837 nonimmprobe(pointable_address_unchecked(obj.one_o));
9838 return obj.one_o;
9839 }
ngci_pointable(gcv_object_t obj)9840 static inline aint ngci_pointable (gcv_object_t obj) {
9841 nonimmprobe(pointable_address_unchecked(obj.one_o));
9842 return obj.one_o;
9843 }
9844 #else
9845 #define cgci_pointable(obj) as_oint(obj)
9846 #define pgci_pointable(obj) as_oint(obj)
9847 #define ngci_pointable(obj) as_oint(obj)
9848 #endif
9849 %% #if defined(DEBUG_GCSAFETY)
9850 %% puts("static inline aint cgci_pointable (object obj) { return obj.one_o; }");
9851 %% puts("static inline aint cgci_pointable (gcv_object_t obj) { return obj.one_o; }");
9852 %% puts("static inline aint pgci_pointable (object obj) { if (!(gcinvariant_object_p(obj) || gcinvariant_symbol_p(obj) || obj.allocstamp == alloccount || nonimmsubrp(obj))) abort(); nonimmprobe(pointable_address_unchecked(obj.one_o)); return obj.one_o; }");
9853 %% puts("static inline aint pgci_pointable (gcv_object_t obj) { nonimmprobe(pointable_address_unchecked(obj.one_o)); return obj.one_o; }");
9854 %% puts("static inline aint ngci_pointable (object obj) { if (!(gcinvariant_symbol_p(obj) || obj.allocstamp == alloccount || nonimmsubrp(obj))) abort(); nonimmprobe(pointable_address_unchecked(obj.one_o)); return obj.one_o; }");
9855 %% puts("static inline aint ngci_pointable (gcv_object_t obj) { nonimmprobe(pointable_address_unchecked(obj.one_o)); return obj.one_o; }");
9856 %% #else
9857 %% export_def(cgci_pointable(obj));
9858 %% export_def(pgci_pointable(obj));
9859 %% export_def(ngci_pointable(obj));
9860 %% #endif
9861
9862 /* TheCons(object) yields the Cons that's equivalent to object.
9863 The information that it is a Cons has to be put into it.
9864 The other type conversions are similar. */
9865 #ifdef TYPECODES
9866 #ifdef DEBUG_GCSAFETY
9867 #define cgci_types_pointable(ORed_types,obj) pointable_address_unchecked(cgci_pointable(obj))
9868 #define pgci_types_pointable(ORed_types,obj) pointable_address_unchecked(pgci_pointable(obj))
9869 #define ngci_types_pointable(ORed_types,obj) pointable_address_unchecked(ngci_pointable(obj))
9870 #else
9871 #define cgci_types_pointable(ORed_types,obj) types_pointable(ORed_types,obj)
9872 #define pgci_types_pointable(ORed_types,obj) types_pointable(ORed_types,obj)
9873 #define ngci_types_pointable(ORed_types,obj) types_pointable(ORed_types,obj)
9874 #endif
9875 #define TheCons(obj) ((Cons)(ngci_types_pointable(cons_type,obj)))
9876 #define TheRatio(obj) ((Ratio)(ngci_types_pointable(ratio_type|bit(sign_bit_t),obj)))
9877 #define TheComplex(obj) ((Complex)(ngci_types_pointable(complex_type,obj)))
9878 #define TheSymbol(obj) ((Symbol)(ngci_types_pointable(symbol_type,obj)))
9879 #if (oint_symbolflags_shift==oint_type_shift)
9880 #define TheSymbolflagged(obj) ((Symbol)(ngci_types_pointable(symbol_type|bit(active_bit)|bit(dynam_bit)|bit(svar_bit),obj)))
9881 #else
9882 #define TheSymbolflagged(obj) TheSymbol(symbol_without_flags(obj))
9883 #endif
9884 #define TheBignum(obj) ((Bignum)(ngci_types_pointable(bignum_type|bit(sign_bit_t),obj)))
9885 #ifndef IMMEDIATE_FFLOAT
9886 #define TheFfloat(obj) ((Ffloat)(ngci_types_pointable(ffloat_type|bit(sign_bit_t),obj)))
9887 #endif
9888 #define TheDfloat(obj) ((Dfloat)(ngci_types_pointable(dfloat_type|bit(sign_bit_t),obj)))
9889 #define TheLfloat(obj) ((Lfloat)(ngci_types_pointable(lfloat_type|bit(sign_bit_t),obj)))
9890 #define TheSarray(obj) ((Sarray)(ngci_types_pointable(sbvector_type|sb2vector_type|sb4vector_type|sb8vector_type|sb16vector_type|sb32vector_type|sstring_type|svector_type,obj)))
9891 #define TheSbvector(obj) ((Sbvector)(ngci_types_pointable(sbvector_type|sb2vector_type|sb4vector_type|sb8vector_type|sb16vector_type|sb32vector_type,obj)))
9892 #define TheCodevec(obj) ((Codevec)(ngci_types_pointable(sb8vector_type,obj)))
9893 #define TheS8string(obj) ((S8string)(ngci_types_pointable(sstring_type,obj)))
9894 #define TheS16string(obj) ((S16string)(ngci_types_pointable(sstring_type,obj)))
9895 #define TheS32string(obj) ((S32string)(ngci_types_pointable(sstring_type,obj)))
9896 #define TheSnstring(obj) ((Snstring)(ngci_types_pointable(sstring_type,obj)))
9897 #define TheSistring(obj) ((Sistring)(ngci_types_pointable(sstring_type,obj)))
9898 #define TheSstring(obj) ((Sstring)(ngci_types_pointable(sstring_type,obj)))
9899 #define TheSvector(obj) ((Svector)(ngci_types_pointable(svector_type,obj)))
9900 #define TheIarray(obj) ((Iarray)(ngci_types_pointable(mdarray_type|bvector_type|b2vector_type|b4vector_type|b8vector_type|b16vector_type|b32vector_type|string_type|vector_type,obj)))
9901 #define TheRecord(obj) ((Record)(ngci_types_pointable(closure_type|structure_type|stream_type|orecord_type|instance_type|lrecord_type,obj)))
9902 #define TheLrecord(obj) ((Lrecord)(ngci_types_pointable(lrecord_type,obj)))
9903 #define TheSrecord(obj) ((Srecord)(ngci_types_pointable(closure_type|structure_type|orecord_type|instance_type,obj)))
9904 #define TheXrecord(obj) ((Xrecord)(ngci_types_pointable(stream_type|orecord_type,obj)))
9905 #define ThePackage(obj) ((Package)(ngci_types_pointable(orecord_type,obj)))
9906 #define TheHashtable(obj) ((Hashtable)(ngci_types_pointable(orecord_type,obj)))
9907 #define TheReadtable(obj) ((Readtable)(ngci_types_pointable(orecord_type,obj)))
9908 #define ThePathname(obj) ((Pathname)(ngci_types_pointable(orecord_type,obj)))
9909 #define TheLogpathname(obj) ((Logpathname)(ngci_types_pointable(orecord_type,obj)))
9910 #define The_Random_state(obj) ((Random_state)(ngci_types_pointable(orecord_type,obj)))
9911 #define TheByte(obj) ((Byte)(ngci_types_pointable(orecord_type,obj)))
9912 #define TheFsubr(obj) ((Fsubr)(ngci_types_pointable(orecord_type,obj)))
9913 #define TheLoadtimeeval(obj) ((Loadtimeeval)(ngci_types_pointable(orecord_type,obj)))
9914 #define TheSymbolmacro(obj) ((Symbolmacro)(ngci_types_pointable(orecord_type,obj)))
9915 #define TheGlobalSymbolmacro(obj) ((GlobalSymbolmacro)(ngci_types_pointable(orecord_type,obj)))
9916 #define TheMacro(obj) ((Macro)(ngci_types_pointable(orecord_type,obj)))
9917 #define TheFunctionMacro(obj) ((FunctionMacro)(ngci_types_pointable(orecord_type,obj)))
9918 #define TheBigReadLabel(obj) ((BigReadLabel)(ngci_types_pointable(orecord_type,obj)))
9919 #define TheEncoding(obj) ((Encoding)(ngci_types_pointable(orecord_type,obj)))
9920 #ifdef FOREIGN
9921 #define TheFpointer(obj) ((Fpointer)(ngci_types_pointable(orecord_type,obj)))
9922 #endif
9923 #ifdef DYNAMIC_FFI
9924 #define TheFaddress(obj) ((Faddress)(ngci_types_pointable(orecord_type,obj)))
9925 #define TheFvariable(obj) ((Fvariable)(ngci_types_pointable(orecord_type,obj)))
9926 #define TheFfunction(obj) ((Ffunction)(ngci_types_pointable(orecord_type,obj)))
9927 #endif
9928 #define TheWeakpointer(obj) ((Weakpointer)(ngci_types_pointable(orecord_type,obj)))
9929 #define TheMutableWeakList(obj) ((MutableWeakList)(ngci_types_pointable(orecord_type,obj)))
9930 #define TheWeakList(obj) ((WeakList)(ngci_types_pointable(lrecord_type,obj)))
9931 #define TheWeakAnd(obj) ((WeakAnd)(ngci_types_pointable(lrecord_type,obj)))
9932 #define TheWeakOr(obj) ((WeakOr)(ngci_types_pointable(lrecord_type,obj)))
9933 #define TheWeakmapping(obj) ((Weakmapping)(ngci_types_pointable(orecord_type,obj)))
9934 #define TheWeakAndMapping(obj) ((WeakAndMapping)(ngci_types_pointable(lrecord_type,obj)))
9935 #define TheWeakOrMapping(obj) ((WeakOrMapping)(ngci_types_pointable(lrecord_type,obj)))
9936 #define TheMutableWeakAlist(obj) ((MutableWeakAlist)(ngci_types_pointable(orecord_type,obj)))
9937 #define TheWeakAlist(obj) ((WeakAlist)(ngci_types_pointable(lrecord_type,obj)))
9938 #define TheWeakHashedAlist(obj) ((WeakHashedAlist)(ngci_types_pointable(lrecord_type,obj)))
9939 #define TheFinalizer(obj) ((Finalizer)(ngci_types_pointable(orecord_type,obj)))
9940 #ifdef SOCKET_STREAMS
9941 #define TheSocketServer(obj) ((Socket_server)(ngci_types_pointable(orecord_type,obj)))
9942 #endif
9943 #ifdef YET_ANOTHER_RECORD
9944 #define TheYetanother(obj) ((Yetanother)(ngci_types_pointable(orecord_type,obj)))
9945 #endif
9946 #define TheStream(obj) ((Stream)(ngci_types_pointable(stream_type,obj)))
9947 #define TheStructure(obj) ((Structure)(ngci_types_pointable(structure_type,obj)))
9948 #define TheClosure(obj) ((Closure)(ngci_types_pointable(closure_type,obj)))
9949 #define TheIclosure(obj) ((Iclosure)(ngci_types_pointable(closure_type,obj)))
9950 #define TheCclosure(obj) ((Cclosure)(ngci_types_pointable(closure_type,obj)))
9951 #define TheInstance(obj) ((Instance)(ngci_types_pointable(instance_type|closure_type,obj)))
9952 #define TheSubr(obj) ((Subr)(cgci_types_pointable(subr_type,obj)))
9953 #define TheFramepointer(obj) ((gcv_object_t*)(cgci_types_pointable(system_type,obj)))
9954 #define TheMachine(obj) ((void*)(cgci_types_pointable(machine_type,obj)))
9955 #ifdef FOREIGN_HANDLE
9956 /* pack Handle in Sbvector */
9957 #define TheHandle(obj) (*(Handle*)(&TheSbvector(obj)->data[0]))
9958 #else
9959 /* pack Handle in Fixnum>=0 */
9960 #define TheHandle(obj) ((Handle)posfixnum_to_V(obj))
9961 #endif
9962 /* variable length object: */
9963 #define TheVarobject(obj) \
9964 ((Varobject) \
9965 (ngci_types_pointable \
9966 (sbvector_type|sb2vector_type|sb4vector_type|sb8vector_type \
9967 |sb16vector_type|sb32vector_type \
9968 |sstring_type|svector_type \
9969 |mdarray_type \
9970 |bvector_type|b2vector_type|b4vector_type|b8vector_type \
9971 |b16vector_type|b32vector_type \
9972 |string_type|vector_type \
9973 |closure_type|structure_type|stream_type|orecord_type \
9974 |instance_type|lrecord_type|symbol_type \
9975 |bignum_type|ffloat_type|dfloat_type|lfloat_type|bit(sign_bit_t), \
9976 obj \
9977 )))
9978 /* Object that represents a pointer into the memory: */
9979 #define ThePointer(obj) \
9980 (pgci_types_pointable \
9981 (sbvector_type|sb2vector_type|sb4vector_type|sb8vector_type \
9982 |sb16vector_type|sb32vector_type \
9983 |sstring_type|svector_type \
9984 |mdarray_type \
9985 |bvector_type|b2vector_type|b4vector_type|b8vector_type \
9986 |b16vector_type|b32vector_type \
9987 |string_type|vector_type \
9988 |closure_type|structure_type|stream_type|orecord_type \
9989 |instance_type|lrecord_type|symbol_type \
9990 |cons_type \
9991 |bignum_type|ffloat_type|dfloat_type|lfloat_type \
9992 |ratio_type|complex_type|bit(sign_bit_t), \
9993 obj \
9994 ))
9995 #ifdef MULTITHREAD
9996 #define TheThread(obj) ((Thread)(ngci_types_pointable(orecord_type,obj)))
9997 #define TheMutex(obj) ((Mutex)(ngci_types_pointable(orecord_type,obj)))
9998 #define TheExemption(obj) ((Exemption)(ngci_types_pointable(orecord_type,obj)))
9999 #endif
10000 #else /* no TYPECODES */
10001 #define TheCons(obj) ((Cons)(ngci_pointable(obj)-cons_bias))
10002 #define TheRatio(obj) ((Ratio)(ngci_pointable(obj)-varobject_bias))
10003 #define TheComplex(obj) ((Complex)(ngci_pointable(obj)-varobject_bias))
10004 #define TheSymbol(obj) ((Symbol)(ngci_pointable(obj)-varobject_bias))
10005 #define TheSymbolflagged(obj) TheSymbol(symbol_without_flags(obj))
10006 #define TheBignum(obj) ((Bignum)(ngci_pointable(obj)-varobject_bias))
10007 #define TheFfloat(obj) ((Ffloat)(ngci_pointable(obj)-varobject_bias))
10008 #define TheDfloat(obj) ((Dfloat)(ngci_pointable(obj)-varobject_bias))
10009 #define TheLfloat(obj) ((Lfloat)(ngci_pointable(obj)-varobject_bias))
10010 #define TheSarray(obj) ((Sarray)(ngci_pointable(obj)-varobject_bias))
10011 #define TheSbvector(obj) ((Sbvector)(ngci_pointable(obj)-varobject_bias))
10012 #define TheCodevec(obj) ((Codevec)TheSbvector(obj))
10013 #define TheS8string(obj) ((S8string)(ngci_pointable(obj)-varobject_bias))
10014 #define TheS16string(obj) ((S16string)(ngci_pointable(obj)-varobject_bias))
10015 #define TheS32string(obj) ((S32string)(ngci_pointable(obj)-varobject_bias))
10016 #define TheSnstring(obj) ((Snstring)(ngci_pointable(obj)-varobject_bias))
10017 #define TheSistring(obj) ((Sistring)(ngci_pointable(obj)-varobject_bias))
10018 #define TheSstring(obj) ((Sstring)(ngci_pointable(obj)-varobject_bias))
10019 #define TheSvector(obj) ((Svector)(ngci_pointable(obj)-varobject_bias))
10020 #define TheIarray(obj) ((Iarray)(ngci_pointable(obj)-varobject_bias))
10021 #define TheRecord(obj) ((Record)(ngci_pointable(obj)-varobject_bias))
10022 #define TheLrecord(obj) ((Lrecord)(ngci_pointable(obj)-varobject_bias))
10023 #define TheSrecord(obj) ((Srecord)(ngci_pointable(obj)-varobject_bias))
10024 #define TheXrecord(obj) ((Xrecord)(ngci_pointable(obj)-varobject_bias))
10025 #define ThePackage(obj) ((Package)(ngci_pointable(obj)-varobject_bias))
10026 #define TheHashtable(obj) ((Hashtable)(ngci_pointable(obj)-varobject_bias))
10027 #define TheReadtable(obj) ((Readtable)(ngci_pointable(obj)-varobject_bias))
10028 #define ThePathname(obj) ((Pathname)(ngci_pointable(obj)-varobject_bias))
10029 #define TheLogpathname(obj) ((Logpathname)(ngci_pointable(obj)-varobject_bias))
10030 #define The_Random_state(obj) ((Random_state)(ngci_pointable(obj)-varobject_bias))
10031 #define TheByte(obj) ((Byte)(ngci_pointable(obj)-varobject_bias))
10032 #define TheFsubr(obj) ((Fsubr)(ngci_pointable(obj)-varobject_bias))
10033 #define TheLoadtimeeval(obj) ((Loadtimeeval)(ngci_pointable(obj)-varobject_bias))
10034 #define TheSymbolmacro(obj) ((Symbolmacro)(ngci_pointable(obj)-varobject_bias))
10035 #define TheGlobalSymbolmacro(obj) ((GlobalSymbolmacro)(ngci_pointable(obj)-varobject_bias))
10036 #define TheMacro(obj) ((Macro)(ngci_pointable(obj)-varobject_bias))
10037 #define TheFunctionMacro(obj) ((FunctionMacro)(ngci_pointable(obj)-varobject_bias))
10038 #define TheBigReadLabel(obj) ((BigReadLabel)(ngci_pointable(obj)-varobject_bias))
10039 #define TheEncoding(obj) ((Encoding)(ngci_pointable(obj)-varobject_bias))
10040 #ifdef FOREIGN
10041 #define TheFpointer(obj) ((Fpointer)(ngci_pointable(obj)-varobject_bias))
10042 #endif
10043 #ifdef DYNAMIC_FFI
10044 #define TheFaddress(obj) ((Faddress)(ngci_pointable(obj)-varobject_bias))
10045 #define TheFvariable(obj) ((Fvariable)(ngci_pointable(obj)-varobject_bias))
10046 #define TheFfunction(obj) ((Ffunction)(ngci_pointable(obj)-varobject_bias))
10047 #endif
10048 #define TheWeakpointer(obj) ((Weakpointer)(ngci_pointable(obj)-varobject_bias))
10049 #define TheMutableWeakList(obj) ((MutableWeakList)(ngci_pointable(obj)-varobject_bias))
10050 #define TheWeakList(obj) ((WeakList)(ngci_pointable(obj)-varobject_bias))
10051 #define TheWeakAnd(obj) ((WeakAnd)(ngci_pointable(obj)-varobject_bias))
10052 #define TheWeakOr(obj) ((WeakOr)(ngci_pointable(obj)-varobject_bias))
10053 #define TheWeakmapping(obj) ((Weakmapping)(ngci_pointable(obj)-varobject_bias))
10054 #define TheWeakAndMapping(obj) ((WeakAndMapping)(ngci_pointable(obj)-varobject_bias))
10055 #define TheWeakOrMapping(obj) ((WeakOrMapping)(ngci_pointable(obj)-varobject_bias))
10056 #define TheMutableWeakAlist(obj) ((MutableWeakAlist)(ngci_pointable(obj)-varobject_bias))
10057 #define TheWeakAlist(obj) ((WeakAlist)(ngci_pointable(obj)-varobject_bias))
10058 #define TheWeakHashedAlist(obj) ((WeakHashedAlist)(ngci_pointable(obj)-varobject_bias))
10059 #define TheFinalizer(obj) ((Finalizer)(ngci_pointable(obj)-varobject_bias))
10060 #ifdef SOCKET_STREAMS
10061 #define TheSocketServer(obj) ((Socket_server)(ngci_pointable(obj)-varobject_bias))
10062 #endif
10063 #ifdef YET_ANOTHER_RECORD
10064 #define TheYetanother(obj) ((Yetanother)(ngci_pointable(obj)-varobject_bias))
10065 #endif
10066 #define TheStream(obj) ((Stream)(ngci_pointable(obj)-varobject_bias))
10067 #define TheStructure(obj) ((Structure)(ngci_pointable(obj)-varobject_bias))
10068 #define TheClosure(obj) ((Closure)(ngci_pointable(obj)-varobject_bias))
10069 #define TheIclosure(obj) ((Iclosure)(ngci_pointable(obj)-varobject_bias))
10070 #define TheCclosure(obj) ((Cclosure)(ngci_pointable(obj)-varobject_bias))
10071 #define TheInstance(obj) ((Instance)(ngci_pointable(obj)-varobject_bias))
10072 #define TheSubr(obj) ((Subr)(cgci_pointable(obj)-subr_bias))
10073 #define TheFramepointer(obj) ((gcv_object_t*)(cgci_pointable(obj)-machine_bias))
10074 #define TheMachine(obj) ((void*)(cgci_pointable(obj)-machine_bias))
10075 #ifdef FOREIGN_HANDLE
10076 /* pack Handle in Sbvector */
10077 #define TheHandle(obj) (*(Handle*)(&TheSbvector(obj)->data[0]))
10078 #else
10079 /* pack Handle in Fixnum>=0 */
10080 #define TheHandle(obj) ((Handle)posfixnum_to_V(obj))
10081 #endif
10082 /* Object of variable length: */
10083 #define TheVarobject(obj) ((Varobject)(ngci_pointable(obj)-varobject_bias))
10084 /* Object, represents a pointer into the memory: */
10085 #define ThePointer(obj) ((void*)(pgci_pointable(obj) & ~(aint)nonimmediate_bias_mask))
10086 #ifdef MULTITHREAD
10087 #define TheThread(obj) ((Thread)(ngci_pointable(obj)-varobject_bias))
10088 #define TheMutex(obj) ((Mutex)(ngci_pointable(obj)-varobject_bias))
10089 #define TheExemption(obj) ((Exemption)(ngci_pointable(obj)-varobject_bias))
10090 #endif
10091 #endif
10092 /* TheMachineCode is the opposite of make_machine_code. */
10093 #if PSEUDODATA_ALIGNMENT <= C_CODE_ALIGNMENT
10094 #define TheMachineCode(obj) TheMachine(obj)
10095 #elif defined(HPPA) && !defined(HPPA64) && PSEUDODATA_ALIGNMENT == 4
10096 #define TheMachineCode(obj) ((void*)((uintP)TheMachine(obj)+C_FUNCTION_POINTER_BIAS))
10097 #elif PSEUDOCODE_ALIGNMENT == C_CODE_ALIGNMENT
10098 #define TheMachineCode(obj) ((void*)(((uintP)TheMachine(obj)>>(log2_PSEUDODATA_ALIGNMENT-log2_C_CODE_ALIGNMENT))|(CODE_ADDRESS_RANGE&~((~(uintP)0)>>(log2_PSEUDODATA_ALIGNMENT-log2_C_CODE_ALIGNMENT)))))
10099 #elif PSEUDOCODE_ALIGNMENT == PSEUDODATA_ALIGNMENT
10100 #define TheMachineCode(obj) TheMachine(obj)
10101 #endif
10102 #define ThePseudofun(obj) ((Pseudofun)TheMachineCode(obj))
10103 #define TheClassVersion(obj) ((ClassVersion)TheSvector(obj))
10104 #define TheSlotDefinition(obj) ((SlotDefinition)TheInstance(obj))
10105 #define TheClass(obj) ((Class)TheInstance(obj))
10106 %% export_def(TheCons(obj));
10107 %% #if notused
10108 %% export_def(TheRatio(obj));
10109 %% export_def(TheComplex(obj));
10110 %% #endif
10111 %% export_def(TheSymbol(obj));
10112 %% export_def(TheBignum(obj));
10113 %% #if notused
10114 %% export_def(TheSarray(obj));
10115 %% #endif
10116 %% export_def(TheSbvector(obj));
10117 %% #ifdef HAVE_SMALL_SSTRING
10118 %% export_def(TheS8string(obj));
10119 %% export_def(TheS16string(obj));
10120 %% export_def(TheS32string(obj));
10121 %% #endif
10122 %% export_def(TheSstring(obj));
10123 %% export_def(TheSvector(obj));
10124 %% export_def(TheRecord(obj));
10125 %% export_def(TheSrecord(obj));
10126 %% #if notused
10127 %% export_def(TheXrecord(obj));
10128 %% export_def(ThePackage(obj));
10129 %% #endif
10130 %% export_def(TheEncoding(obj));
10131 %% #ifdef FOREIGN
10132 %% export_def(TheFpointer(obj));
10133 %% #endif
10134 %% export_def(TheStructure(obj));
10135 %% export_def(TheClosure(obj));
10136 %% export_def(TheInstance(obj));
10137 %% export_def(TheSubr(obj));
10138 %% export_def(TheMachine(obj));
10139 %% export_def(TheMachineCode(obj));
10140 %% export_def(ThePseudofun(obj));
10141
10142 /* Some acronyms
10143 Access to objects that are conses: */
10144 #define Car(obj) (TheCons(obj)->car)
10145 #define Cdr(obj) (TheCons(obj)->cdr)
10146 #define Symbol_function(obj) (TheSymbol(obj)->symfunction)
10147 #define Symbol_plist(obj) (TheSymbol(obj)->proplist)
10148 #define Symbol_name(obj) (TheSymbol(obj)->pname)
10149 #define Symbol_package(obj) (TheSymbol(obj)->homepackage)
10150 /* Length (number of objects) of a record, obj has to be a Srecord/Xrecord: */
10151 #define SXrecord_length(obj) \
10152 (Record_type(obj) < rectype_limit ? Srecord_length(obj) : Xrecord_length(obj))
10153 /* Likewise, but ignoring weak pointers: */
10154 #define SXrecord_nonweak_length(obj) \
10155 (Record_type(obj) < rectype_limit \
10156 ? Srecord_length(obj) \
10157 : ((Record_type(obj)==Rectype_Weakpointer \
10158 || Record_type(obj)==Rectype_Weakmapping) \
10159 ? 0 \
10160 : Xrecord_length(obj)))
10161 /* Length of an Lrecord, ignoring weak pointers: */
10162 #define Lrecord_nonweak_length(obj) \
10163 ((Record_type(obj) >= Rectype_WeakList \
10164 && Record_type(obj) <= Rectype_WeakHashedAlist_Both) \
10165 ? 0 \
10166 : Lrecord_length(obj))
10167 /* Length (number of objects) of a record, obj has to be a Record: */
10168 #define Record_length(obj) \
10169 (Record_type(obj) >= rectype_longlimit \
10170 ? Lrecord_length(obj) \
10171 : SXrecord_length(obj))
10172 /* Likewise, but ignoring weak pointers: */
10173 #define Record_nonweak_length(obj) \
10174 (Record_type(obj) >= rectype_longlimit \
10175 ? Lrecord_nonweak_length(obj) \
10176 : SXrecord_nonweak_length(obj))
10177 %% export_def(Car(obj));
10178 %% export_def(Cdr(obj));
10179 %% export_def(Symbol_function(obj));
10180 %% export_def(Symbol_plist(obj));
10181 %% export_def(Symbol_name(obj));
10182 %% export_def(Symbol_package(obj));
10183
10184
10185 /* ####################### type test predicates ########################### #
10186 There are two kinds of predicates:
10187 1. ???p, query with 'if': if ???p(object)
10188 2. if_???p, called as
10189 if_???p(object, statement1, statement2)
10190 instead of
10191 if ???p(object) statement1 else statement2
10192
10193 UP: tests for equality of pointers EQ
10194 eq(obj1,obj2)
10195 > obj1,obj2: Lisp-objects
10196 < result: true, if objects are equal */
10197 #if defined(DEBUG_GCSAFETY)
10198 #define eq(obj1,obj2) (pgci_pointable(obj1) == pgci_pointable(obj2))
10199 #elif defined(WIDE_STRUCT) || defined(OBJECT_STRUCT)
10200 #define eq(obj1,obj2) (as_oint(obj1) == as_oint(obj2))
10201 #else
10202 #define eq(obj1,obj2) ((obj1) == (obj2))
10203 #endif
10204 %% export_def(eq(obj1,obj2));
10205
10206 /* Symbol_value() definition moved here - since in MT we need eq() to be defined. */
10207 /* Access to objects that are symbols: */
10208 #if defined(MULTITHREAD)
10209 /* helper inline functions to keep ANSI compliance and prevent multiple
10210 time arguments evaluation. Should we __forceinline them ? */
symbol_value_i(Symbol s,gcv_object_t * thrsyms)10211 static inline gcv_object_t *symbol_value_i(Symbol s, gcv_object_t *thrsyms) {
10212 return (s->tls_index && !eq(SYMVALUE_EMPTY,thrsyms[s->tls_index]) ?
10213 thrsyms+s->tls_index : &s->symvalue);
10214 }
symbol_value_h(Symbol s,gcv_object_t * thrsyms)10215 static inline gcv_object_t *symbol_value_h(Symbol s, gcv_object_t *thrsyms) {
10216 return (s->tls_index ? thrsyms+s->tls_index : &s->symvalue);
10217 }
symbol_value_b(Symbol s,gcv_object_t * thrsyms)10218 static inline object symbol_value_b(Symbol s, gcv_object_t *thrsyms) {
10219 return (s->tls_index ? (object)thrsyms[s->tls_index] : SYMVALUE_EMPTY);
10220 }
10221 #define Symbol_value(sym) \
10222 *(symbol_value_i(TheSymbol(sym),current_thread()->_ptr_symvalues))
10223 #define Symbol_thread_value(sym) \
10224 *(symbol_value_h(TheSymbol(sym),current_thread()->_ptr_symvalues))
10225 #define Symbol_thread_binding(sym) \
10226 symbol_value_b(TheSymbol(sym),current_thread()->_ptr_symvalues)
10227 #define Symbolflagged_value(sym) \
10228 *(symbol_value_h(TheSymbolflagged(sym),current_thread()->_ptr_symvalues))
10229 #else
10230 #define Symbol_value(sym) (TheSymbol(sym)->symvalue)
10231 #define Symbol_thread_value(sym) Symbol_value(sym)
10232 #define Symbol_thread_binding(sym) Symbol_value(sym)
10233 #define Symbolflagged_value(sym) (TheSymbolflagged(sym)->symvalue)
10234 #endif
10235 %% #if defined(MULTITHREAD)
10236 %% export_def(SYMVALUE_EMPTY);
10237 %% export_def(SYMBOL_TLS_INDEX_NONE);
10238 %% puts("static inline gcv_object_t *symbol_value_i(Symbol s, gcv_object_t *thrsyms) {");
10239 %% puts("return (s->tls_index && !eq(SYMVALUE_EMPTY,thrsyms[s->tls_index]) ?");
10240 %% puts("thrsyms+s->tls_index : &s->symvalue);}");
10241 %% puts("static inline gcv_object_t *symbol_value_h(Symbol s, gcv_object_t *thrsyms) {");
10242 %% puts(" return (s->tls_index ? thrsyms+s->tls_index : &s->symvalue);}");
10243 %% #endif
10244 %% export_def(Symbol_value(obj));
10245
10246 /* Test for NIL */
10247 #define nullp(obj) (eq(obj,NIL))
10248 %% export_def(nullp(obj));
10249
10250 /* Shorthand: Test a fixed symbol's value for NIL */
10251 #define nullpSv(sym) ( nullp(Symbol_value(S(sym))))
10252
10253 /* Test for an argument's value, whether the argument was provided. */
10254 #define boundp(obj) (!eq(obj,unbound))
10255 %% export_def(boundp(obj));
10256
10257 /* Test for an argument's value, whether the argument was not provided or NIL. */
10258 #define missingp(obj) (!boundp(obj) || nullp(obj))
10259 %% export_def(missingp(obj));
10260
10261 /* Test for Cons */
10262 #ifdef TYPECODES
10263 #if defined(cons_bit_o)
10264 /* define consp(obj) (as_oint(obj) & wbit(cons_bit_o)) */
10265 #define consp(obj) (wbit_test(as_oint(obj),cons_bit_o))
10266 #ifdef fast_mtypecode
10267 #ifdef WIDE_STRUCT
10268 #undef consp
10269 #define consp(obj) (typecode(obj) & bit(cons_bit_t))
10270 #endif
10271 #define mconsp(obj) (mtypecode(obj) & bit(cons_bit_t))
10272 #else
10273 #define mconsp(obj) consp(obj)
10274 #endif
10275 #else
10276 #define consp(obj) (typecode(obj) == cons_type)
10277 #define mconsp(obj) (mtypecode(obj) == cons_type)
10278 #endif
10279 #else
10280 #define consp(obj) ((as_oint(obj) & 7) == (cons_bias+conses_misaligned))
10281 #define mconsp(obj) consp(obj)
10282 #endif
10283 %% export_def(consp(obj));
10284 %% export_def(mconsp(obj));
10285
10286 /* Test for Atom */
10287 #ifdef TYPECODES
10288 #if defined(cons_bit_o)
10289 /* define atomp(obj) ((as_oint(obj) & wbit(cons_bit_o))==0) */
10290 #define atomp(obj) (!wbit_test(as_oint(obj),cons_bit_o))
10291 #ifdef fast_mtypecode
10292 #ifdef WIDE_STRUCT
10293 #undef atomp
10294 #define atomp(obj) ((typecode(obj) & bit(cons_bit_t))==0)
10295 #endif
10296 #define matomp(obj) ((mtypecode(obj) & bit(cons_bit_t))==0)
10297 #else
10298 #define matomp(obj) atomp(obj)
10299 #endif
10300 #else
10301 #define atomp(obj) (!(typecode(obj) == cons_type))
10302 #define matomp(obj) (!(mtypecode(obj) == cons_type))
10303 #endif
10304 #else
10305 #define atomp(obj) (!consp(obj))
10306 #define matomp(obj) atomp(obj)
10307 #endif
10308 %% export_def(atomp(obj));
10309 %% export_def(matomp(obj));
10310
10311 /* For all type tests below this line, the argument must be side-effect-free.
10312 Ideally a variable, but a STACK_(n) reference works as well. */
10313
10314 /* Test for List */
10315 #define listp(obj) (nullp(obj) || consp(obj))
10316 %% export_def(listp(obj));
10317
10318 #ifndef TYPECODES
10319 /* Test for Object with variable length */
10320 #define varobjectp(obj) ((as_oint(obj) & nonimmediate_heapcode_mask) == (varobject_bias+varobjects_misaligned))
10321 #endif
10322 %% #ifndef TYPECODES
10323 %% export_def(varobjectp(obj));
10324 %% #endif
10325
10326 /* Test for Symbol */
10327 #ifdef TYPECODES
10328 #define symbolp(obj) (typecode(obj) == symbol_type)
10329 #else
10330 #define symbolp(obj) \
10331 (varobjectp(obj) && (Record_type(obj) == Rectype_Symbol))
10332 #endif
10333 %% export_def(symbolp(obj));
10334
10335 /* Test for number */
10336 #ifdef TYPECODES
10337 /* define numberp(obj) (as_oint(obj) & wbit(number_bit_o)) */
10338 #define numberp(obj) (wbit_test(as_oint(obj),number_bit_o))
10339 #ifdef WIDE_STRUCT
10340 #undef numberp
10341 #define numberp(obj) (typecode(obj) & bit(number_bit_t))
10342 #endif
10343 #else
10344 #define immediate_number_p(obj) \
10345 ((as_oint(obj) & ((4 << imm_type_shift) | immediate_bias_mask)) == (fixnum_type&sfloat_type))
10346 #define numberp(obj) \
10347 (immediate_number_p(obj) \
10348 || (varobjectp(obj) \
10349 && ((uintB)(Record_type(obj)-Rectype_Bignum) <= Rectype_Complex-Rectype_Bignum)))
10350 #endif
10351 %% #if notused
10352 %% #ifdef TYPECODES
10353 %% export_def(numberp(obj));
10354 %% #else
10355 %% export_def(immediate_number_p(obj));
10356 %% #endif
10357 %% #endif
10358
10359 /* Test for Vector (typebytes %001,%010,%011,%101,%110,%111) */
10360 #ifdef TYPECODES
10361 #define vectorp(obj) \
10362 ((tint)(typecode(obj) - sbvector_type) <= (tint)(vector_type - sbvector_type))
10363 #else
10364 /* cases: Rectype_Sbvector, Rectype_Sb[2|4|8|16|32]vector, Rectype_Svector, Rectype_[Imm_]S[8|16|32]string,
10365 Rectype_bvector, Rectype_b[2|4|8|16|32]vector, Rectype_vector, Rectype_reallocstring, Rectype_string */
10366 #define vectorp(obj) \
10367 (varobjectp(obj) && ((uintB)(Record_type(obj) - Rectype_vector) \
10368 <= Rectype_string - Rectype_vector))
10369 #endif
10370 %% export_def(vectorp(obj));
10371
10372 /* Test for simple-vector or simple-bit-vector or simple-string */
10373 #ifdef TYPECODES
10374 #define simplep(obj) \
10375 ((tint)(typecode(obj) - sbvector_type) <= (tint)(svector_type - sbvector_type))
10376 #else
10377 /* cases: Rectype_Sbvector, Rectype_Sb[2|4|8|16|32]vector, Rectype_Svector, Rectype_[Imm_]S[8|16|32]string,
10378 Rectype_reallocstring */
10379 #define simplep(obj) \
10380 (varobjectp(obj) && ((uintB)(Record_type(obj) - Rectype_Svector) \
10381 <= Rectype_reallocstring - Rectype_Svector))
10382 #endif
10383
10384 /* Tests an Array for simple-vector or simple-bit-vector or simple-string */
10385 #ifdef TYPECODES
10386 #define array_simplep(obj) \
10387 ((typecode(obj) & bit(notsimple_bit_t)) == 0)
10388 #else
10389 /* cases: Rectype_Sbvector, Rectype_Sb[2|4|8|16|32]vector, Rectype_Svector, Rectype_[Imm_]S[8|16|32]string,
10390 Rectype_reallocstring */
10391 #define array_simplep(obj) \
10392 ((uintB)(Record_type(obj) - Rectype_Svector) \
10393 <= Rectype_reallocstring - Rectype_Svector)
10394 #endif
10395
10396 /* Test for simple-vector */
10397 #ifdef TYPECODES
10398 #define simple_vector_p(obj) \
10399 (typecode(obj) == svector_type)
10400 #else
10401 /* cases: Rectype_Svector */
10402 #define simple_vector_p(obj) \
10403 (varobjectp(obj) && (Record_type(obj) == Rectype_Svector))
10404 #endif
10405 %% export_def(simple_vector_p(obj));
10406
10407 /* Test for general-vector=(vector t) */
10408 #ifdef TYPECODES
10409 #define general_vector_p(obj) \
10410 ((typecode(obj) & ~bit(notsimple_bit_t)) == svector_type)
10411 #else
10412 /* cases: Rectype_Svector, Rectype_vector */
10413 #define general_vector_p(obj) \
10414 (varobjectp(obj) \
10415 && ((Record_type(obj) & ~(Rectype_Svector ^ Rectype_vector)) == (Rectype_Svector & Rectype_vector)) \
10416 )
10417 #endif
10418 %% export_def(general_vector_p(obj));
10419
10420 /* Test for simple-string */
10421 #ifdef TYPECODES
10422 #define simple_string_p(obj) \
10423 (typecode(obj) == sstring_type)
10424 #else
10425 /* cases: Rectype_[Imm_]S[8|16|32]string, Rectype_reallocstring */
10426 #define simple_string_p(obj) \
10427 (varobjectp(obj) && ((uintB)(Record_type(obj) - Rectype_S8string) \
10428 <= Rectype_reallocstring - Rectype_S8string))
10429 #endif
10430 %% export_def(simple_string_p(obj));
10431
10432 /* Test for string */
10433 #ifdef TYPECODES
10434 #define stringp(obj) \
10435 ((typecode(obj) & ~bit(notsimple_bit_t)) == sstring_type)
10436 #else
10437 /* cases: Rectype_[Imm_]S[8|16|32]string, Rectype_reallocstring, Rectype_string */
10438 #define stringp(obj) \
10439 (varobjectp(obj) && ((uintB)(Record_type(obj) - Rectype_S8string) \
10440 <= Rectype_string - Rectype_S8string))
10441 #endif
10442 %% export_def(stringp(obj));
10443
10444 /* test for (VECTOR NIL) */
10445 #ifdef TYPECODES
10446 #define nil_vector_p(obj) \
10447 (typecode(obj) == vector_type \
10448 && (Iarray_flags(obj) & arrayflags_atype_mask) == Atype_NIL \
10449 )
10450 #else
10451 /* cases: Rectype_Svector, Rectype_vector */
10452 #define nil_vector_p(obj) \
10453 (varobjectp(obj) \
10454 && (Record_type(obj) == Rectype_vector \
10455 && (Iarray_flags(obj) & arrayflags_atype_mask) == Atype_NIL \
10456 ) )
10457 #endif
10458
10459 /* Test for simple-bit[n]-vector */
10460 #ifdef TYPECODES
10461 #define simple_bit_vector_p(atype,obj) \
10462 (typecode(obj) == Array_type_simple_bit_vector(atype))
10463 #else
10464 /* cases: Rectype_Sb[2^n]vector */
10465 #define simple_bit_vector_p(atype,obj) \
10466 (varobjectp(obj) && (Record_type(obj) == Rectype_Sbvector+(atype)))
10467 #endif
10468 %% export_def(simple_bit_vector_p(atype,obj));
10469
10470 /* Test for bit[n]-vector */
10471 #ifdef TYPECODES
10472 #define bit_vector_p(atype,obj) \
10473 ((typecode(obj) & ~bit(notsimple_bit_t)) == Array_type_simple_bit_vector(atype))
10474 #else
10475 /* cases: Rectype_Sb[2^n]vector, Rectype_b[2^n]vector */
10476 #define bit_vector_p(atype,obj) \
10477 (varobjectp(obj) \
10478 && ((Record_type(obj) & ~(Rectype_Sbvector ^ Rectype_bvector)) == (Rectype_Sbvector & Rectype_bvector) + (atype)) \
10479 )
10480 #endif
10481 %% export_def(bit_vector_p(atype,obj));
10482
10483 /* Test for Array (general) */
10484 #ifdef TYPECODES
10485 #define arrayp(obj) \
10486 ((tint)(typecode(obj) - mdarray_type) <= (tint)(vector_type - mdarray_type))
10487 #else
10488 /* cases: Rectype_Sbvector, Rectype_Sb[2|4|8|16|32]vector, Rectype_Svector, Rectype_[Imm_]S[8|16|32]string,
10489 Rectype_bvector, Rectype_b[2|4|8|16|32]vector, Rectype_vector, Rectype_reallocstring, Rectype_string,
10490 Rectype_mdarray */
10491 #define arrayp(obj) \
10492 (varobjectp(obj) && ((uintB)(Record_type(obj) - Rectype_vector) \
10493 <= Rectype_mdarray - Rectype_vector))
10494 #endif
10495 %% export_def(arrayp(obj));
10496
10497 /* Test for Array, that isn't a Vector (type byte %100) */
10498 #ifdef TYPECODES
10499 #define mdarrayp(obj) \
10500 (typecode(obj) == mdarray_type)
10501 #else
10502 /* cases: Rectype_mdarray */
10503 #define mdarrayp(obj) \
10504 (varobjectp(obj) && (Record_type(obj) == Rectype_mdarray))
10505 #endif
10506
10507 #ifdef TYPECODES
10508 /* Test for Closure/Structure/Stream/Instance/OtherRecord/LongRecord */
10509 #define if_recordp(obj,statement1,statement2) \
10510 switch (typecode(obj)) { \
10511 case_record: statement1; break; \
10512 default: statement2; break; \
10513 }
10514 #else
10515 /* Test for Lrecord/Srecord/Xrecord */
10516 #define if_recordp(obj,statement1,statement2) \
10517 if (orecordp(obj)) \
10518 switch (Record_type(obj)) { \
10519 case Rectype_Sbvector: \
10520 case Rectype_S8string: case Rectype_Imm_S8string: \
10521 case Rectype_S16string: case Rectype_Imm_S16string: \
10522 case Rectype_S32string: case Rectype_Imm_S32string: \
10523 case Rectype_Svector: \
10524 case Rectype_mdarray: \
10525 case Rectype_bvector: case Rectype_string: case Rectype_vector: \
10526 case Rectype_reallocstring: \
10527 case Rectype_Bignum: case Rectype_Lfloat: \
10528 goto not_record; \
10529 default: { statement1 } break; \
10530 } \
10531 else \
10532 not_record: { statement2 }
10533 #endif
10534
10535 /* Test for Closure */
10536 #ifdef TYPECODES
10537 #define closurep(obj) (typecode(obj)==closure_type)
10538 #else
10539 #define closurep(obj) \
10540 (varobjectp(obj) && (Record_type(obj) == Rectype_Closure))
10541 #endif
10542
10543 /* Test for compiled Closure
10544 The second component of a closure is either a list
10545 (the Lambdabody for interpreted Closures)
10546 or a Simple-Bit-Vector (the code vector for compiled Closures). */
10547 #define cclosurep(obj) \
10548 (closurep(obj) \
10549 && simple_bit_vector_p(Atype_8Bit,TheClosure(obj)->clos_codevec))
10550
10551 /* Test for a function with a code vector produced by %GENERIC-FUNCTION-LAMBDA. */
10552 #define genericlambda_function_p(obj) \
10553 (cclosurep(obj) \
10554 && (TheCodevec(TheClosure(obj)->clos_codevec)->ccv_flags & bit(4)))
10555
10556 /* Test for CLOS-Instance */
10557 #ifdef TYPECODES
10558 #define instancep(obj) \
10559 (typecode(obj)==instance_type \
10560 || (typecode(obj)==closure_type && Closure_instancep(obj)))
10561 #else
10562 #define instancep(obj) \
10563 (varobjectp(obj) \
10564 && (Record_type(obj) == Rectype_Instance \
10565 || (Record_type(obj) == Rectype_Closure && Closure_instancep(obj))))
10566 #endif
10567 /* Test for non-funcallable CLOS-Instance */
10568 #ifdef TYPECODES
10569 #define regular_instance_p(obj) (typecode(obj)==instance_type)
10570 #else
10571 #define regular_instance_p(obj) \
10572 (varobjectp(obj) && (Record_type(obj) == Rectype_Instance))
10573 #endif
10574 /* Test for funcallable CLOS-Instance */
10575 #define funcallable_instance_p(obj) \
10576 (closurep(obj) && Closure_instancep(obj))
10577 %% export_def(instancep(obj));
10578
10579 /* Test for CLOS-class or forward-reference.
10580 Our CLOS implements all classes as instances of a
10581 (not necessarily direct) subclass of <class>. */
10582 #define if_potential_class_p(obj,statement1,statement2) \
10583 if (instancep(obj)) { \
10584 { \
10585 var object obj_forwarded = obj; \
10586 instance_un_realloc(obj_forwarded); \
10587 /*instance_update(obj,obj_forwarded); - not needed since we don't access a slot */ \
10588 {var object cv = TheInstance(obj_forwarded)->inst_class_version; \
10589 /* Treat the most frequent cases first, for speed. */ \
10590 if (eq(cv,O(class_version_standard_class))) /* direct instance of STANDARD-CLASS? */\
10591 goto obj##_classp_yes; \
10592 if (eq(cv,O(class_version_structure_class))) /* direct instance of STRUCTURE-CLASS? */\
10593 goto obj##_classp_yes; \
10594 if (eq(cv,O(class_version_built_in_class))) /* direct instance of BUILT-IN-CLASS? */\
10595 goto obj##_classp_yes; \
10596 /* Now a slow, but general instanceof test. */ \
10597 {var object objclas = TheClassVersion(cv)->cv_newest_class; \
10598 if (eq(gethash(O(class_potential_class),TheClass(objclas)->all_superclasses,false),nullobj)) \
10599 goto obj##_classp_no; \
10600 }}} \
10601 obj##_classp_yes: statement1; \
10602 } else { \
10603 obj##_classp_no: statement2; \
10604 }
10605
10606 /* Test for CLOS-class.
10607 Our CLOS implements all classes as instances of a
10608 (not necessarily direct) subclass of <defined-class>. */
10609 #define if_defined_class_p(obj,statement1,statement2) \
10610 if (instancep(obj)) { \
10611 { \
10612 var object obj_forwarded = obj; \
10613 instance_un_realloc(obj_forwarded); \
10614 /*instance_update(obj,obj_forwarded); - not needed since we don't access a slot */ \
10615 {var object cv = TheInstance(obj_forwarded)->inst_class_version; \
10616 /* Treat the most frequent cases first, for speed. */ \
10617 if (eq(cv,O(class_version_standard_class))) /* direct instance of STANDARD-CLASS? */\
10618 goto obj##_classp_yes; \
10619 if (eq(cv,O(class_version_structure_class))) /* direct instance of STRUCTURE-CLASS? */\
10620 goto obj##_classp_yes; \
10621 if (eq(cv,O(class_version_built_in_class))) /* direct instance of BUILT-IN-CLASS? */\
10622 goto obj##_classp_yes; \
10623 /* Now a slow, but general instanceof test. */ \
10624 {var object objclas = TheClassVersion(cv)->cv_newest_class; \
10625 if (eq(gethash(O(class_defined_class),TheClass(objclas)->all_superclasses,false),nullobj)) \
10626 goto obj##_classp_no; \
10627 }}} \
10628 obj##_classp_yes: statement1; \
10629 } else { \
10630 obj##_classp_no: statement2; \
10631 }
10632
10633 /* Test for Other-Record
10634 This is not really a type test (because there is no well-defined type
10635 Other-Record). It's just a precondition for calling Record_type(obj). */
10636 #ifdef TYPECODES
10637 #define orecordp(obj) (typecode(obj)==orecord_type)
10638 #else
10639 #define orecordp(obj) varobjectp(obj)
10640 #endif
10641 %% export_def(orecordp(obj));
10642
10643 /* Test for Long-Record
10644 This is not really a type test (because there is no well-defined type
10645 Long-Record). It's just a precondition for calling Record_type(obj). */
10646 #ifdef TYPECODES
10647 #define lrecordp(obj) (typecode(obj)==lrecord_type)
10648 #else
10649 #define lrecordp(obj) varobjectp(obj)
10650 #endif
10651
10652 /* Test for Structure */
10653 #ifdef case_structure
10654 #define structurep(obj) (typecode(obj)==structure_type)
10655 #else
10656 #define structurep(obj) \
10657 (orecordp(obj) && (Record_type(obj) == Rectype_Structure))
10658 #endif
10659 %% export_def(structurep(obj));
10660
10661 /* Test for Builtin-Stream */
10662 #ifdef case_stream
10663 #define builtin_stream_p(obj) (typecode(obj)==stream_type)
10664 #else
10665 #define builtin_stream_p(obj) \
10666 (orecordp(obj) && (Record_type(obj) == Rectype_Stream))
10667 #endif
10668 /* %% export_def(builtin_stream_p(obj)); */
10669
10670 /* Test for Stream */
10671 #define streamp(obj) \
10672 (builtin_stream_p(obj) || instanceof(obj,O(class_fundamental_stream)))
10673
10674 /* Test for Package */
10675 #define packagep(obj) \
10676 (orecordp(obj) && (Record_type(obj) == Rectype_Package))
10677 %% #if notused
10678 %% export_def(packagep(obj));
10679 %% #endif
10680
10681 /* Test for Hash-Table */
10682 #define hash_table_p(obj) \
10683 (orecordp(obj) && (Record_type(obj) == Rectype_Hashtable))
10684
10685 /* Test for Readtable */
10686 #define readtablep(obj) \
10687 (orecordp(obj) && (Record_type(obj) == Rectype_Readtable))
10688
10689 /* Test for Pathname */
10690 #define pathnamep(obj) \
10691 (orecordp(obj) && (Record_type(obj) == Rectype_Pathname))
10692
10693 /* Test for Logical Pathname */
10694 #define logpathnamep(obj) \
10695 (orecordp(obj) && (Record_type(obj) == Rectype_Logpathname))
10696
10697 /* Test for Extended Pathname (i.e., Pathname or Logical Pathname)
10698 define xpathnamep(obj) (pathnamep(obj) || logpathnamep(obj)) */
10699 #define xpathnamep(obj) \
10700 (orecordp(obj) \
10701 && ((Record_type(obj) == Rectype_Pathname) \
10702 || (Record_type(obj) == Rectype_Logpathname)))
10703
10704 /* Test for Random-State */
10705 #define random_state_p(obj) \
10706 (orecordp(obj) && (Record_type(obj) == Rectype_Random_State))
10707
10708 /* Test for Byte */
10709 #define bytep(obj) \
10710 (orecordp(obj) && (Record_type(obj) == Rectype_Byte))
10711
10712 /* Test for Fsubr */
10713 #define fsubrp(obj) \
10714 (orecordp(obj) && (Record_type(obj) == Rectype_Fsubr))
10715
10716 /* Test for Loadtimeeval */
10717 #define loadtimeevalp(obj) \
10718 (orecordp(obj) && (Record_type(obj) == Rectype_Loadtimeeval))
10719
10720 /* Test for Symbolmacro */
10721 #define symbolmacrop(obj) \
10722 (orecordp(obj) && (Record_type(obj) == Rectype_Symbolmacro))
10723
10724 /* Test for GlobalSymbolmacro */
10725 #define globalsymbolmacrop(obj) \
10726 (orecordp(obj) && (Record_type(obj) == Rectype_GlobalSymbolmacro))
10727
10728 /* Test for Macro */
10729 #define macrop(obj) \
10730 (orecordp(obj) && (Record_type(obj) == Rectype_Macro))
10731
10732 /* Test for FunctionMacro */
10733 #define functionmacrop(obj) \
10734 (orecordp(obj) && (Record_type(obj) == Rectype_FunctionMacro))
10735
10736 /* Test for BigReadLabel */
10737 #define big_read_label_p(obj) \
10738 (orecordp(obj) && (Record_type(obj) == Rectype_BigReadLabel))
10739
10740 /* Test for Encoding */
10741 #define encodingp(obj) \
10742 (orecordp(obj) && (Record_type(obj) == Rectype_Encoding))
10743
10744 /* Test for Fpointer */
10745 #define fpointerp(obj) \
10746 (orecordp(obj) && (Record_type(obj) == Rectype_Fpointer))
10747 %% #ifdef FOREIGN
10748 %% export_def(fpointerp(obj));
10749 %% #endif
10750
10751 /* Test for Faddress */
10752 #define faddressp(obj) \
10753 (orecordp(obj) && (Record_type(obj) == Rectype_Faddress))
10754
10755 /* Test for Fvariable */
10756 #define fvariablep(obj) \
10757 (orecordp(obj) && (Record_type(obj) == Rectype_Fvariable))
10758
10759 /* Test for Ffunction */
10760 #ifdef DYNAMIC_FFI
10761 #define ffunctionp(obj) \
10762 (orecordp(obj) && (Record_type(obj) == Rectype_Ffunction))
10763 #else
10764 #define ffunctionp(obj) ((void)(obj), 0)
10765 #endif
10766
10767 /* Test for Function */
10768 #define functionp(obj) (subrp(obj) || closurep(obj) || ffunctionp(obj))
10769
10770 /* Test for Weakpointer */
10771 #define weakpointerp(obj) \
10772 (orecordp(obj) && (Record_type(obj) == Rectype_Weakpointer))
10773
10774 /* test for socket-server and for socket-stream */
10775 #ifdef SOCKET_STREAMS
10776 #define socket_server_p(obj) \
10777 (orecordp(obj) && (Record_type(obj) == Rectype_Socket_Server))
10778 #define socket_stream_p(obj) \
10779 (builtin_stream_p(obj) && (TheStream(obj)->strmtype==strmtype_socket))
10780 #endif
10781
10782 #if defined(MULTITHREAD)
10783 #define threadp(obj) \
10784 (orecordp(obj) && (Record_type(obj) == Rectype_Thread))
10785 #define mutexp(obj) \
10786 (orecordp(obj) && (Record_type(obj) == Rectype_Mutex))
10787 #define exemptionp(obj) \
10788 (orecordp(obj) && (Record_type(obj) == Rectype_Exemption))
10789
10790 #endif
10791
10792 #ifdef YET_ANOTHER_RECORD
10793 /* Test for Yetanother */
10794 #define yetanotherp(obj) \
10795 (orecordp(obj) && (Record_type(obj) == Rectype_Yetanother))
10796 #endif
10797
10798 /* Test for Character */
10799 #ifdef TYPECODES
10800 #define charp(obj) (typecode(obj)==char_type)
10801 #else
10802 #define charp(obj) ((as_oint(obj) & ((7 << imm_type_shift) | immediate_bias_mask)) == char_type)
10803 #endif
10804 %% export_def(charp(obj));
10805
10806 #if (base_char_code_limit < char_code_limit)
10807 /* Test for base character */
10808 #define base_char_p(obj) \
10809 ((as_oint(obj) & ~((oint)(bit(base_char_int_len)-1)<<oint_data_shift)) == type_zero_oint(char_type))
10810 #endif
10811
10812 /* Test for SUBR (compiled functional object) */
10813 #ifdef TYPECODES
10814 #define subrp(obj) (typecode(obj)==subr_type)
10815 #else
10816 #ifdef ONE_FREE_BIT_HEAPCODES
10817 #define subrp(obj) ((as_oint(obj) & 3) == subr_bias)
10818 #define immsubrp(obj) subrp(obj)
10819 #endif
10820 #if defined(KERNELVOID32_HEAPCODES) || defined(GENERIC64_HEAPCODES)
10821 #define subrp(obj) (orecordp(obj) && (Record_type(obj) == Rectype_Subr))
10822 #define immsubrp(obj) false
10823 #ifdef DEBUG_GCSAFETY
10824 /* This is used by pgci_pointable, so it cannot use pgci_pointable itself. */
nonimmsubrp(object obj)10825 static inline bool nonimmsubrp (object obj) {
10826 return (varobjectp(obj)
10827 && (inside_gc /* Avoid doing memory accesses during GC. */
10828 || (varobject_type((Record)(cgci_pointable(obj)-varobject_bias)) == Rectype_Subr)));
10829 }
10830 #endif
10831 #endif
10832 #endif
10833 %% #ifndef TYPECODES
10834 %% #if defined(KERNELVOID32_HEAPCODES) || defined(GENERIC64_HEAPCODES)
10835 %% #ifdef DEBUG_GCSAFETY
10836 %% printf2("static inline bool nonimmsubrp (object obj) { return (varobjectp(obj) && (varobject_type((Record)(cgci_pointable(obj)-%d)) == %d)); }\n",varobject_bias,Rectype_Subr);
10837 %% #endif
10838 %% #endif
10839 %% #endif
10840
10841 /* Test for pointer into the STACK (usually at a frame) */
10842 #ifdef TYPECODES
10843 #define framepointerp(obj) (typecode(obj)==system_type) /* other cases?? */
10844 #else /* HEAPCODES */
10845 #if defined(GENERIC64C_HEAPCODES)
10846 #define framepointerp(obj) ((as_oint(obj) & 7) == machine_bias) /* other cases?? */
10847 #else
10848 #define framepointerp(obj) ((as_oint(obj) & 3) == machine_bias) /* other cases?? */
10849 #endif
10850 #endif
10851
10852 #ifndef TYPECODES
10853
10854 /* Test for Machine-Pointer */
10855 #ifdef ONE_FREE_BIT_HEAPCODES
10856 #define machinep(obj) ((as_oint(obj) & 3) == machine_bias)
10857 #endif
10858 #ifdef KERNELVOID32A_HEAPCODES
10859 #define machinep(obj) \
10860 ((as_oint(obj) & 3) == machine_bias \
10861 && (as_oint(obj) & 0xE0000000) != 0xC0000000)
10862 #endif
10863 #ifdef KERNELVOID32B_HEAPCODES
10864 #define machinep(obj) \
10865 ((as_oint(obj) & 3) == machine_bias \
10866 && (0xE0000000 & ~as_oint(obj)) != 0)
10867 #endif
10868 #if defined(GENERIC64A_HEAPCODES) || defined(GENERIC64B_HEAPCODES)
10869 #define machinep(obj) \
10870 ((as_oint(obj) & 3) == machine_bias \
10871 && (as_oint(obj) & 0xE000000000000000UL) != 0xC000000000000000UL)
10872 #endif
10873 #ifdef GENERIC64C_HEAPCODES
10874 #define machinep(obj) ((as_oint(obj) & 7) == machine_bias)
10875 #endif
10876
10877 /* Test for Small-Read-Label */
10878 #define small_read_label_p(obj) ((as_oint(obj) & ((7 << imm_type_shift) | immediate_bias_mask)) == small_read_label_type)
10879
10880 /* Test for System-Pointer */
10881 #define systemp(obj) ((as_oint(obj) & ((7 << imm_type_shift) | immediate_bias_mask)) == system_type)
10882
10883 #endif
10884
10885 /* Test for real number */
10886 #ifdef TYPECODES
10887 #define if_realp(obj,statement1,statement2) \
10888 do { \
10889 var object obj_from_if_realp = (obj); \
10890 var tint type_from_if_realp = typecode(obj_from_if_realp); \
10891 if ( (type_from_if_realp & bit(number_bit_t)) \
10892 && !(type_from_if_realp==complex_type) ) \
10893 { statement1 } else { statement2 } \
10894 } while(0)
10895 #else
10896 #define if_realp(obj,statement1,statement2) \
10897 do { if (((as_oint(obj) & ((4 << imm_type_shift) | immediate_bias_mask)) \
10898 == fixnum_type) \
10899 || (varobjectp(obj) \
10900 && ((uintB)(Record_type(obj)-Rectype_Bignum) <= \
10901 Rectype_Ratio-Rectype_Bignum))) \
10902 { statement1 } else { statement2 } \
10903 } while(0)
10904 #endif
10905
10906 /* Test for rational number */
10907 #ifdef TYPECODES
10908 #define if_rationalp(obj,statement1,statement2) \
10909 do { \
10910 var object obj_from_if_rationalp = (obj); \
10911 var tint type_from_if_rationalp = typecode(obj_from_if_rationalp); \
10912 if ((type_from_if_rationalp != complex_type) \
10913 && ((type_from_if_rationalp & \
10914 ~((fixnum_type|bignum_type|ratio_type|bit(sign_bit_t)) \
10915 & ~(fixnum_type&bignum_type&ratio_type))) \
10916 == (fixnum_type&bignum_type&ratio_type))) \
10917 { statement1 } else { statement2 } \
10918 } while(0)
10919 #else
10920 #define if_rationalp(obj,statement1,statement2) \
10921 do { if (((as_oint(obj) & ((6 << imm_type_shift) | immediate_bias_mask)) \
10922 == fixnum_type) \
10923 || (varobjectp(obj) \
10924 && ((Record_type(obj) == Rectype_Bignum) \
10925 || (Record_type(obj) == Rectype_Ratio)))) \
10926 { statement1 } else { statement2 } \
10927 } while(0)
10928
10929 #endif
10930
10931 /* Test for Integer */
10932 #ifdef TYPECODES
10933 #define integerp(obj) \
10934 ((typecode(obj) & \
10935 ~((fixnum_type|bignum_type|bit(sign_bit_t)) & ~(fixnum_type&bignum_type)) \
10936 ) == (fixnum_type&bignum_type))
10937 #else
10938 #define integerp(obj) \
10939 (((as_oint(obj) & ((6 << imm_type_shift) | immediate_bias_mask)) == fixnum_type) \
10940 || (varobjectp(obj) && (Record_type(obj) == Rectype_Bignum)))
10941 #endif
10942 %% export_def(integerp(obj));
10943
10944 /* Test for Fixnum */
10945 #ifdef TYPECODES
10946 #define fixnump(obj) ((typecode(obj) & ~bit(sign_bit_t)) == fixnum_type)
10947 #else
10948 #define fixnump(obj) ((as_oint(obj) & ((6 << imm_type_shift) | immediate_bias_mask)) == fixnum_type)
10949 #endif
10950 %% export_def(fixnump(obj));
10951
10952 /* Test for Fixnum >=0 */
10953 #ifdef TYPECODES
10954 #define posfixnump(obj) (typecode(obj) == fixnum_type)
10955 #else
10956 #define posfixnump(obj) ((as_oint(obj) & ((7 << imm_type_shift) | immediate_bias_mask)) == fixnum_type)
10957 #endif
10958 %% export_def(posfixnump(obj));
10959
10960 /* Test for Bignum */
10961 #ifdef TYPECODES
10962 #define bignump(obj) ((typecode(obj) & ~bit(sign_bit_t)) == bignum_type)
10963 #else
10964 #define bignump(obj) \
10965 (varobjectp(obj) && (Record_type(obj) == Rectype_Bignum))
10966 #endif
10967 %% export_def(bignump(obj));
10968
10969 /* Test for Bignum >=0 */
10970 #ifdef TYPECODES
10971 #define posbignump(obj) (typecode(obj) == bignum_type)
10972 #else
10973 #define posbignump(obj) \
10974 (varobjectp(obj) \
10975 && (Record_type(obj) == Rectype_Bignum) \
10976 && ((Record_flags(obj) & bit(7)) == 0))
10977 #endif
10978 %% export_def(posbignump(obj));
10979
10980 /* Test for Ratio */
10981 #ifdef TYPECODES
10982 #define ratiop(obj) ((typecode(obj) & ~bit(sign_bit_t)) == ratio_type)
10983 #else
10984 #define ratiop(obj) (varobjectp(obj) && (Record_type(obj) == Rectype_Ratio))
10985 #endif
10986 %% #if notused
10987 %% export_def(ratiop(obj));
10988 %% #endif
10989
10990 /* Test for Float */
10991 #ifdef TYPECODES
10992 #define floatp(obj) \
10993 ((typecode(obj) & \
10994 ~((sfloat_type|ffloat_type|dfloat_type|lfloat_type|bit(sign_bit_t)) & ~(sfloat_type&ffloat_type&dfloat_type&lfloat_type)) \
10995 ) == (sfloat_type&ffloat_type&dfloat_type&lfloat_type))
10996 #else
10997 #define floatp(obj) \
10998 (((as_oint(obj) & ((6 << imm_type_shift) | immediate_bias_mask)) == sfloat_type) \
10999 || (varobjectp(obj) \
11000 && ((uintB)(Record_type(obj)-Rectype_Lfloat) <= Rectype_Ffloat-Rectype_Lfloat)))
11001 #endif
11002 %% #if notused
11003 %% export_def(floatp(obj));
11004 %% #endif
11005
11006 /* Test for Short-Float */
11007 #ifdef TYPECODES
11008 #define short_float_p(obj) ((typecode(obj) & ~bit(sign_bit_t)) == sfloat_type)
11009 #else
11010 #define short_float_p(obj) ((as_oint(obj) & ((6 << imm_type_shift) | immediate_bias_mask)) == sfloat_type)
11011 #endif
11012 %% #if notused
11013 %% export_def(short_float_p(obj));
11014 %% #endif
11015
11016 /* Test for Single-Float */
11017 #ifdef TYPECODES
11018 #define single_float_p(obj) ((typecode(obj) & ~bit(sign_bit_t)) == ffloat_type)
11019 #else
11020 #define single_float_p(obj) (varobjectp(obj) && (Record_type(obj) == Rectype_Ffloat))
11021 #endif
11022 %% export_def(single_float_p(obj));
11023
11024 /* Test for Double-Float */
11025 #ifdef TYPECODES
11026 #define double_float_p(obj) ((typecode(obj) & ~bit(sign_bit_t)) == dfloat_type)
11027 #else
11028 #define double_float_p(obj) (varobjectp(obj) && (Record_type(obj) == Rectype_Dfloat))
11029 #endif
11030 %% export_def(double_float_p(obj));
11031
11032 /* Test for Long-Float */
11033 #ifdef TYPECODES
11034 #define long_float_p(obj) ((typecode(obj) & ~bit(sign_bit_t)) == lfloat_type)
11035 #else
11036 #define long_float_p(obj) (varobjectp(obj) && (Record_type(obj) == Rectype_Lfloat))
11037 #endif
11038 %% #if notused
11039 %% export_def(long_float_p(obj));
11040 %% #endif
11041
11042 /* Test for Complex */
11043 #ifdef TYPECODES
11044 #define complexp(obj) (typecode(obj) == complex_type)
11045 #else
11046 #define complexp(obj) (varobjectp(obj) && (Record_type(obj) == Rectype_Complex))
11047 #endif
11048 %% #if notused
11049 %% export_def(complexp(obj));
11050 %% #endif
11051
11052 /* Test if a real number is >=0: */
11053 #ifdef TYPECODES
11054 /* define positivep(obj) ((as_oint(obj) & wbit(sign_bit_o)) == 0) */
11055 #define positivep(obj) (!wbit_test(as_oint(obj),sign_bit_o))
11056 #ifdef WIDE_STRUCT
11057 #undef positivep
11058 #define positivep(obj) ((typecode(obj) & bit(sign_bit_t)) == 0)
11059 #endif
11060 #else
11061 #define positivep(obj) \
11062 (number_immediatep(obj) \
11063 ? /* fixnum, sfloat */ (as_oint(obj) & wbit(sign_bit_o)) == 0 \
11064 : /* bignum, [fdl]float */ (Record_flags(obj) & bit(7)) == 0)
11065 #endif
11066 %% export_def(positivep(obj));
11067
11068
11069 /* switch with typcodes:
11070 example:
11071 switch (typecode(obj)) {
11072 case_symbol: ....
11073 case_orecord:
11074 switch (Record_type(obj)) {
11075 case_Rectype_Symbol_above;
11076 ...
11077 }
11078 } */
11079
11080 #ifdef case_structure
11081 #define case_Rectype_Structure_above
11082 #else
11083 #define case_Rectype_Structure_above \
11084 case Rectype_Structure: goto case_structure;
11085 #endif
11086
11087 #ifdef case_stream
11088 #define case_Rectype_Stream_above
11089 #else
11090 #define case_Rectype_Stream_above \
11091 case Rectype_Stream: goto case_stream;
11092 #endif
11093
11094 #ifdef TYPECODES
11095 #define case_Rectype_Closure_above
11096 #define case_Rectype_Instance_above
11097 #define case_Rectype_Sbvector_above
11098 #define case_Rectype_Sb2vector_above
11099 #define case_Rectype_Sb4vector_above
11100 #define case_Rectype_Sb8vector_above
11101 #define case_Rectype_Sb16vector_above
11102 #define case_Rectype_Sb32vector_above
11103 #define case_Rectype_Sstring_above
11104 #define case_Rectype_Svector_above
11105 #define case_Rectype_mdarray_above
11106 #define case_Rectype_obvector_above
11107 #define case_Rectype_ob2vector_above
11108 #define case_Rectype_ob4vector_above
11109 #define case_Rectype_ob8vector_above
11110 #define case_Rectype_ob16vector_above
11111 #define case_Rectype_ob32vector_above
11112 #define case_Rectype_ostring_above
11113 #define case_Rectype_ovector_above
11114 #define case_Rectype_Bignum_above
11115 #define case_Rectype_Lfloat_above
11116 #define case_Rectype_Dfloat_above
11117 #define case_Rectype_Ffloat_above
11118 #define case_Rectype_Ratio_above
11119 #define case_Rectype_Complex_above
11120 #define case_Rectype_Symbol_above
11121 /* Composite cases: */
11122 #define case_Rectype_string_above
11123 #define case_Rectype_bvector_above
11124 #define case_Rectype_b2vector_above
11125 #define case_Rectype_b4vector_above
11126 #define case_Rectype_b8vector_above
11127 #define case_Rectype_b16vector_above
11128 #define case_Rectype_b32vector_above
11129 #define case_Rectype_vector_above
11130 #define case_Rectype_array_above
11131 #define case_Rectype_number_above
11132 #define case_Rectype_float_above
11133 #define case_Rectype_integer_above
11134 #else
11135 #define case_Rectype_Closure_above \
11136 case Rectype_Closure: goto case_closure;
11137 #define case_Rectype_Instance_above \
11138 case Rectype_Instance: goto case_instance;
11139 #define case_Rectype_Sbvector_above \
11140 case Rectype_Sbvector: goto case_sbvector;
11141 #define case_Rectype_Sb2vector_above \
11142 case Rectype_Sb2vector: goto case_sb2vector;
11143 #define case_Rectype_Sb4vector_above \
11144 case Rectype_Sb4vector: goto case_sb4vector;
11145 #define case_Rectype_Sb8vector_above \
11146 case Rectype_Sb8vector: goto case_sb8vector;
11147 #define case_Rectype_Sb16vector_above \
11148 case Rectype_Sb16vector: goto case_sb16vector;
11149 #define case_Rectype_Sb32vector_above \
11150 case Rectype_Sb32vector: goto case_sb32vector;
11151 #define case_Rectype_Sstring_above \
11152 case Rectype_S8string: case Rectype_Imm_S8string: case Rectype_S16string: case Rectype_Imm_S16string: case Rectype_S32string: case Rectype_Imm_S32string: case Rectype_reallocstring: goto case_sstring;
11153 #define case_Rectype_Svector_above \
11154 case Rectype_Svector: goto case_svector;
11155 #define case_Rectype_mdarray_above \
11156 case Rectype_mdarray: goto case_mdarray;
11157 #define case_Rectype_obvector_above \
11158 case Rectype_bvector: goto case_obvector;
11159 #define case_Rectype_ob2vector_above \
11160 case Rectype_b2vector: goto case_ob2vector;
11161 #define case_Rectype_ob4vector_above \
11162 case Rectype_b4vector: goto case_ob4vector;
11163 #define case_Rectype_ob8vector_above \
11164 case Rectype_b8vector: goto case_ob8vector;
11165 #define case_Rectype_ob16vector_above \
11166 case Rectype_b16vector: goto case_ob16vector;
11167 #define case_Rectype_ob32vector_above \
11168 case Rectype_b32vector: goto case_ob32vector;
11169 #define case_Rectype_ostring_above \
11170 case Rectype_string: goto case_ostring;
11171 #define case_Rectype_ovector_above \
11172 case Rectype_vector: goto case_ovector;
11173 #define case_Rectype_Bignum_above \
11174 case Rectype_Bignum: goto case_bignum;
11175 #define case_Rectype_Lfloat_above \
11176 case Rectype_Lfloat: goto case_lfloat;
11177 #define case_Rectype_Dfloat_above \
11178 case Rectype_Dfloat: goto case_dfloat;
11179 #define case_Rectype_Ffloat_above \
11180 case Rectype_Ffloat: goto case_ffloat;
11181 #define case_Rectype_Ratio_above \
11182 case Rectype_Ratio: goto case_ratio;
11183 #define case_Rectype_Complex_above \
11184 case Rectype_Complex: goto case_complex;
11185 #define case_Rectype_Symbol_above \
11186 case Rectype_Symbol: goto case_symbol;
11187 /* Composite cases: */
11188 #define case_Rectype_string_above \
11189 case Rectype_S8string: case Rectype_Imm_S8string: case Rectype_S16string: case Rectype_Imm_S16string: case Rectype_S32string: case Rectype_Imm_S32string: case Rectype_reallocstring: case Rectype_string: goto case_string;
11190 #define case_Rectype_bvector_above \
11191 case Rectype_Sbvector: case Rectype_bvector: goto case_bvector;
11192 #define case_Rectype_b2vector_above \
11193 case Rectype_Sb2vector: case Rectype_b2vector: goto case_b2vector;
11194 #define case_Rectype_b4vector_above \
11195 case Rectype_Sb4vector: case Rectype_b4vector: goto case_b4vector;
11196 #define case_Rectype_b8vector_above \
11197 case Rectype_Sb8vector: case Rectype_b8vector: goto case_b8vector;
11198 #define case_Rectype_b16vector_above \
11199 case Rectype_Sb16vector: case Rectype_b16vector: goto case_b16vector;
11200 #define case_Rectype_b32vector_above \
11201 case Rectype_Sb32vector: case Rectype_b32vector: goto case_b32vector;
11202 #define case_Rectype_vector_above \
11203 case Rectype_Svector: case Rectype_vector: goto case_vector;
11204 #define case_Rectype_array_above \
11205 case Rectype_S8string: case Rectype_Imm_S8string: \
11206 case Rectype_S16string: case Rectype_Imm_S16string: \
11207 case Rectype_S32string: case Rectype_Imm_S32string: \
11208 case Rectype_reallocstring: case Rectype_string: \
11209 case Rectype_Sbvector: case Rectype_bvector: \
11210 case Rectype_Sb2vector: case Rectype_b2vector: \
11211 case Rectype_Sb4vector: case Rectype_b4vector: \
11212 case Rectype_Sb8vector: case Rectype_b8vector: \
11213 case Rectype_Sb16vector: case Rectype_b16vector: \
11214 case Rectype_Sb32vector: case Rectype_b32vector: \
11215 case Rectype_Svector: case Rectype_vector: \
11216 case Rectype_mdarray: \
11217 goto case_array;
11218 #define case_Rectype_number_above /* don't forget immediate_number_p */ \
11219 case Rectype_Complex: case Rectype_Ratio: \
11220 case Rectype_Ffloat: case Rectype_Dfloat: case Rectype_Lfloat: \
11221 case Rectype_Bignum: \
11222 goto case_number;
11223 #define case_Rectype_float_above /* don't forget short_float_p */ \
11224 case Rectype_Ffloat: case Rectype_Dfloat: case Rectype_Lfloat: \
11225 goto case_float;
11226 #define case_Rectype_integer_above /* don't forget fixnump */ \
11227 case Rectype_Bignum: goto case_integer;
11228 #endif
11229
11230 #if defined(TYPECODES) || defined(ONE_FREE_BIT_HEAPCODES)
11231 #define case_Rectype_Subr_above
11232 #else /* KERNELVOID32_HEAPCODES || GENERIC64_HEAPCODES */
11233 #define case_Rectype_Subr_above \
11234 case Rectype_Subr: goto case_subr;
11235 #endif
11236
11237
11238 /* ################# Declarations for the arithmetics #######################
11239
11240 Type hierachy :
11241 Number (N) =
11242 Real (R) =
11243 Float (F) =
11244 Short float (SF)
11245 Single float (FF)
11246 Double float (DF)
11247 Long float (LF)
11248 Rational (RA) =
11249 Integer (I) =
11250 Fixnum (FN)
11251 Bignum (BN)
11252 Ratio (RT)
11253 Complex (C)
11254
11255 Type field:
11256 Bytes for testing whether it's that type (Bit set, is yes).
11257 _bit_t to test in the type byte (tint)
11258 _bit_o to test in the object (oint) */
11259
11260 #ifndef NUMBER_BITS_INVERTED
11261 #define number_wbit_test wbit_test
11262 #else
11263 #define number_wbit_test !wbit_test
11264 #endif
11265
11266 #ifdef TYPECODES
11267
11268 /* see above:
11269 #define number_bit_t 4 -- set only for numbers
11270 #define number_bit_o (number_bit_t+oint_type_shift) -- set only for numbers
11271
11272 float_bit:
11273 in a number : Bit set, if it's a Float.
11274 Bit unset, if it's a rational or complex number.
11275 (For NUMBER_BITS_INVERTED it's exactly the other way around.)
11276 #define float_bit_t 1
11277 #define float_bit_o (float_bit_t+oint_type_shift)
11278
11279 float1_bit:
11280 In a floating-point: discriminates further: */
11281 #ifndef NUMBER_BITS_INVERTED
11282 /* Float-Bit 1 2
11283 0 0 Short Float (SF)
11284 0 1 Single Float (FF)
11285 1 0 Double Float (DF)
11286 1 1 Long Float (LF) */
11287 #else
11288 /* Float-Bit 1 2
11289 0 0 Long Float (LF)
11290 0 1 Double Float (DF)
11291 1 0 Single Float (FF)
11292 1 1 Short Float (SF) */
11293 #endif
11294 /* #define float1_bit_t 3
11295 #define float1_bit_o (float1_bit_t+oint_type_shift)
11296 #define float2_bit_t 2
11297 #define float2_bit_o (float2_bit_t+oint_type_shift) */
11298
11299 /* ratio_bit:
11300 For rational numbers: Bit set , if it's a real fraction.
11301 Bit unset, if it's an Integer.
11302 (For NUMBER_BITS_INVERTED it's exactly the other way around..)
11303 #define ratio_bit_t 3
11304 #define ratio_bit_o (ratio_bit_t+oint_type_shift) */
11305
11306 /* bignum_bit:
11307 For Integers: Bit set, if it's a Bignum.
11308 Bit unset, if it's a Fixnum.
11309 (For NUMBER_BITS_INVERTED it's exactly the other way around..)
11310 #define bignum_bit_t 2
11311 #define bignum_bit_o (bignum_bit_t+oint_type_shift) */
11312
11313 /* vorz_bit: (sign bit)
11314 For Reals:
11315 returns the sign of the number.
11316 Bit set, if number < 0,
11317 Bit unset, if number >=0. */
11318 #define vorz_bit_t sign_bit_t
11319 /* should be = 0, so the sign-extend
11320 is easier for Fixnums. */
11321 #define vorz_bit_o (vorz_bit_t+oint_type_shift)
11322
11323 #endif
11324
11325 /* return the sign of a real number (0 if >=0, -1 if <0) */
11326 #ifdef TYPECODES
11327 #if (vorz_bit_o<32) && !defined(WIDE_STRUCT)
11328 #define R_sign(obj) ((signean)sign_of_sint32( (sint32)((uint32)as_oint(obj) << (31-vorz_bit_o)) ))
11329 #else
11330 /* define R_sign(obj) ((signean)sign_of_sint32( (sint32)(uint32)(as_oint(obj) >> (vorz_bit_o-31)) )) */
11331 #define R_sign(obj) ((signean)sign_of_sint32( (sint32)((uint32)typecode(obj) << (31-vorz_bit_t)) ))
11332 #endif
11333 #else
11334 #define R_sign(obj) ((signean)sign_of_sint32(_R_sign(obj)))
11335 #define _R_sign(obj) \
11336 (number_immediatep(obj) \
11337 ? /* fixnum, sfloat */ (sint32)as_oint(obj) << (31-sign_bit_o) \
11338 : /* [fdl]float */ (sint32)(sintB)Record_flags(obj))
11339 #endif
11340
11341 /* Gives the sign of a Fixnum/Bignum/Ratio/
11342 Short-/Single-/Double-/Long-Float. */
11343 #ifdef TYPECODES
11344 #define FN_sign(obj) R_sign(obj)
11345 #define BN_sign(obj) R_sign(obj)
11346 #define RT_sign(obj) R_sign(obj)
11347 #define SF_sign(obj) R_sign(obj)
11348 #define FF_sign(obj) R_sign(obj)
11349 #define DF_sign(obj) R_sign(obj)
11350 #define LF_sign(obj) R_sign(obj)
11351 #else
11352 #define FN_sign(obj) \
11353 ((signean)sign_of_sint32((sint32)as_oint(obj) << (31-sign_bit_o)))
11354 #define BN_sign(obj) \
11355 ((signean)sign_of_sint32((sint32)(sintB)Record_flags(obj)))
11356 #define RT_sign(obj) \
11357 ((signean)sign_of_sint32((sint32)(sintB)Record_flags(obj)))
11358 #define SF_sign(obj) \
11359 ((signean)sign_of_sint32((sint32)as_oint(obj) << (31-sign_bit_o)))
11360 #define FF_sign(obj) \
11361 ((signean)sign_of_sint32((sint32)(sintB)Record_flags(obj)))
11362 #define DF_sign(obj) \
11363 ((signean)sign_of_sint32((sint32)(sintB)Record_flags(obj)))
11364 #define LF_sign(obj) \
11365 ((signean)sign_of_sint32((sint32)(sintB)Record_flags(obj)))
11366 #endif
11367
11368 /* Checks whether two real numbers have the same sign: */
11369 #ifdef TYPECODES
11370 #define same_sign_p(obj1,obj2) \
11371 (wbit_test(as_oint(obj1)^as_oint(obj2),vorz_bit_o)==0)
11372 #else
11373 #define same_sign_p(obj1,obj2) \
11374 ((sint32)(_R_sign(obj1) ^ _R_sign(obj2)) >= 0)
11375 #endif
11376
11377
11378 /* Type test macros:
11379 (Return /=0, if satisfied. Prefix 'm', if argument is in memory) */
11380
11381 /* Tests an objects whether it's a number: (see above)
11382 define numberp(obj) ... */
11383
11384 /* Tests a number whether it's a Float. */
11385 #ifdef TYPECODES
11386 #ifndef NUMBER_BITS_INVERTED
11387 /* define N_floatp(obj) ( as_oint(obj) & wbit(float_bit_o) ) */
11388 #define N_floatp(obj) (wbit_test(as_oint(obj),float_bit_o))
11389 #else
11390 #define N_floatp(obj) (!wbit_test(as_oint(obj),float_bit_o))
11391 #endif
11392 #else
11393 #define N_floatp(obj) floatp(obj)
11394 #endif
11395
11396 /* Tests a number whether it's an Integer. */
11397 #ifdef TYPECODES
11398 #ifndef NUMBER_BITS_INVERTED
11399 #define N_integerp(obj) (!( as_oint(obj) & (wbit(float_bit_o)|wbit(ratio_bit_o)) ))
11400 #else
11401 #define N_integerp(obj) (!( (wbit(float_bit_o)|wbit(ratio_bit_o)) & ~as_oint(obj) ))
11402 #endif
11403 #else
11404 #define N_integerp(obj) integerp(obj)
11405 #endif
11406
11407 /* Tests a real number whether it's rational. */
11408 #ifdef TYPECODES
11409 #ifndef NUMBER_BITS_INVERTED
11410 /* define R_rationalp(obj) (!( as_oint(obj) & wbit(float_bit_o) )) */
11411 #define R_rationalp(obj) (!wbit_test(as_oint(obj),float_bit_o))
11412 #else
11413 #define R_rationalp(obj) (wbit_test(as_oint(obj),float_bit_o))
11414 #endif
11415 #else
11416 #define R_rationalp(obj) (!floatp(obj))
11417 #endif
11418
11419 /* Tests a real number whether it's a Float. */
11420 #ifdef TYPECODES
11421 #ifndef NUMBER_BITS_INVERTED
11422 /* define R_floatp(obj) ( as_oint(obj) & wbit(float_bit_o) ) */
11423 #define R_floatp(obj) (wbit_test(as_oint(obj),float_bit_o))
11424 #else
11425 #define R_floatp(obj) (!wbit_test(as_oint(obj),float_bit_o))
11426 #endif
11427 #else
11428 #define R_floatp(obj) floatp(obj)
11429 #endif
11430
11431 /* Tests a real number whether it's <0. */
11432 #ifdef TYPECODES
11433 /* define R_minusp(obj) ( as_oint(obj) & wbit(vorz_bit_o) ) */
11434 #define R_minusp(obj) (wbit_test(as_oint(obj),vorz_bit_o))
11435 #else
11436 #define R_minusp(obj) (!positivep(obj))
11437 #endif
11438 %% export_def(R_minusp(obj));
11439
11440 /* Tests a rational number whether it's an Integer. */
11441 #ifdef TYPECODES
11442 #ifndef NUMBER_BITS_INVERTED
11443 /* define RA_integerp(obj) (!( as_oint(obj) & wbit(ratio_bit_o) )) */
11444 #define RA_integerp(obj) (!wbit_test(as_oint(obj),ratio_bit_o))
11445 #else
11446 #define RA_integerp(obj) (wbit_test(as_oint(obj),ratio_bit_o))
11447 #endif
11448 #else
11449 #define RA_integerp(obj) (!ratiop(obj))
11450 #endif
11451
11452 /* Tests a rational number whether it's a fraction. */
11453 #ifdef TYPECODES
11454 #ifndef NUMBER_BITS_INVERTED
11455 /* define RA_ratiop(obj) ( as_oint(obj) & wbit(ratio_bit_o) ) */
11456 #define RA_ratiop(obj) (wbit_test(as_oint(obj),ratio_bit_o))
11457 #else
11458 #define RA_ratiop(obj) (!wbit_test(as_oint(obj),ratio_bit_o))
11459 #endif
11460 #else
11461 #define RA_ratiop(obj) ratiop(obj)
11462 #endif
11463
11464 /* Tests an Integer whether it's a Bignum. */
11465 #ifndef NUMBER_BITS_INVERTED
11466 /* define I_bignump(obj) ( as_oint(obj) & wbit(bignum_bit_o) ) */
11467 #define I_bignump(obj) (wbit_test(as_oint(obj),bignum_bit_o))
11468 #else
11469 #define I_bignump(obj) (!wbit_test(as_oint(obj),bignum_bit_o))
11470 #endif
11471
11472 /* Tests an Integer whether it's a Fixnum. */
11473 #ifndef NUMBER_BITS_INVERTED
11474 /* define I_fixnump(obj) (!( as_oint(obj) & wbit(bignum_bit_o) )) */
11475 #define I_fixnump(obj) (!wbit_test(as_oint(obj),bignum_bit_o))
11476 #else
11477 #define I_fixnump(obj) (wbit_test(as_oint(obj),bignum_bit_o))
11478 #endif
11479
11480 /* Tests a Fixnum whether it is >=0. */
11481 #ifdef TYPECODES
11482 #define FN_positivep(obj) positivep(obj)
11483 #else
11484 #define FN_positivep(obj) ((as_oint(obj) & wbit(sign_bit_o)) == 0)
11485 #endif
11486 %% export_def(FN_positivep(obj));
11487
11488 /* Tests a Bignum whether it is >=0. */
11489 #ifdef TYPECODES
11490 #define BN_positivep(obj) positivep(obj)
11491 #else
11492 #define BN_positivep(obj) ((Record_flags(obj) & bit(7)) == 0)
11493 #endif
11494 %% export_def(BN_positivep(obj));
11495
11496 /* Tests a number whether it's a real number */
11497 #define N_realp(obj) (!complexp(obj))
11498
11499 /* Tests a number whether it's a complex number */
11500 #define N_complexp(obj) complexp(obj)
11501
11502 /* Tests two Integers whether both are Bignum. */
11503 #ifndef NUMBER_BITS_INVERTED
11504 #define I_I_bignums_p(obj1,obj2) \
11505 (wbit_test(as_oint(obj1)&as_oint(obj2),bignum_bit_o))
11506 #else
11507 #define I_I_bignums_p(obj1,obj2) \
11508 (!wbit_test(as_oint(obj1)|as_oint(obj2),bignum_bit_o))
11509 #endif
11510
11511 /* Tests for an Integer from a given range.
11512 obj should be a variable */
11513 #define uint1_p(obj) \
11514 ((as_oint(obj) & ~((oint)0x01 << oint_data_shift)) == as_oint(Fixnum_0))
11515 #define uint2_p(obj) \
11516 ((as_oint(obj) & ~((oint)0x03 << oint_data_shift)) == as_oint(Fixnum_0))
11517 #define uint4_p(obj) \
11518 ((as_oint(obj) & ~((oint)0x0F << oint_data_shift)) == as_oint(Fixnum_0))
11519 #define uint8_p(obj) \
11520 ((as_oint(obj) & ~((oint)0xFF << oint_data_shift)) == as_oint(Fixnum_0))
11521 #define sint8_p(obj) \
11522 (((as_oint(obj) ^ (FN_positivep(obj) ? 0 : as_oint(Fixnum_minus1)^as_oint(Fixnum_0))) & ~((oint)0x7F << oint_data_shift)) == as_oint(Fixnum_0))
11523 #define uint16_p(obj) \
11524 ((as_oint(obj) & ~((oint)0xFFFF << oint_data_shift)) == as_oint(Fixnum_0))
11525 #define sint16_p(obj) \
11526 (((as_oint(obj) ^ (FN_positivep(obj) ? 0 : as_oint(Fixnum_minus1)^as_oint(Fixnum_0))) & ~((oint)0x7FFF << oint_data_shift)) == as_oint(Fixnum_0))
11527 #if (oint_data_len>=32)
11528 #define uint32_p(obj) \
11529 ((as_oint(obj) & ~((oint)0xFFFFFFFFUL << oint_data_shift)) == as_oint(Fixnum_0))
11530 #else
11531 #define uint32_p(obj) \
11532 (posfixnump(obj) \
11533 || (posbignump(obj) \
11534 && (Bignum_length(obj) <= ceiling(33,intDsize)) \
11535 && ((Bignum_length(obj) < ceiling(33,intDsize)) \
11536 || (TheBignum(obj)->data[0] < (uintD)bit(32%intDsize)))))
11537 #endif
11538 #if (oint_data_len>=31)
11539 #define sint32_p(obj) \
11540 (((as_oint(obj) ^ (FN_positivep(obj) ? 0 : as_oint(Fixnum_minus1)^as_oint(Fixnum_0))) & ~((oint)0x7FFFFFFFUL << oint_data_shift)) == as_oint(Fixnum_0))
11541 #else
11542 #define sint32_p(obj) \
11543 (fixnump(obj) \
11544 || (bignump(obj) \
11545 && (Bignum_length(obj) <= ceiling(32,intDsize)) \
11546 && ((Bignum_length(obj) < ceiling(32,intDsize)) \
11547 || ((TheBignum(obj)->data[0] ^ (BN_positivep(obj) ? (uintD)0 : ~(uintD)0)) < (uintD)bit(31%intDsize)))))
11548 #endif
11549 #define uint64_p(obj) \
11550 (posfixnump(obj) \
11551 || (posbignump(obj) \
11552 && (Bignum_length(obj) <= ceiling(65,intDsize)) \
11553 && ((Bignum_length(obj) < ceiling(65,intDsize)) \
11554 || (TheBignum(obj)->data[0] < (uintD)bit(64%intDsize)))))
11555 #define sint64_p(obj) \
11556 (fixnump(obj) \
11557 || (bignump(obj) \
11558 && (Bignum_length(obj) <= ceiling(64,intDsize)) \
11559 && ((Bignum_length(obj) < ceiling(64,intDsize)) \
11560 || ((TheBignum(obj)->data[0] ^ (BN_positivep(obj) ? (uintD)0 : ~(uintD)0)) < (uintD)bit(63%intDsize)))))
11561 #if (int_bitsize==16)
11562 #define uint_p uint16_p
11563 #define sint_p sint16_p
11564 #else /* (int_bitsize==32) */
11565 #define uint_p uint32_p
11566 #define sint_p sint32_p
11567 #endif
11568 #if (long_bitsize==32)
11569 #define ulong_p uint32_p
11570 #define slong_p sint32_p
11571 #else /* (long_bitsize==64) */
11572 #define ulong_p uint64_p
11573 #define slong_p sint64_p
11574 #endif
11575 %% export_def(uint8_p(obj));
11576 %% export_def(sint8_p(obj));
11577 %% export_def(uint16_p(obj));
11578 %% export_def(sint16_p(obj));
11579 %% export_def(uint32_p(obj));
11580 %% export_def(sint32_p(obj));
11581 %% export_def(uint64_p(obj));
11582 %% export_def(sint64_p(obj));
11583 %% export_def(uint_p);
11584 %% export_def(sint_p);
11585 %% export_def(ulong_p);
11586 %% export_def(slong_p);
11587
11588
11589 /* ####################### TIMEBIBL in TIME.D #############################
11590
11591 (* 25567 24 60 60) => 2208988800
11592 the number of seconds from 1900-01-01 to 1970-01-01 */
11593 #define UNIX_LISP_TIME_DIFF 2208988800UL
11594 %% export_def(UNIX_LISP_TIME_DIFF);
11595
11596 /* Type which is used for 'Internal Time': */
11597 #ifdef TIME_UNIX
11598 typedef struct {
11599 uintL tv_sec; /* number of seconds since 1.1.1970 00:00 GMT,
11600 'uintL' for tv_sec is good for 136 years. */
11601 uintL tv_usec; /* additional microseconds */
11602 } internal_time_t;
11603 #define ticks_per_second 1000000UL /* 1 Tick = 1 mu-sec */
11604 #define sub_internal_time(x,y, z) /* z:=x-y */ \
11605 do { (z).tv_sec = (x).tv_sec - (y).tv_sec; \
11606 if ((x).tv_usec < (y).tv_usec) \
11607 { (x).tv_usec += ticks_per_second; (z).tv_sec -= 1; } \
11608 (z).tv_usec = (x).tv_usec - (y).tv_usec; \
11609 } while(0)
11610 #define add_internal_time(x,y, z) /* z:=x+y */ \
11611 do { (z).tv_sec = (x).tv_sec + (y).tv_sec; \
11612 (z).tv_usec = (x).tv_usec + (y).tv_usec; \
11613 if ((z).tv_usec >= ticks_per_second) \
11614 { (z).tv_usec -= ticks_per_second; (z).tv_sec += 1; } \
11615 } while(0)
11616 #endif
11617 #ifdef TIME_WIN32
11618 typedef /* struct _FILETIME { DWORD dwLowDateTime; DWORD dwHighDateTime; } */
11619 FILETIME /* number of 0.1 mu-sec since 1.1.1601 00:00 GMT. */
11620 internal_time_t;
11621 #define ticks_per_second 10000000UL /* 1 Tick = 0.1 mu-sec */
11622 #define sub_internal_time(x,y, z) /* z:=x-y */ \
11623 do { (z).dwHighDateTime = (x).dwHighDateTime - (y).dwHighDateTime; \
11624 if ((x).dwLowDateTime < (y).dwLowDateTime) { (z).dwHighDateTime -= 1;}\
11625 (z).dwLowDateTime = (x).dwLowDateTime - (y).dwLowDateTime; \
11626 } while(0)
11627 #define add_internal_time(x,y, z) /* z:=x+y */ \
11628 do { (z).dwHighDateTime = (x).dwHighDateTime + (y).dwHighDateTime; \
11629 (z).dwLowDateTime = (x).dwLowDateTime + (y).dwLowDateTime; \
11630 if ((z).dwLowDateTime < (x).dwLowDateTime) { (z).dwHighDateTime += 1;}\
11631 } while(0)
11632 #endif
11633
11634 /* UP: yields the real-time
11635 get_real_time()
11636 < internal_time_t* result: absolute time */
11637 extern void get_real_time (internal_time_t*);
11638 /* is used by LISPARIT */
11639
11640 /* UP: Yields the run-time
11641 get_running_times(×core);
11642 < timescore.runtime: Run-time since LISP-system-start (in Ticks)
11643 < timescore.realtime: Real-time since LISP-system-start (in Ticks)
11644 < timescore.gctime: GC-Time since LISP-system-start (in Ticks)
11645 < timescore.gccount: Number of GC's since LISP-system-start
11646 < timescore.gcfreed: Size of the space reclaimed by the GC's so far*/
11647 typedef struct {
11648 internal_time_t runtime;
11649 internal_time_t realtime;
11650 internal_time_t gctime;
11651 uintL gccount;
11652 uintL2 gcfreed;
11653 } timescore_t;
11654 extern void get_running_times (timescore_t*);
11655 /* is used by TIME */
11656
11657 /* Converts an internal_time_t to a Lisp integer.
11658 internal_time_to_I(&it) */
11659 extern object internal_time_to_I (const internal_time_t* tp);
11660 /* used by TIME, DEBUG */
11661
11662 /* UP: yields the run-time
11663 get_thread_run_time(&runtime, thread);
11664 > thread: thread for which to obtain info (nullobj for process wide)
11665 < runtime: Run-time (in Ticks)
11666 < returns true if successful (may fail in MT) */
11667 extern bool get_thread_run_time (internal_time_t* runtime, object thread);
11668 #define get_run_time(runtime) get_thread_run_time(runtime, nullobj)
11669 /* is used by SPVW */
11670
11671 /* Time in decoded-time: */
11672 typedef struct {
11673 object seconds;
11674 object minutes;
11675 object hours;
11676 object day;
11677 object month;
11678 object year;
11679 } decoded_time_t;
11680
11681 #ifdef UNIX
11682 /* UP: Converts the system-time-format into Decoded-Time.
11683 convert_time(&time,&timepoint);
11684 > time_t time: time in the system-time-format
11685 < timepoint.seconds, timepoint.minutes, timepoint.hours,
11686 timepoint.day, timepoint.month, timepoint.year, each a Fixnum */
11687 extern void convert_time (const time_t* time, decoded_time_t* timepoint);
11688 /* is used by PATHNAME */
11689 #endif
11690 #ifdef WIN32_NATIVE
11691 /* UP: Converts the system-time-format into Decoded-Time.
11692 convert_time(&time,&timepoint);
11693 > FILETIME time: time in the system-time-format
11694 < timepoint.seconds, timepoint.minutes, timepoint.hours,
11695 timepoint.day, timepoint.month, timepoint.year, each a Fixnum */
11696 extern void convert_time (const FILETIME* time, decoded_time_t* timepoint);
11697 /* is used by PATHNAME */
11698 #endif
11699
11700 #ifdef UNIX
11701 /* UP: Converts the system time-format into Universal-Time.
11702 convert_time_to_universal(&time)
11703 > time_t time: time in the system time-format
11704 < result: integer denoting the seconds since 1900-01-01 00:00 GMT
11705 can trigger GC */
11706 extern maygc object convert_time_to_universal (const time_t* time);
11707 /* is used by PATHNAME */
11708 #endif
11709 #ifdef WIN32_NATIVE
11710 /* UP: converts the system time-format into Universal-Time.
11711 convert_time_to_universal(&time)
11712 > FILETIME time: Time in the system-time-format
11713 < result: integer denoting the seconds since 1900-01-01 00:00 GMT
11714 can trigger GC */
11715 extern maygc object convert_time_to_universal (const FILETIME* time);
11716 /* is used by PATHNAME */
11717 #endif
11718 %% #ifdef UNIX
11719 %% exportF(object,convert_time_to_universal,(const time_t* time));
11720 %% #endif
11721 %% #ifdef WIN32_NATIVE
11722 %% exportF(object,convert_time_to_universal,(const FILETIME* time));
11723 %% #endif
11724
11725 #ifdef UNIX
11726 /* the inverse of convert_time_to_universal() */
11727 extern void convert_time_from_universal (object universal, time_t* time);
11728 #endif
11729 #ifdef WIN32_NATIVE
11730 /* the inverse of convert_time_to_universal() */
11731 extern void convert_time_from_universal (object universal, FILETIME* time);
11732 #endif
11733 %% #ifdef UNIX
11734 %% exportF(void,convert_time_from_universal,(object universal, time_t* time));
11735 %% #endif
11736 %% #ifdef WIN32_NATIVE
11737 %% exportF(void,convert_time_from_universal,(object universal, FILETIME* time));
11738 %% #endif
11739
11740 /* UP: Initializes the thread or global time variables. */
11741 extern void init_time ();
11742 /* is used by SPVW */
11743
11744
11745 /* ####################### SPVWBIBL for SPVW.D #############################
11746
11747 The Stacks
11748 ==========
11749
11750 Two Stacks are being used :
11751 - the C-program stack (Stackpointer SP = Register A7),
11752 - the LISP-Stack (Stackpointer STACK).
11753 All calls of sub-programs are done through BSR/JSR via the program stack;
11754 it's also used to temporarily store data, that is not a LISP-object.
11755 The LISP-Stack is used to store frames and for the temporary storage
11756 of LISP-objects.
11757 For both stacks the limits of growth are controlled by the memory management
11758 and the following macros:
11759 check_SP(); tests the program stack for overflow
11760 check_STACK(); tests the LISP-Stack for overflow
11761 get_space_on_STACK(n); tests, whether there are still D0.L
11762 Bytes free on the LISP-Stack
11763 Basically only long words may be stored on the LISP-Stack.
11764 If FRAME_BIT is set, it's the lower end of a frame;
11765 this long word is a pointer above the Frame, together with a
11766 Frame-type-Byte; if SKIP2_BIT is unset in it, the longword above
11767 it is not a LISP-object.
11768 All other long words on the LISP-Stack are LISP-objects.
11769
11770 machine stack: SP
11771 SP() returns the current value of the SP.
11772 setSP(adresse); sets the SP to a given value. Extremely dangerous!
11773 FAST_SP defined, if SP-accesses are fast. */
11774 #if defined(GNU) && !(__APPLE_CC__ > 1) && !defined(__clang__)
11775 /* definition of the register, in which the SP resides. */
11776 #ifdef M68K
11777 #define SP_register "sp" /* %sp = %a7 */
11778 #endif
11779 #ifdef SPARC
11780 #define SP_register "%sp" /* %sp = %o6 */
11781 #endif
11782 #ifdef HPPA
11783 #define SP_register "%r30" /* %sp = %r30 */
11784 #endif
11785 #ifdef MIPS
11786 #define SP_register "$sp" /* $sp = $29 */
11787 #endif
11788 #ifdef POWERPC
11789 #define SP_register "r1"
11790 #endif
11791 #ifdef ARM
11792 #define SP_register "%sp" /* %sp = %r13 */
11793 #endif
11794 #ifdef DECALPHA
11795 #define SP_register "$30" /* $sp = $30 */
11796 #endif
11797 #ifdef I80386
11798 #define SP_register "%esp"
11799 #endif
11800 #ifdef IA64
11801 #define SP_register "r12"
11802 #endif
11803 #ifdef AMD64
11804 #define SP_register "%rsp"
11805 #endif
11806 #ifdef S390
11807 #define SP_register "15"
11808 #endif
11809 #ifdef RISCV64
11810 #define SP_register "sp"
11811 #endif
11812 #endif
11813 #if (defined(GNU) || defined(INTEL)) && !defined(NO_ASM)
11814 /* Assembler-instruction that copies the SP-register into a variable. */
11815 #ifdef M68K
11816 #ifdef __REGISTER_PREFIX__ /* GNU C Version >= 2.4 has %/ and __REGISTER_PREFIX__ */
11817 /* But the value of __REGISTER_PREFIX__ is useless, because we might be
11818 cross-compiling. */
11819 #define REGISTER_PREFIX "%/"
11820 #else
11821 #define REGISTER_PREFIX "" /* or "%%", depends on the assembler that's being used */
11822 #endif
11823 #define ASM_get_SP_register(resultvar) ("movel "REGISTER_PREFIX"sp,%0" : "=g" (resultvar) : )
11824 #endif
11825 #ifdef SPARC
11826 #ifdef SPARC64
11827 #define ASM_get_SP_register(resultvar) ("add %%sp,2048,%0" : "=r" (resultvar) : )
11828 #else
11829 #define ASM_get_SP_register(resultvar) ("mov %%sp,%0" : "=r" (resultvar) : )
11830 #endif
11831 #endif
11832 #ifdef HPPA
11833 #define ASM_get_SP_register(resultvar) ("copy %%r30,%0" : "=r" (resultvar) : )
11834 #endif
11835 #ifdef MIPS
11836 #define ASM_get_SP_register(resultvar) ("move\t%0,$sp" : "=r" (resultvar) : )
11837 #endif
11838 #ifdef POWERPC
11839 #define ASM_get_SP_register(resultvar) ("mr %0,r1" : "=r" (resultvar) : )
11840 #endif
11841 #ifdef ARM
11842 #define ASM_get_SP_register(resultvar) ("mov\t%0, sp" : "=r" (resultvar) : )
11843 #endif
11844 #ifdef DECALPHA
11845 #define ASM_get_SP_register(resultvar) ("bis $30,$30,%0" : "=r" (resultvar) : )
11846 #endif
11847 #ifdef I80386
11848 #define ASM_get_SP_register(resultvar) ("movl %%esp,%0" : "=g" (resultvar) : )
11849 #endif
11850 #ifdef IA64
11851 #define ASM_get_SP_register(resultvar) ("mov %0 = r12" : "=r" (resultvar) : )
11852 #endif
11853 #ifdef AMD64
11854 #define ASM_get_SP_register(resultvar) ("movq %%rsp,%0" : "=g" (resultvar) : )
11855 #endif
11856 #ifdef S390
11857 #define ASM_get_SP_register(resultvar) ("lr %0,%%r15" : "=r" (resultvar) : )
11858 #endif
11859 #ifdef RISCV64
11860 #define ASM_get_SP_register(resultvar) ("mv %0,sp" : "=r" (resultvar) : )
11861 #endif
11862 #endif
11863 #if defined(GNU) && defined(M68K) && !defined(NO_ASM)
11864 /* Access to a global register-"variable" SP */
11865 #define SP() \
11866 ({var aint __SP; \
11867 __asm__ __volatile__ ("movel "REGISTER_PREFIX"sp,%0" : "=g" (__SP) : ); \
11868 __SP; \
11869 })
11870 #define setSP(adresse) \
11871 ({ __asm__ __volatile__ ("movel %0,"REGISTER_PREFIX"sp" : : "g" ((aint)(adresse)) : "sp" ); })
11872 #define FAST_SP
11873 #elif (defined(GNU) || defined(INTEL)) && defined(I80386) && !defined(NO_ASM)
11874 /* Access to a register-"variable" %esp */
11875 #define SP() \
11876 ({var aint __SP; \
11877 __asm__ __volatile__ ("movl %%esp,%0" : "=g" (__SP) : ); \
11878 __SP; \
11879 })
11880 /* Doesn't work with gcc 3.1 any more. */
11881 #if (__GNUC__ < 3) || (__GNUC__ == 3 && __GNUC_MINOR__ < 1)
11882 #define setSP(adresse) \
11883 ({ __asm__ __volatile__ ("movl %0,%%esp" : : "g" ((aint)(adresse)) : "sp" ); })
11884 #define FAST_SP
11885 #endif
11886 #elif defined(GNU) && defined(SP_register)
11887 register __volatile__ aint __SP __asm__(SP_register);
11888 #ifdef SPARC64
11889 #define SP() (__SP+2048)
11890 #else
11891 #define SP() __SP
11892 #endif
11893 #if defined(SPARC)
11894 /* We must not do a setSP() here without taking care that
11895 1. %sp has to pay attention to an alignment of 8 Bytes,
11896 2. above %sp 92 Bytes have to be kept free (that's where the
11897 register contents are saved, if a 'register window overflow trap'
11898 is triggered by a 'save' in a sub-program). */
11899 #endif
11900 #elif defined(MICROSOFT) && defined(I80386) && !defined(NO_ASM)
11901 /* access the register %esp */
11902 #define SP getSP
getSP()11903 static __inline aint getSP () { __asm mov eax,esp }
setSP(aint address)11904 static __inline aint setSP (aint address) { __asm mov esp,address }
11905 #elif (defined(M68K) || defined(SPARC) || defined(MIPS) || (defined(I80386) && !defined(UNIX_MACOSX))) && !defined(NO_SP_ASM)
11906 /* access functions extern, in assembler */
11907 #define SP getSP
11908 #define getSP asm_getSP
11909 extern_C void* getSP (void);
11910 #define setSP asm_setSP
11911 extern_C void setSP (void* adresse);
11912 #else
11913 /* access function portable in C */
11914 #define SP() getSP()
11915 extern void* getSP (void);
11916 #define NEED_OWN_GETSP
11917 #endif
11918 #if defined(stack_grows_down) /* defined(M68K) || defined(I80386) || defined(SPARC) || defined(MIPS) || defined(DECALPHA) || defined(IA64) || defined(AMD64) || defined(S390) || defined(RISCV64) || ... */
11919 #define SP_DOWN /* SP grows downward */
11920 #define SPoffset 0 /* top-of-SP ist *(SP+SPoffset) */
11921 #endif
11922 #if defined(stack_grows_up) /* defined(HPPA) || ... */
11923 #define SP_UP /* SP grows upward */
11924 #define SPoffset -1 /* top-of-SP ist *(SP+SPoffset) */
11925 #endif
11926 #if (defined(SP_DOWN) && defined(SP_UP)) || (!defined(SP_DOWN) && !defined(SP_UP))
11927 #error Unknown SP direction -- readjust SP_DOWN/SP_UP!
11928 #endif
11929 /* Derived from that:
11930 SPint is the type of the elements on the SP, an Integer type at least as
11931 wide as uintL and at least as wide as aint resp. void*.
11932 SP_(n) = (n+1)th longword on the SP.
11933 _SP_(n) = &SP_(n).
11934 pushSP(item) puts a longword on the SP. Synonym: -(SP).
11935 popSP(item=) returns item=SP_(0) and takes it off the SP.
11936 skipSP(n); takes n long words of the SP. */
11937 typedef uintP SPint;
11938 %% #ifdef export_unwind_protect_macros
11939 %% emit_typedef("uintP","SPint");
11940 %% #endif
11941 #ifdef SP_DOWN
11942 #define skipSPop +=
11943 #define SPop +
11944 #endif
11945 #ifdef SP_UP
11946 #define skipSPop -=
11947 #define SPop -
11948 #endif
11949 #define _SP_(n) (((SPint*)SP()) + SPoffset SPop (uintP)(n))
11950 #if !(defined(GNU) && defined(M68K) && !defined(NO_ASM)) /* generally */
11951 #define SP_(n) (((SPint*)SP())[SPoffset SPop (uintP)(n)])
11952 #define skipSP(n) \
11953 do { var register SPint* sp = (SPint*)SP(); \
11954 sp skipSPop (uintP)(n); \
11955 setSP(sp); \
11956 } while(0)
11957 #define pushSP(item) \
11958 do { var register SPint* sp = (SPint*)SP(); \
11959 sp skipSPop -1; \
11960 setSP(sp); /* First decrease SP (because of a possible interrupt!) */\
11961 sp[SPoffset] = (item); /* then insert item as top-of-SP */ \
11962 } while(0)
11963 #define popSP(item_assignment) \
11964 do { var register SPint* sp = (SPint*)SP(); \
11965 item_assignment sp[SPoffset]; /* First fetch top-of-SP */\
11966 sp skipSPop 1; \
11967 setSP(sp); /* then (danger of interrupt!) increase SP */\
11968 } while(0)
11969 #endif
11970 #if defined(GNU) && defined(M68K) && !defined(NO_ASM)
11971 /* With GNU on as 680X0 SP is in a register. Thus access and
11972 modification of SP are a unit that cannot be interrupted.
11973 And SP_DOWN as well as SPoffset=0 hold. */
11974 #define SP_(n) \
11975 ({var register uintL __n = sizeof(SPint) * (n); \
11976 var register SPint __item; \
11977 __asm__ __volatile__ ("movel "REGISTER_PREFIX"sp@(%1:l),%0" : "=g" (__item) : "r" (__n) ); \
11978 __item; \
11979 })
11980 #define skipSP(n) \
11981 do { var register uintL __n = sizeof(SPint) * (n); \
11982 __asm__ __volatile__ ("addl %0,"REGISTER_PREFIX"sp" : : "g" (__n) : "sp" ); \
11983 } while(0)
11984 #define pushSP(item) \
11985 do { var register SPint __item = (item); \
11986 __asm__ __volatile__ ("movel %0,"REGISTER_PREFIX"sp@-" : : "g" (__item) : "sp" ); \
11987 } while(0)
11988 #define popSP(item_assignment) \
11989 do { var register SPint __item; \
11990 __asm__ __volatile__ ("movel "REGISTER_PREFIX"sp@+,%0" : "=r" (__item) : : "sp" ); \
11991 item_assignment __item; \
11992 } while(0)
11993 #endif
11994 /* An sp_jmp_buf is exactly the same as a jmp_buf,
11995 except that on Irix 6.5 in 32-bit mode, a jmp_buf has alignment 8,
11996 whereas an SPint only has alignment 4.
11997 Need to add some padding.
11998 Then jmpbufsize = sizeof(sp_jmp_buf)/sizeof(SPint). */
11999 #define sp_jmp_buf_incr (alignof(jmp_buf)>alignof(SPint)?alignof(jmp_buf)-alignof(SPint):0)
12000 #define sp_jmp_buf_to_jmp_buf(x) (*(jmp_buf*)(((long)&(x)+(long)sp_jmp_buf_incr)&-(long)(alignof(jmp_buf)>alignof(SPint)?alignof(jmp_buf):1)))
12001 #define setjmpspl(x) setjmpl(sp_jmp_buf_to_jmp_buf(x))
12002 #define longjmpspl(x,y) longjmpl(sp_jmp_buf_to_jmp_buf(x),y)
12003 #define jmpbufsize ceiling(sizeof(jmp_buf)+sp_jmp_buf_incr,sizeof(SPint))
12004 typedef SPint sp_jmp_buf[jmpbufsize];
12005 %% #ifdef export_unwind_protect_macros
12006 %% printf("#define jmpbufsize %d\n",jmpbufsize);
12007 %% puts("typedef SPint sp_jmp_buf[jmpbufsize];");
12008 %% #endif
12009 /* The initial value of SP() during main(). */
12010 extern void* SP_anchor;
12011 %% #if (defined(GNU) || defined(INTEL)) && defined(I80386) && !defined(NO_ASM)
12012 %% printf("%s\n","#define SP() ({aint __SP; __asm__ __volatile__ (\"movl %%esp,%0\" : \"=g\" (__SP) : ); __SP; })");
12013 %% #endif
12014
12015 /* LISP-Stack: STACK */
12016 #if !defined(STACK_register)
12017 /* a global variable */
12018 extern gcv_object_t* STACK;
12019 #else
12020 /* a global register variable */
12021 register gcv_object_t* STACK __asm__(STACK_register);
12022 #endif
12023 #if defined(SPARC) && !defined(GNU) && !defined(__SUNPRO_C) && !defined(MULTITHREAD) && (SAFETY < 2)
12024 /* a global register variable, but access functions externally in assembler */
12025 #define STACK _getSTACK()
12026 extern_C gcv_object_t* _getSTACK (void);
12027 #define setSTACK(allocation) /* hem, yuck! */ \
12028 do { var gcv_object_t* tempSTACK; _setSTACK(temp##allocation); } while(0)
12029 extern_C void _setSTACK (void* new_STACK);
12030 #else
12031 #define setSTACK(allocation) allocation
12032 #endif
12033 #if defined(UNIX) || defined(WIN32) || defined(HYPERSTONE)
12034 #define STACK_UP /* STACK grows upward */
12035 #endif
12036 #if (defined(STACK_DOWN) && defined(STACK_UP)) || (!defined(STACK_DOWN) && !defined(STACK_UP))
12037 #error Unknown STACK direction -- readjust STACK_DOWN/STACK_UP!
12038 #endif
12039 %% #if defined(STACK_register)
12040 %% puts("#ifndef IN_MODULE_CC");
12041 %% printf("register gcv_object_t* STACK __asm__(\"%s\");\n",STACK_register);
12042 %% puts("#endif");
12043 %% #elif !defined(STACK)
12044 %% exportV(gcv_object_t*,STACK);
12045 %% #endif
12046
12047 /* A singly-linked list of all currently active function calls.
12048 Resides in the C stack. */
12049 struct backtrace_t {
12050 const struct backtrace_t* bt_next; /* Link to the caller */
12051 gcv_object_t bt_function; /* Function or FSUBR being called */
12052 gcv_object_t *bt_stack; /* STACK value where the frame area begins */
12053 int bt_num_arg; /* Number of arguments, if known, or -1 */
12054 };
12055 extern void back_trace_check (const struct backtrace_t *bt,
12056 const char* label, const char* file, int line);
12057 #ifdef DEBUG_BACKTRACE
12058 #define BT_CHECK(b,l) back_trace_check(b,l,__FILE__,__LINE__)
12059 #else
12060 #define BT_CHECK(b,l)
12061 #endif
12062 #define BT_CHECK1(l) BT_CHECK(back_trace,l)
12063 %% puts("struct backtrace_t {\n struct backtrace_t* bt_next;\n gcv_object_t bt_function;\n gcv_object_t *bt_stack;\n int bt_num_arg;\n};");
12064
12065 #if defined(DEBUG_BACKTRACE) && defined(__cplusplus)
12066 struct p_backtrace_t {
12067 const struct backtrace_t * ba_tr_p;
p_backtrace_tp_backtrace_t12068 p_backtrace_t (void* bt) { ba_tr_p = (struct backtrace_t*)bt; }
12069 /* assignment should check for circularities */
12070 p_backtrace_t& operator= (const struct backtrace_t *bt) {
12071 if (this->ba_tr_p != bt) {
12072 BT_CHECK(bt,"=: new value");
12073 BT_CHECK(ba_tr_p,"=: current value");
12074 this->ba_tr_p = bt;
12075 }
12076 return *this;
12077 };
12078 /* back_trace->foo means back_trace.ba_tr_p->foo */
12079 const struct backtrace_t* operator-> () {
12080 BT_CHECK(ba_tr_p,"->");
12081 return this->ba_tr_p;
12082 };
12083 /* cast p_backtrace_t to struct backtrace_t* */
12084 operator const struct backtrace_t* () const {
12085 BT_CHECK(ba_tr_p,"(struct backtrace_t*)");
12086 return ba_tr_p;
12087 }
12088 };
12089 #else
12090 typedef const struct backtrace_t* p_backtrace_t;
12091 #endif
12092 %% emit_typedef("struct backtrace_t *","p_backtrace_t");
12093
12094 /* Returns the top-of-frame of a back_trace element. */
12095 extern gcv_object_t* top_of_back_trace_frame (const struct backtrace_t *bt);
12096
12097 #define bt_beyond_stack_p(bt,st) \
12098 ((bt) != NULL && !((aint)(st) cmpSTACKop (aint)top_of_back_trace_frame(bt)))
12099 /* unwind backtrace to the stack location */
12100 #define unwind_back_trace(bt,st) \
12101 do { BT_CHECK(bt,"unwind_back_trace"); \
12102 while (bt_beyond_stack_p(bt,st)) \
12103 bt = bt->bt_next; \
12104 } while(0)
12105
12106 /* Evaluate statement, augmenting back_trace with an activation record for
12107 the given function.
12108 stack permits to locate the top-of-frame, namely
12109 - for FSUBRs:
12110 stack = top-of-frame - (req + opt + (body-flag ? 1 : 0))
12111 - for SUBRs:
12112 stack = top-of-frame - (req + opt + length(keyword-list))
12113 - for compiled closures:
12114 stack = top-of-frame - (req + opt + (rest-flag ? 1 : 0) + length(keyword-list))
12115 - for interpreted closures:
12116 stack = top-of-frame
12117 */
12118 #if STACKCHECKS || STACKCHECKC
12119 #define with_saved_back_trace(fun,stack,num_arg,statement) \
12120 do { \
12121 p_backtrace_t bt_save = back_trace; \
12122 struct backtrace_t bt_here; \
12123 bt_here.bt_next = back_trace; \
12124 bt_here.bt_function = (fun); \
12125 bt_here.bt_stack = (stack); \
12126 bt_here.bt_num_arg = (num_arg); \
12127 BT_CHECK1("w/s/b/t: before"); \
12128 back_trace = &bt_here; \
12129 statement; \
12130 if (back_trace != &bt_here) abort(); \
12131 if (back_trace->bt_next != bt_save) abort(); \
12132 BT_CHECK1("w/s/b/t: after"); \
12133 back_trace = back_trace->bt_next; \
12134 } while(0)
12135 #else
12136 #define with_saved_back_trace(fun,stack,num_arg,statement) \
12137 do { \
12138 struct backtrace_t bt_here; \
12139 bt_here.bt_next = back_trace; \
12140 bt_here.bt_function = (fun); \
12141 bt_here.bt_stack = (stack); \
12142 bt_here.bt_num_arg = (num_arg); \
12143 back_trace = &bt_here; \
12144 statement; \
12145 back_trace = back_trace->bt_next; \
12146 } while(0)
12147 #endif
12148 #define with_saved_back_trace_fsubr(fun,statement) \
12149 with_saved_back_trace(fun,STACK,-1,statement)
12150 #define with_saved_back_trace_subr(fun,stack,num_arg,statement) \
12151 with_saved_back_trace(fun,stack,num_arg,statement)
12152 #define with_saved_back_trace_cclosure(fun,statement) \
12153 with_saved_back_trace(fun,STACK,-1,statement)
12154 #define with_saved_back_trace_iclosure(fun,stack,num_arg,statement) \
12155 with_saved_back_trace(fun,stack,num_arg,statement)
12156
12157 /* Every call of an external function (or a sequence of those) has to be framed
12158 with
12159 begin_call();
12160 and
12161 end_call();
12162 Purpose: The stack, if it resides in a register,
12163 should be brought to a halfway recent value
12164 in case of an interrupt during the corresponding timespan.
12165
12166 If you want to access the STACK while an external function run,
12167 you have to frame the corresponding code with
12168 begin_callback();
12169 and
12170 end_callback(); */
12171 #ifdef HAVE_SAVED_mv_count
12172 extern uintC saved_mv_count;
12173 #define SAVE_mv_count() saved_mv_count = mv_count
12174 #define RESTORE_mv_count() mv_count = saved_mv_count
12175 #else
12176 #define SAVE_mv_count()
12177 #define RESTORE_mv_count()
12178 #endif
12179 #ifdef HAVE_SAVED_value1
12180 extern object saved_value1;
12181 #define SAVE_value1() saved_value1 = value1
12182 #define RESTORE_value1() value1 = saved_value1
12183 #else
12184 #define SAVE_value1()
12185 #define RESTORE_value1()
12186 #endif
12187 #ifdef HAVE_SAVED_back_trace
12188 extern p_backtrace_t saved_back_trace;
12189 #define SAVE_back_trace() saved_back_trace = back_trace
12190 #define RESTORE_back_trace() back_trace = saved_back_trace
12191 #else
12192 #define SAVE_back_trace()
12193 #define RESTORE_back_trace()
12194 #endif
12195 #define SAVE_GLOBALS() SAVE_mv_count(); SAVE_value1(); SAVE_back_trace();
12196 #define RESTORE_GLOBALS() RESTORE_mv_count(); RESTORE_value1(); RESTORE_back_trace();
12197 #if defined(HAVE_SAVED_STACK)
12198 extern gcv_object_t* saved_STACK;
12199 #define begin_call() SAVE_GLOBALS(); saved_STACK = STACK
12200 #define end_call() RESTORE_GLOBALS(); saved_STACK = (gcv_object_t*)NULL
12201 #define begin_callback() SAVE_REGISTERS( STACK = saved_STACK; ); end_call()
12202 #define end_callback() SAVE_GLOBALS(); RESTORE_REGISTERS( saved_STACK = STACK; )
12203 #else
12204 #define begin_call() SAVE_GLOBALS()
12205 #define end_call() RESTORE_GLOBALS()
12206 #define begin_callback() SAVE_REGISTERS(;); end_call()
12207 #define end_callback() SAVE_GLOBALS(); RESTORE_REGISTERS(;)
12208 #endif
12209 %% #ifdef HAVE_SAVED_mv_count
12210 %% exportV(uintC,saved_mv_count);
12211 %% #endif
12212 %% #ifdef HAVE_SAVED_value1
12213 %% exportV(object,saved_value1);
12214 %% #endif
12215 %% #ifdef HAVE_SAVED_back_trace
12216 %% exportV(p_backtrace_t,saved_back_trace);
12217 %% #endif
12218 %% #if defined(HAVE_SAVED_STACK)
12219 %% exportV(gcv_object_t*,saved_STACK);
12220 %% #endif
12221 %% export_def(begin_call());
12222 %% export_def(end_call());
12223 %% export_def(begin_callback());
12224 %% export_def(end_callback());
12225
12226 /* Every OS-call (or a sequence thereof) has to be framed with
12227 begin_system_call();
12228 and
12229 end_system_call();
12230 Purpose: The STACK - if it resides in a register -
12231 should be brought to a halfway recent value,
12232 if an interrupt happens during the corresponding timespan.
12233 While a break-semaphore has been set, you don't have to use the macros
12234 because of that. */
12235 #ifdef NO_ASYNC_INTERRUPTS
12236 /* NO_ASYNC_INTERRUPTS: if we don't react to asynchronous Interrupts,
12237 the program can't be interrupted. */
12238 #define begin_system_call()
12239 #define end_system_call()
12240 #else
12241 #define begin_system_call() begin_call()
12242 #define end_system_call() end_call()
12243 #endif
12244 /* The same holds for setjmp()/longjmp(). Here we avoid an unneeded overhead
12245 if at all possible.
12246 You don't have to use these macros when a break-semaphore has been
12247 set. */
12248 #if 0
12249 /* Disassembly of setjmp() and longjmp() shows, that the STACK-register
12250 isn't used arbitrarily. */
12251 #define begin_setjmp_call()
12252 #define end_setjmp_call()
12253 #define begin_longjmp_call()
12254 #define end_longjmp_call()
12255 #elif defined(I80386) && (defined(UNIX_LINUX) || defined(UNIX_GNU))
12256 /* Disassembly of setjmp() shows, that the STACK-register %ebx
12257 isn't used arbitrarily. */
12258 #define begin_setjmp_call()
12259 #define end_setjmp_call()
12260 #define begin_longjmp_call() begin_system_call()
12261 #define end_longjmp_call() end_system_call()
12262 #else
12263 #define begin_setjmp_call() begin_system_call()
12264 #define end_setjmp_call() end_system_call()
12265 #define begin_longjmp_call() begin_system_call()
12266 #define end_longjmp_call() end_system_call()
12267 #endif
12268 /* The same holds for arithmetics-functions that use the STACK_registers.
12269 On I80386 (%ebx) these are SHIFT_LOOPS, MUL_LOOPS, DIV_LOOPS. */
12270 #if defined(I80386) && !defined(NO_ARI_ASM) && defined(HAVE_SAVED_STACK)
12271 #define begin_arith_call() begin_system_call()
12272 #define end_arith_call() end_system_call()
12273 #else
12274 #define begin_arith_call()
12275 #define end_arith_call()
12276 #endif
12277 %% export_def(begin_system_call());
12278 %% export_def(end_system_call());
12279
12280 #if defined(MULTITHREAD)
12281 #define HANDLE_PENDING_INTERRUPTS(thr) \
12282 do { \
12283 if (thr->_pending_interrupts) \
12284 handle_pending_interrupts(); \
12285 } while (0)
12286
12287 /* acknowledge suspend request and wait for resume */
12288 #define GC_SAFE_ACK_SUSPEND_REQUEST_() \
12289 do { \
12290 var clisp_thread_t *thr=current_thread(); \
12291 SET_SP_BEFORE_SUSPEND(thr); /* debug only */ \
12292 spinlock_release(&thr->_gc_suspend_ack); \
12293 thr->_raw_wait_mutex = &thr->_gc_suspend_lock; \
12294 xmutex_raw_lock(&thr->_gc_suspend_lock); \
12295 spinlock_acquire(&thr->_gc_suspend_ack); \
12296 xmutex_raw_unlock(&thr->_gc_suspend_lock); \
12297 thr->_raw_wait_mutex = NULL; \
12298 HANDLE_PENDING_INTERRUPTS(thr); \
12299 } while (0)
12300 /* gc statement is executed in case we have to suspend ourselves
12301 otherwise no_gc statement is executed. */
12302 #define GC_SAFE_POINT_IF(gc,no_gc) \
12303 do{ \
12304 if (spinlock_tryacquire(&(current_thread()->_gc_suspend_request))) \
12305 {GCTRIGGER();gc;} else {no_gc;} \
12306 }while(0)
12307 #define GC_SAFE_POINT() GC_SAFE_POINT_IF(GC_SAFE_ACK_SUSPEND_REQUEST_(), ;)
12308 /* Giving up suspend ack while we are in system call.
12309 So we can be considered suspended for GC. */
12310 #define GC_SAFE_REGION_BEGIN() \
12311 do { \
12312 GCTRIGGER(); \
12313 var clisp_thread_t *thr=current_thread(); \
12314 SET_SP_BEFORE_SUSPEND(thr); /* debug only */ \
12315 spinlock_release(&thr->_gc_suspend_ack); \
12316 }while(0)
12317 /* following two macroses are workarround for differences between WIN32 and
12318 POSIX "signal" handling. With POSIX signals we really interrupt thread,
12319 while with WIN32 threads we should deffer the handling after system call
12320 returns */
12321 #ifdef HAVE_SIGNALS /* POSIX_THREADS */
12322 #define _thr_ptb_(s) s
12323 #define _thr_pta_(s)
12324 #else /* WIN32_THREADS */
12325 #define _thr_ptb_(s)
12326 #define _thr_pta_(s) s
12327 #endif
12328 /* If we cannot get the suspend ack lock again - it means there is/was GC -
12329 so try to wait for it's end if it is not already finished. */
12330 #define GC_SAFE_REGION_END_i(statement) \
12331 do { \
12332 GCTRIGGER(); \
12333 var clisp_thread_t *thr=current_thread(); \
12334 if (!spinlock_tryacquire(&thr->_gc_suspend_ack)) { \
12335 thr->_raw_wait_mutex = &thr->_gc_suspend_lock; \
12336 xmutex_raw_lock(&thr->_gc_suspend_lock); \
12337 spinlock_acquire(&thr->_gc_suspend_ack); \
12338 spinlock_acquire(&thr->_gc_suspend_request); \
12339 xmutex_raw_unlock(&thr->_gc_suspend_lock); \
12340 thr->_raw_wait_mutex = NULL; \
12341 _thr_ptb_(statement); \
12342 } \
12343 _thr_pta_(statement); \
12344 }while(0)
12345 #define GC_SAFE_REGION_END() \
12346 GC_SAFE_REGION_END_i(HANDLE_PENDING_INTERRUPTS(thr))
12347 #define GC_SAFE_REGION_END_WITHOUT_INTERRUPTS() \
12348 GC_SAFE_REGION_END_i(;)
12349
12350 #else /* ! MULTITHREAD */
12351 #define GC_SAFE_POINT_IF(gc,no_gc)
12352 #define GC_SAFE_POINT()
12353 #define GC_SAFE_REGION_BEGIN()
12354 #define GC_SAFE_REGION_END()
12355 #endif
12356
12357 #define begin_blocking_system_call() begin_system_call();GC_SAFE_REGION_BEGIN()
12358 #define end_blocking_system_call() end_system_call();GC_SAFE_REGION_END()
12359
12360 /* when we are in big region that is already marked as system call -
12361 we would like just to enable GC on some blocking calls */
12362 #define begin_blocking_call() GC_SAFE_REGION_BEGIN()
12363 #define end_blocking_call() GC_SAFE_REGION_END()
12364
12365 #define GC_SAFE_CALL(statement) \
12366 do { \
12367 begin_blocking_call(); \
12368 statement; \
12369 end_blocking_call(); \
12370 } while(0)
12371
12372 #define GC_SAFE_SYSTEM_CALL(statement) \
12373 do { \
12374 begin_blocking_system_call(); \
12375 statement; \
12376 end_blocking_system_call(); \
12377 } while(0)
12378
12379 %% export_def(begin_blocking_system_call());
12380 %% export_def(end_blocking_system_call());
12381 %% export_def(begin_blocking_call());
12382 %% export_def(end_blocking_call());
12383 %% export_def(GC_SAFE_CALL(statement));
12384 %% export_def(GC_SAFE_SYSTEM_CALL(statement));
12385
12386 #if defined(HAVE_STACK_OVERFLOW_RECOVERY)
12387 /* Detection of SP-overflow through a Guard-Page or other mechanisms. */
12388 #define NOCOST_SP_CHECK
12389 #else
12390 /* The OS is responsible for the SP.
12391 From where should we get a reasonable value for SP_bound? */
12392 #define NO_SP_CHECK
12393 #endif
12394
12395 /* Tests for SP-overflow.
12396 check_SP(); tests for overflow
12397 check_SP_notUNIX(); dito, except when a temporary overflow doesn't matter */
12398 #define check_SP() if (SP_overflow()) SP_ueber()
12399 #if !(defined(NO_SP_CHECK) || defined(NOCOST_SP_CHECK))
12400 #ifdef SP_DOWN
12401 #define SP_overflow() ( (aint)SP() < (aint)SP_bound )
12402 #endif
12403 #ifdef SP_UP
12404 #define SP_overflow() ( (aint)SP() > (aint)SP_bound )
12405 #endif
12406 #else /* NO_SP_CHECK || NOCOST_SP_CHECK */
12407 #define SP_overflow() false
12408 #ifdef NOCOST_SP_CHECK
12409 #ifdef WIN32_NATIVE
12410 #ifdef SP_DOWN
12411 #define near_SP_overflow() ( (aint)SP() < (aint)SP_bound+0x1000 )
12412 #endif
12413 #ifdef SP_UP
12414 #define near_SP_overflow() ( (aint)SP() > (aint)SP_bound-0x1000 )
12415 #endif
12416 #else
12417 extern bool near_SP_overflow (void);
12418 #endif
12419 #endif
12420 #endif
12421 extern void* SP_bound;
12422 extern _Noreturn void SP_ueber (void);
12423 #ifdef UNIX
12424 #define check_SP_notUNIX()
12425 #else
12426 #define check_SP_notUNIX() check_SP()
12427 #endif
12428
12429 /* Tests for STACK-overflow.
12430 check_STACK(); */
12431 #define check_STACK() if (STACK_overflow()) STACK_ueber()
12432 #ifdef STACK_DOWN
12433 #define STACK_overflow() ( (aint)STACK < (aint)STACK_bound )
12434 #endif
12435 #ifdef STACK_UP
12436 #define STACK_overflow() ( (aint)STACK > (aint)STACK_bound )
12437 #endif
12438 extern void* STACK_bound;
12439 extern void* STACK_start;
12440 extern _Noreturn void STACK_ueber (void);
12441 %% #if notused
12442 %% export_def(check_STACK());
12443 %% export_def(STACK_overflow());
12444 %% export_def(get_space_on_STACK(n));
12445 %% exportV(void*,STACK_bound);
12446 %% exportE(STACK_ueber,(void));
12447 %% #endif
12448
12449 /* Tests, if there are still n Bytes free on the STACK.
12450 get_space_on_STACK(n); */
12451 #ifdef STACK_DOWN
12452 #define get_space_on_STACK(n) \
12453 if ( (aint)STACK < (aint)STACK_bound + (aint)(n) ) STACK_ueber()
12454 #else
12455 #define get_space_on_STACK(n) \
12456 if ( (aint)STACK + (aint)(n) > (aint)STACK_bound ) STACK_ueber()
12457 #endif
12458
12459 /* Exit the LISP-Interpreter
12460 quit();
12461 > final_exitcode: 0 for a normal end, >0 for failure, -signum for a signal */
12462 extern _GL_NORETURN_FUNC void quit (void);
12463 extern int final_exitcode;
12464 /* is used by CONTROL */
12465
12466 /* Error message if an unreachable program part has been reached.
12467 Does not return.
12468 error_notreached(file,line);
12469 > file: Filename (with quotation marks) as constant ASCIZ-String
12470 > line: line number */
12471 extern _Noreturn void error_notreached (const char * file, uintL line);
12472 /* used by all modules */
12473 %% exportE(error_notreached,(const char * file, uintL line));
12474
12475 /* Language that's used to communicate with the user: */
12476 #if defined(GNU_GETTEXT) /* many languages, determined at runtime. */
12477 #ifndef COMPILE_STANDALONE
12478 #include <libintl.h>
12479 #endif
12480 /* Fetch the message translations from a message catalog. */
12481 #ifndef gettext /* Sometimes `gettext' is a macro... */
12482 extern char* gettext (const char * msgid)
12483 #ifdef __GNUC__
12484 __attribute__ ((__format_arg__ (1)))
12485 #endif
12486 ;
12487 #endif
12488 extern const char * clgettext (const char * msgid)
12489 #ifdef __GNUC__
12490 __attribute__ ((__format_arg__ (1)))
12491 #endif
12492 ;
12493 extern const char * clgettextl (const char * msgid)
12494 #ifdef __GNUC__
12495 __attribute__ ((__format_arg__ (1)))
12496 #endif
12497 ;
12498 /* GETTEXT(english_message) fetches the translation of english_message
12499 and returns it in UTF-8 (if ENABLE_UNICODE is defined).
12500 GETTEXTL(english_message) fetches the translation of english_message
12501 and returns it in the locale encoding.
12502 GETTEXT and GETTEXTL are special tags recognized by clisp-xgettext. We
12503 choose English because it's the only language understood by all CLISP
12504 developers. */
12505 #define GETTEXT clgettext
12506 #define GETTEXTL clgettextl
12507 /* the value of *current-language* */
12508 extern object current_language_o (void);
12509 /* init the language and the locale */
12510 extern void init_language (const char*, const char*, bool lisp_error_p);
12511 #else /* static language */
12512 #define GETTEXT(english) english
12513 #define GETTEXTL(english) english
12514 #define current_language_o() S(english)
12515 #endif
12516 %% #if defined(GNU_GETTEXT)
12517 %% puts("#define GNU_GETTEXT");
12518 %% puts("#ifndef COMPILE_STANDALONE");
12519 %% puts("#include <libintl.h>");
12520 %% puts("#endif");
12521 %% exportF(const char *,clgettext,(const char * msgid));
12522 %% export_def(GETTEXT);
12523 %% exportF(object,CLSTEXT,(const char* asciz));
12524 %% #else
12525 %% export_def(GETTEXT(english));
12526 %% emit_define("CLSTEXT","ascii_to_string");
12527 %% #endif
12528
12529 /* Fetch the message translations of a string: "CL String getTEXT"
12530 CLSTEXT(string)
12531 > obj: C string
12532 < result: String
12533 can trigger GC */
12534 extern maygc object CLSTEXT (const char*);
12535
12536 /* Fetch the "translation" of a Lisp object: "CL Object getTEXT"
12537 CLOTEXT(string)
12538 > obj: String
12539 can trigger GC */
12540 extern maygc object CLOTEXT (const char*);
12541
12542 /* Print a Lisp object in Lisp notation relatively directly
12543 through the operating system:
12544 object_out(obj);
12545 can trigger GC */
12546 extern maygc object object_out (object obj);
12547 /* can trigger GC
12548 print the object with label, file name and line number
12549 this can trigger GC, but will save and restore OBJ */
12550 #define OBJECT_OUT(obj,label) \
12551 (printf("[%s:%d] %s: %s:\n",__FILE__,__LINE__,STRING(obj),label), \
12552 fflush(stdout), obj=object_out(obj))
12553 /* print the object to a C stream - not all objects can be handled yet!
12554 non-consing, STACK non-modifying */
12555 extern maygc object nobject_out (FILE* out, object obj);
12556 #define NOBJECT_OUT(obj,label) \
12557 (printf("[%s:%d] %s: %s: ",__FILE__,__LINE__,STRING(obj),label), \
12558 nobject_out(stdout,obj), print("\n"), fflush(stdout))
12559 /* used for debugging purposes */
12560 %% exportF(object,object_out,(object obj));
12561 %% puts("#define OBJECT_OUT(obj,label) (printf(\"[%s:%d] %s: %s:\\n\",__FILE__,__LINE__,STRING(obj),label),obj=object_out(obj))");
12562
12563 /* After allocating memory for an object, add the type infos. */
12564 #ifdef TYPECODES
12565 #define bias_type_pointer_object(bias,type,ptr) type_pointer_object(type,ptr)
12566 #else
12567 #define bias_type_pointer_object(bias,type,ptr) as_object((oint)(ptr)+(bias))
12568 #endif
12569 /* used by SPVW, macros SP_allocate_bit_vector, SP_allocate_string */
12570
12571 /* UP: executes a Garbage Collection
12572 gar_col(level);
12573 > level: if 1, also drop all jitc code
12574 can trigger GC */
12575 extern maygc void gar_col (int level);
12576 /* is used by DEBUG */
12577
12578 /* GC-statistics */
12579 extern uintL gc_count;
12580 extern uintL2 gc_space;
12581 extern internal_time_t gc_time;
12582 /* is used by TIME */
12583
12584 /* UP: allocates a Cons
12585 allocate_cons()
12586 < result: pointer to a new CONS, with CAR and CDR =NIL
12587 can trigger GC */
12588 extern maygc object allocate_cons (void);
12589 /* is used by LIST, SEQUENCE, PACKAGE, EVAL, CONTROL, RECORD,
12590 PREDTYPE, IO, STREAM, PATHNAME, SYMBOL, ARRAY, LISPARIT */
12591 %% exportF(object,allocate_cons,(void));
12592
12593 /* UP: Returns a newly created uninterned symbol with a given Printname.
12594 make_symbol(string)
12595 > string: immutable Simple-String
12596 < result: new symbol with this name, with Home-Package=NIL.
12597 can trigger GC */
12598 extern maygc object make_symbol (object string);
12599 /* is used by PACKAGE, IO, SYMBOL */
12600 %% #if notused
12601 %% exportF(object,make_symbol,(object string));
12602 %% #endif
12603
12604 /* UP: allocates a general vector
12605 allocate_vector(len)
12606 > len: length of the vector
12607 < result: fresh simple general vector (elements are initialized with NIL)
12608 can trigger GC */
12609 extern maygc object allocate_vector (uintL len);
12610 /* is used by ARRAY, IO, EVAL, PACKAGE, CONTROL, HASHTABL */
12611 %% exportF(object,allocate_vector,(uintL len));
12612
12613 /* Function: Allocates a bit/byte vector.
12614 allocate_bit_vector(atype,len)
12615 > uintB atype: Atype_nBit
12616 > uintL len: length (number of n-bit blocks)
12617 < result: fresh simple bit/byte-vector of the given length
12618 can trigger GC */
12619 extern maygc object allocate_bit_vector (uintB atype, uintL len);
12620 /* is used by ARRAY, IO, RECORD, LISPARIT, STREAM, CLX */
12621 %% exportF(object,allocate_bit_vector,(uintB atype, uintL len));
12622
12623 /* Macro: Allocates a 8bit-vector on the stack, with dynamic extent.
12624 { var DYNAMIC_8BIT_VECTOR(obj,len);
12625 ...
12626 FREE_DYNAMIC_8BIT_VECTOR(obj);
12627 }
12628 > uintL len: length (number of bytes)
12629 < object obj: simple-8bit-vector with dynamic extent
12630 (may or may not be heap-allocated, therefore not GC-invariant)
12631 can trigger GC */
12632 #if defined(SPVW_PURE) || defined(NO_ADDRESS_SPACE_ASSUMPTIONS) || ((((STACK_ADDRESS_RANGE << addr_shift) >> garcol_bit_o) & 1) != 0)
12633 /* No way to allocate a Lisp object on the stack. */
12634 #define DYNAMIC_8BIT_VECTOR(objvar,len) \
12635 var uintL objvar##_len = (len); \
12636 var object objvar = TLO(dynamic_8bit_vector); \
12637 TLO(dynamic_8bit_vector) = NIL; \
12638 if (!(simple_bit_vector_p(Atype_8Bit,objvar) && (Sbvector_length(objvar) >= objvar##_len))) \
12639 objvar = allocate_bit_vector(Atype_8Bit,objvar##_len); \
12640 GCTRIGGER1(objvar)
12641 #define FREE_DYNAMIC_8BIT_VECTOR(objvar) \
12642 TLO(dynamic_8bit_vector) = objvar
12643 #else
12644 #define CAN_ALLOCATE_8BIT_VECTORS_ON_C_STACK
12645 /* Careful: Fill GCself with pointers to itself, so that GC will leave
12646 pointers to this object untouched. */
12647 #ifdef TYPECODES
12648 #define DYNAMIC_8BIT_VECTOR(objvar,len) \
12649 DYNAMIC_ARRAY(objvar##_storage,object,ceiling((uintL)(len)+offsetofa(sbvector_,data),sizeof(gcv_object_t))); \
12650 var object objvar = ((Sbvector)objvar##_storage)->GCself = bias_type_pointer_object(varobject_bias,sb8vector_type,(Sbvector)objvar##_storage); \
12651 ((Sbvector)objvar##_storage)->length = (len); \
12652 GCTRIGGER1(objvar)
12653 #else
12654 #define DYNAMIC_8BIT_VECTOR(objvar,len) \
12655 DYNAMIC_ARRAY(objvar##_storage,object,ceiling((uintL)(len)+offsetofa(sbvector_,data)+varobjects_misaligned,sizeof(gcv_object_t))); \
12656 var object* objvar##_address = (object*)((uintP)objvar##_storage | varobjects_misaligned); \
12657 var object objvar = ((Sbvector)objvar##_address)->GCself = bias_type_pointer_object(varobject_bias,sb8vector_type,(Sbvector)objvar##_address); \
12658 ((Sbvector)objvar##_address)->tfl = vrecord_tfl(Rectype_Sb8vector,len); \
12659 GCTRIGGER1(objvar)
12660 #endif
12661 #define FREE_DYNAMIC_8BIT_VECTOR(objvar) \
12662 FREE_DYNAMIC_ARRAY(objvar##_storage)
12663 #endif
12664 /* used by STREAM, PATHNAME */
12665
12666 /* Macro: Wraps a GC-invariant uintB* pointer in a fake simple-8bit-vector.
12667 FAKE_8BIT_VECTOR(ptr)
12668 > uintB* ptr: pointer to GC-invariant data
12669 < gcv_object_t obj: a fake simple-8bit-vector,
12670 with TheSbvector(obj)->data == ptr,
12671 that must *not* be stored in GC-visible locations */
12672 #ifdef TYPECODES
12673 #define FAKE_8BIT_VECTOR(ptr) \
12674 type_pointer_object(0, (const char*)(ptr) - offsetofa(sbvector_,data))
12675 #else
12676 #define FAKE_8BIT_VECTOR(ptr) \
12677 fake_gcv_object((aint)((const char*)(ptr) - offsetofa(sbvector_,data)) + varobject_bias)
12678 #endif
12679
12680 #if !defined(ENABLE_UNICODE) || defined(HAVE_SMALL_SSTRING)
12681 /* UP, provides 8-bit character string
12682 allocate_s8string(len)
12683 > len: length of the string (in characters), must be <= stringsize_limit_1
12684 < result: new 8-bit character simple-string (LISP-object)
12685 can trigger GC */
12686 extern maygc object allocate_s8string (uintL len);
12687 /* used by */
12688 #endif
12689 #if defined(ENABLE_UNICODE) && !defined(HAVE_SMALL_SSTRING)
12690 #define allocate_s8string(len) allocate_s32string(len)
12691 #endif
12692 %% #if !defined(ENABLE_UNICODE)
12693 %% exportF(object,allocate_s8string,(uintL len));
12694 %% #endif
12695
12696 #if !defined(ENABLE_UNICODE) || defined(HAVE_SMALL_SSTRING)
12697 /* UP, provides immutable 8-bit character string
12698 allocate_imm_s8string(len)
12699 > len: length of the string (in characters), must be <= stringsize_limit_1
12700 < result: new immutable 8-bit character simple-string (LISP-object)
12701 can trigger GC */
12702 extern maygc object allocate_imm_s8string (uintL len);
12703 /* used by */
12704 #endif
12705
12706 #ifdef HAVE_SMALL_SSTRING
12707 /* UP, provides 16-bit character string
12708 allocate_s16string(len)
12709 > len: length of the string (in characters), must be <= stringsize_limit_1
12710 < result: new 16-bit character simple-string (LISP-object)
12711 can trigger GC */
12712 extern maygc object allocate_s16string (uintL len);
12713 /* used by */
12714 #endif
12715 #if defined(ENABLE_UNICODE) && !defined(HAVE_SMALL_SSTRING)
12716 #define allocate_s16string(len) allocate_s32string(len)
12717 #endif
12718
12719 #ifdef HAVE_SMALL_SSTRING
12720 /* UP, provides immutable 16-bit character string
12721 allocate_imm_s16string(len)
12722 > len: length of the string (in characters), must be <= stringsize_limit_1
12723 < result: new immutable 16-bit character simple-string (LISP-object)
12724 can trigger GC */
12725 extern maygc object allocate_imm_s16string (uintL len);
12726 /* used by */
12727 #endif
12728
12729 #ifdef ENABLE_UNICODE
12730 /* UP, provides 32-bit character string
12731 allocate_s32string(len)
12732 > len: length of the string (in characters), must be <= stringsize_limit_1
12733 < result: new 32-bit character simple-string (LISP-object)
12734 can trigger GC */
12735 extern maygc object allocate_s32string (uintL len);
12736 #endif
12737 %% #ifdef ENABLE_UNICODE
12738 %% exportF(object,allocate_s32string,(uintL len));
12739 %% #endif
12740
12741 #ifdef ENABLE_UNICODE
12742 /* UP, provides immutable 32-bit character string
12743 allocate_imm_s32string(len)
12744 > len: length of the string (in characters), must be <= stringsize_limit_1
12745 < result: new immutable 32-bit character simple-string (LISP-object)
12746 can trigger GC */
12747 extern maygc object allocate_imm_s32string (uintL len);
12748 #endif
12749
12750 /* UP: allocates String
12751 allocate_string(len)
12752 > len: length of the Strings (in Characters), must be <= stringsize_limit_1
12753 < result: new Normal-Simple-String (LISP-object)
12754 can trigger GC */
12755 #ifdef ENABLE_UNICODE
12756 #define allocate_string(len) allocate_s32string(len)
12757 #else
12758 #define allocate_string(len) allocate_s8string(len)
12759 #endif
12760 /* is used by ARRAY, CHARSTRG, STREAM, PATHNAME */
12761 %% export_def(allocate_string(len));
12762
12763 /* Macro: Allocates a normal string on the stack, with dynamic extent.
12764 { var DYNAMIC_STRING(obj,len);
12765 ...
12766 FREE_DYNAMIC_STRING(obj);
12767 }
12768 > uintL len: length (number of characters)
12769 < object obj: normal-simple-string with dynamic extent
12770 (may or may not be heap-allocated, therefore not GC-invariant)
12771 can trigger GC */
12772 #if defined(SPVW_PURE) || defined(NO_ADDRESS_SPACE_ASSUMPTIONS) || ((((STACK_ADDRESS_RANGE << addr_shift) >> garcol_bit_o) & 1) != 0)
12773 /* No way to allocate a Lisp object on the stack. */
12774 #define DYNAMIC_STRING(objvar,len) \
12775 var uintL objvar##_len = (len); \
12776 var object objvar = TLO(dynamic_string); \
12777 TLO(dynamic_string) = NIL; \
12778 if (!(simple_string_p(objvar) && (Sstring_length(objvar) >= objvar##_len))) { \
12779 if (objvar##_len > stringsize_limit_1) \
12780 error_stringsize(objvar##_len); \
12781 objvar = allocate_string(objvar##_len); \
12782 } \
12783 GCTRIGGER1(objvar)
12784 #define FREE_DYNAMIC_STRING(objvar) \
12785 TLO(dynamic_string) = objvar;
12786 #else
12787 #define CAN_ALLOCATE_STRINGS_ON_C_STACK
12788 /* Careful: Fill GCself with pointers to itself, so that GC will leave
12789 pointers to this object untouched. */
12790 #ifdef ENABLE_UNICODE
12791 #define DYNAMIC_STRING(objvar,len) \
12792 DYNAMIC_ARRAY(objvar##_storage,object,ceiling((uintL)(len)*sizeof(chart)+offsetofa(s32string_,data)+varobjects_misaligned,sizeof(gcv_object_t))); \
12793 var object* objvar##_address = (object*)((uintP)objvar##_storage | varobjects_misaligned); \
12794 var object objvar = ((Sstring)objvar##_address)->GCself = bias_type_pointer_object(varobject_bias,sstring_type,(Sstring)objvar##_address); \
12795 ((Sstring)objvar##_address)->tfl = sstring_tfl(Sstringtype_32Bit,0,0,len); \
12796 GCTRIGGER1(objvar)
12797 #else
12798 #define DYNAMIC_STRING(objvar,len) \
12799 DYNAMIC_ARRAY(objvar##_storage,object,ceiling((uintL)(len)*sizeof(chart)+offsetofa(s8string_,data)+varobjects_misaligned,sizeof(gcv_object_t))); \
12800 var object* objvar##_address = (object*)((uintP)objvar##_storage | varobjects_misaligned); \
12801 var object objvar = ((Sstring)objvar##_address)->GCself = bias_type_pointer_object(varobject_bias,sstring_type,(Sstring)objvar##_address); \
12802 ((Sstring)objvar##_address)->tfl = sstring_tfl(Sstringtype_8Bit,0,0,len); \
12803 GCTRIGGER1(objvar)
12804 #endif
12805 #define FREE_DYNAMIC_STRING(objvar) \
12806 FREE_DYNAMIC_ARRAY(objvar##_storage)
12807 #endif
12808 /* used by LISPARIT */
12809
12810 /* UP: allocates an immutable String
12811 allocate_imm_string(len)
12812 > len: length of the String (in Characters)
12813 < result: new immutable Normal-Simple-String (LISP-object)
12814 can trigger GC */
12815 #ifdef ENABLE_UNICODE
12816 #define allocate_imm_string(len) allocate_imm_s32string(len)
12817 #else
12818 #define allocate_imm_string(len) allocate_imm_s8string(len)
12819 #endif
12820 /* is used by CHARSTRG */
12821
12822 #ifdef HAVE_SMALL_SSTRING
12823 /* UP: Changes the allocation of a Small-String to an Sistring, while
12824 copying the contents to a fresh normal string.
12825 reallocate_small_string(string)
12826 > string: a nonempty Small-String
12827 > newtype: new wider string type, Sstringtype_16Bit or Sstringtype_32Bit
12828 < result: an Sistring pointing to a wider String
12829 can trigger GC */
12830 extern maygc object reallocate_small_string (object string, uintB newtype);
12831 /* is used by ARRAY */
12832 #endif
12833
12834 /* Attempts to reallocate a simple-string, for debugging purposes.
12835 DBGREALLOC(string); */
12836 #if defined(DEBUG_SMALL_SSTRING) && defined(HAVE_SMALL_SSTRING)
12837 #define DBGREALLOC(string) \
12838 if (simple_string_p(string) && !sstring_reallocatedp(TheSstring(string)) \
12839 && !sstring_immutable(TheSstring(string)) \
12840 && sstring_eltype(TheSstring(string)) != Sstringtype_32Bit \
12841 && sstring_length(TheSstring(string)) > 0) \
12842 string = reallocate_small_string(string,sstring_eltype(TheSstring(string))+1)/*;*/
12843 #else
12844 #define DBGREALLOC(string) (void)0 /*nop*/
12845 #endif
12846
12847 /* UP: allocates indirect array
12848 allocate_iarray(flags,rank,type)
12849 > uintB flags: Flags
12850 > uintC (actually uintWC) rank: rank
12851 > tint type: Typinfo
12852 < result: LISP-object Array
12853 can trigger GC */
12854 extern maygc object allocate_iarray (uintB flags, uintC rank, tint type);
12855 /* is used by ARRAY, IO */
12856
12857 /* UP: allocates Long-Record
12858 allocate_lrecord(rectype,reclen,type)
12859 > sintB rectype: further type-info
12860 > uintL reclen: length
12861 > tint type: type-info
12862 < result: LISP-object Record (elements are initialized with NIL)
12863 can trigger GC */
12864 #ifdef TYPECODES
12865 extern maygc object allocate_lrecord (uintB rectype, uintL reclen, tint type);
12866 #else
12867 #define allocate_lrecord(rectype,reclen,type) /* ignore type */ \
12868 allocate_lrecord_(rectype,reclen)
12869 extern object allocate_lrecord_ (uintB rectype, uintL reclen);
12870 #endif
12871 /* is used by WEAK */
12872
12873 /* UP: allocates Simple-Record
12874 allocate_srecord(flags,rectype,reclen,type)
12875 > uintB flags: Flags
12876 > sintB rectype: further type-info
12877 > uintC (actually uintW) reclen: length
12878 > tint type: type-info
12879 < result: LISP-object Record (elements are initialized with NIL)
12880 can trigger GC */
12881 #ifdef TYPECODES
12882 #define allocate_srecord(flags,rectype,reclen,type) \
12883 allocate_srecord_( \
12884 (BIG_ENDIAN_P ? (uintW)(flags)+((uintW)(uintB)(rectype)<<intBsize) \
12885 : ((uintW)(flags)<<intBsize)+(uintW)(uintB)(rectype)),\
12886 reclen, \
12887 type)
12888 extern maygc object allocate_srecord_ (uintW flags_rectype, uintC reclen, tint type);
12889 #else
12890 #define allocate_srecord(flags,rectype,reclen,type) /* ignore type */ \
12891 allocate_srecord_(((uintW)(flags)<<8)+(uintW)(uintB)(rectype),reclen)
12892 extern maygc object allocate_srecord_ (uintW flags_rectype, uintC reclen);
12893 #endif
12894 /* is used by RECORD, EVAL */
12895
12896 /* UP: allocates Extended-Record
12897 allocate_xrecord(flags,rectype,reclen,recxlen,type)
12898 > uintB flags: Flags
12899 > sintB rectype: further type-info
12900 > uintC (actually uintB) reclen: length
12901 > uintC (actually uintB) recxlen: extra-length
12902 > tint type: Typinfo
12903 < result: LISP-object Record (elements are initialized with NIL resp. 0)
12904 can trigger GC */
12905 #ifdef TYPECODES
12906 #define allocate_xrecord(flags,rectype,reclen,recxlen,type) \
12907 allocate_xrecord_( \
12908 (BIG_ENDIAN_P ? (uintW)(flags)+((uintW)(uintB)(rectype)<<intBsize) \
12909 : ((uintW)(flags)<<intBsize)+(uintW)(uintB)(rectype)),\
12910 reclen, \
12911 recxlen, \
12912 type)
12913 extern maygc object allocate_xrecord_ (uintW flags_rectype, uintC reclen, uintC recxlen, tint type);
12914 #else
12915 #define allocate_xrecord(flags,rectype,reclen,recxlen,type) \
12916 allocate_xrecord_((((uintW)(flags)<<8)+(uintW)(uintB)(rectype)),reclen,recxlen)
12917 extern maygc object allocate_xrecord_ (uintW flags_rectype, uintC reclen, uintC recxlen);
12918 #endif
12919 /* is used by */
12920
12921 /* UP: allocates Closure
12922 allocate_closure(reclen)
12923 > uintC reclen: length
12924 < result: LISP-object Closure (elements are initialized with NIL) */
12925 #define allocate_closure(reclen,flags) \
12926 allocate_srecord(flags,Rectype_Closure,reclen,closure_type)
12927 /* is used by EVAL, RECORD */
12928
12929 /* copy a section of memory */
12930 #define copy_mem_b(dest,orig,len) /* bytes */ \
12931 do { var char* newptr = (char*)(dest); \
12932 var const char* oldptr = (const char*)(orig); \
12933 var uintL count; \
12934 var uintL leng = (len); \
12935 dotimespL(count,leng,{ *newptr++ = *oldptr++; }); \
12936 } while(0)
12937 #define copy_mem_o(dest,orig,len) /* objects */ \
12938 do { var gcv_object_t* newptr = (dest); \
12939 var const gcv_object_t* oldptr = (orig); \
12940 var uintC count; \
12941 var uintC leng = (len); \
12942 dotimespC(count,leng,{ *newptr++ = *oldptr++; }); \
12943 } while(0)
12944 #if 0 /* the libc alternative turns out to be ~3-5% slower */
12945 #define copy_mem_b(dest,orig,len) \
12946 do { begin_system_call(); memcpy(dest,orig,len); \
12947 end_system_call(); } while(0)
12948 #define copy_mem_o(dest,orig,len) \
12949 do { begin_system_call(); memcpy(dest,orig,(len)*sizeof(gcv_object_t)); \
12950 end_system_call(); } while(0)
12951 #endif
12952
12953 /* Copying a compiled closure:
12954 newclos = allocate_cclosure_copy(oldclos);
12955 can trigger GC */
12956 #define allocate_cclosure_copy(oldclos) \
12957 allocate_closure(Cclosure_length(oldclos),Closure_flags(oldclos))
12958 /* do_cclosure_copy(newclos,oldclos); */
12959 #define do_cclosure_copy(newclos,oldclos) \
12960 copy_mem_o(((Srecord)TheCclosure(newclos))->recdata, \
12961 ((Srecord)TheCclosure(oldclos))->recdata, \
12962 Cclosure_length(oldclos))
12963 /* is used by EVAL, IO, RECORD */
12964
12965 /* UP: allocates Structure
12966 allocate_structure(reclen)
12967 > uintC reclen: length
12968 < result: LISP-Object Structure (Elements are initialized with NIL)
12969 can trigger GC */
12970 #ifdef case_structure
12971 #define allocate_structure(reclen) \
12972 allocate_srecord(0,Rectype_Structure,reclen,structure_type)
12973 #else
12974 #define allocate_structure(reclen) \
12975 allocate_srecord(0,Rectype_Structure,reclen,orecord_type)
12976 #endif
12977 /* is used by RECORD */
12978
12979 /* UP: allocates Stream
12980 allocate_stream(streamflags,streamtype,reclen,recxlen)
12981 > uintB streamflags: Flags
12982 > uintB streamtype: further type-info
12983 > uintC reclen: length in objects
12984 > uintC recxlen: extra-length in bytes
12985 < result: LISP-object Stream (elements are initialized with NIL)
12986 can trigger GC */
12987 extern maygc object allocate_stream (uintB streamflags, uintB streamtype, uintC reclen, uintC recxlen);
12988 /* is used by STREAM */
12989
12990 /* UP: allocates Package
12991 allocate_package()
12992 < result: LISP-object Package
12993 can trigger GC */
12994 #define allocate_package() \
12995 allocate_xrecord(0,Rectype_Package,package_length,0,orecord_type)
12996 /* is used by PACKAGE */
12997
12998 /* UP: allocates Hash-Table
12999 allocate_hash_table()
13000 < result: LISP-object Hash-Table
13001 can trigger GC */
13002 #define allocate_hash_table() \
13003 allocate_xrecord(0,Rectype_Hashtable,hashtable_length,hashtable_xlength, \
13004 orecord_type)
13005 /* is used by */
13006
13007 /* UP: allocates Readtable
13008 allocate_readtable()
13009 < result: LISP-object Readtable
13010 can trigger GC */
13011 #define allocate_readtable() \
13012 allocate_xrecord(0,Rectype_Readtable,readtable_length,0,orecord_type)
13013 /* is used by IO */
13014
13015 /* UP: allocates Pathname
13016 allocate_pathname()
13017 < result: LISP-object Pathname
13018 can trigger GC */
13019 #define allocate_pathname() \
13020 allocate_xrecord(0,Rectype_Pathname,pathname_length,0,orecord_type)
13021 /* is used by PATHNAME */
13022
13023 /* UP: allocates Logical Pathname
13024 allocate_logpathname()
13025 < result: LISP-object Logical Pathname
13026 can trigger GC */
13027 #define allocate_logpathname() \
13028 allocate_xrecord(0,Rectype_Logpathname,logpathname_length,0,orecord_type)
13029 /* is used by PATHNAME */
13030
13031 /* UP: allocates Random-State
13032 allocate_random_state()
13033 < result: LISP-object Random-State
13034 can trigger GC */
13035 #define allocate_random_state() \
13036 allocate_xrecord(0,Rectype_Random_State,random_state_length,0,orecord_type)
13037 /* is used by IO, LISPARIT */
13038
13039 /* UP: allocates Byte
13040 allocate_byte()
13041 < result: LISP-object Byte
13042 can trigger GC */
13043 #define allocate_byte() \
13044 allocate_xrecord(0,Rectype_Byte,byte_length,0,orecord_type)
13045 /* is used by LISPARIT */
13046
13047 /* UP: allocates Fsubr
13048 allocate_fsubr()
13049 < result: LISP-object Fsubr
13050 can trigger GC */
13051 #define allocate_fsubr() \
13052 allocate_xrecord(0,Rectype_Fsubr,fsubr_length,fsubr_xlength,orecord_type)
13053 /* is used by SPVW */
13054
13055 /* UP: allocates Load-time-Eval
13056 allocate_loadtimeeval()
13057 < result: LISP-object Load-time-Eval
13058 can trigger GC */
13059 #define allocate_loadtimeeval() \
13060 allocate_xrecord(0,Rectype_Loadtimeeval,loadtimeeval_length,0,orecord_type)
13061 /* is used by IO, RECORD */
13062
13063 /* UP: allocates Symbol-Macro
13064 allocate_symbolmacro()
13065 < result: LISP-object Symbol-Macro
13066 can trigger GC */
13067 #define allocate_symbolmacro() \
13068 allocate_xrecord(0,Rectype_Symbolmacro,symbolmacro_length,0,orecord_type)
13069 /* is used by CONTROL, RECORD */
13070
13071 /* UP: allocates Global-Symbol-Macro
13072 allocate_globalsymbolmacro()
13073 < result: LISP-object Global-Symbol-Macro
13074 can trigger GC */
13075 #define allocate_globalsymbolmacro() \
13076 allocate_xrecord(0,Rectype_GlobalSymbolmacro,globalsymbolmacro_length,0,orecord_type)
13077 /* is used by RECORD */
13078
13079 /* UP: allocates a Macro
13080 allocate_macro()
13081 < result: a fresh Macro
13082 can trigger GC */
13083 #define allocate_macro() \
13084 allocate_xrecord(0,Rectype_Macro,macro_length,0,orecord_type)
13085 /* is used by RECORD */
13086
13087 /* UP: allocates a FunctionMacro
13088 allocate_functionmacro()
13089 < result: a fresh FunctionMacro
13090 can trigger GC */
13091 #define allocate_functionmacro() \
13092 allocate_xrecord(0,Rectype_FunctionMacro,functionmacro_length,0,orecord_type)
13093 /* is used by RECORD */
13094
13095 /* UP: allocates a BigReadLabel
13096 allocate_big_read_label()
13097 < result: a fresh BigReadLabel
13098 can trigger GC */
13099 #define allocate_big_read_label() \
13100 allocate_xrecord(0,Rectype_BigReadLabel,bigreadlabel_length,0,orecord_type)
13101 /* is used by IO */
13102
13103 /* UP: allocates an Encoding
13104 allocate_encoding()
13105 < result: a fresh Encoding
13106 can trigger GC */
13107 #define allocate_encoding() \
13108 allocate_xrecord(0,Rectype_Encoding,encoding_length,encoding_xlength,orecord_type)
13109 /* is used by ENCODING */
13110
13111 #ifdef FOREIGN
13112 /* UP: allocates a foreign-pointer packing
13113 allocate_fpointer(foreign)
13114 > foreign: of Type FOREIGN
13115 < result: LISP-object, contains the foreign pointer
13116 can trigger GC */
13117 extern maygc object allocate_fpointer (FOREIGN foreign);
13118 /* used by FFI & modules */
13119 #endif
13120 %% #ifdef FOREIGN
13121 %% exportF(object,allocate_fpointer,(FOREIGN foreign));
13122 %% #endif
13123
13124 /* UP: allocates foreign address
13125 allocate_faddress()
13126 < result: LISP-object foreign address
13127 can trigger GC */
13128 #define allocate_faddress() \
13129 allocate_xrecord(0,Rectype_Faddress,faddress_length,faddress_xlength,orecord_type)
13130 /* is used by FOREIGN */
13131
13132 /* UP: allocates foreign variable
13133 allocate_fvariable()
13134 < result: LISP-object foreign variable
13135 can trigger GC */
13136 #define allocate_fvariable() \
13137 allocate_xrecord(0,Rectype_Fvariable,fvariable_length,0,orecord_type)
13138 /* is used by FOREIGN */
13139
13140 /* UP: allocates foreign function
13141 allocate_ffunction()
13142 < result: LISP-object foreign function
13143 can trigger GC */
13144 #define allocate_ffunction() \
13145 allocate_xrecord(0,Rectype_Ffunction,ffunction_length,0,orecord_type)
13146 /* is used by FOREIGN */
13147
13148 /* UP: allocates finalizer
13149 allocate_finalizer()
13150 < result: LISP-object finalizer
13151 can trigger GC */
13152 #define allocate_finalizer() \
13153 allocate_xrecord(0,Rectype_Finalizer,finalizer_length,0,orecord_type)
13154 /* is used by RECORD */
13155
13156 /* UP: allocates Socket-Server
13157 allocate_socket_server()
13158 < result: LISP-object Socket-Server */
13159 #ifdef SOCKET_STREAMS
13160 #define allocate_socket_server() \
13161 allocate_xrecord(0,Rectype_Socket_Server,socket_server_length,0,orecord_type)
13162 #endif
13163
13164 #ifdef YET_ANOTHER_RECORD
13165 /* UP: allocates Yetanother
13166 allocate_yetanother()
13167 < result: LISP-object Yetanother
13168 can trigger GC */
13169 #define allocate_yetanother() \
13170 allocate_xrecord(0,Rectype_Yetanother,yetanother_length,0,orecord_type)
13171 /* is used by */
13172 #endif
13173
13174 /* UP: allocates handle
13175 allocate_handle(handle)
13176 < result: LISP-object, that contains handle
13177 can trigger GC */
13178 #ifdef FOREIGN_HANDLE
13179 /* can trigger GC */
13180 extern maygc object allocate_handle (Handle handle);
13181 #else
13182 #define allocate_handle(handle) fixnum((uintL)(handle))
13183 #endif
13184 %% #if defined(FOREIGN_HANDLE)
13185 %% exportF(object,allocate_handle,(Handle handle));
13186 %% #else
13187 %% export_def(allocate_handle(handle));
13188 %% #endif
13189
13190 /* UP: allocates Bignum
13191 allocate_bignum(len,sign)
13192 > uintC (actually uintWC) len: length of the number (in Digits)
13193 > sintB sign: flag for sign (0 = +, -1 = -)
13194 < result: new Bignum (LISP-object)
13195 can trigger GC */
13196 extern maygc object allocate_bignum (uintC len, sintB sign);
13197 /* is used by LISPARIT, STREAM */
13198
13199 /* UP: allocates Single-Float
13200 allocate_ffloat(value)
13201 > ffloat value: value (Bit 31 = sign)
13202 < result: new Single-Float (LISP-object)
13203 can trigger GC */
13204 extern maygc object allocate_ffloat (ffloat value);
13205 /* is used by LISPARIT */
13206
13207 /* UP: allocates Double-Float */
13208 #ifdef intQsize
13209 /* allocate_dfloat(value)
13210 > dfloat value: value (Bit 63 = sign)
13211 < result: new Double-Float (LISP-object)
13212 can trigger GC */
13213 extern maygc object allocate_dfloat (dfloat value);
13214 #else
13215 /* allocate_dfloat(semhi,mlo)
13216 > semhi,mlo: value (Bit 31 of semhi = sign )
13217 < result: new Double-Float (LISP-object)
13218 can trigger GC */
13219 extern maygc object allocate_dfloat (uint32 semhi, uint32 mlo);
13220 #endif
13221 /* is used by LISPARIT */
13222
13223 /* UP: allocates Long-Float
13224 allocate_lfloat(len,expo,sign)
13225 > uintC (actually uintWC) len: length of the mantissa (in Digits)
13226 > uintL expo: exponent
13227 > signean sign: sign (0 = +, -1 = -)
13228 < result: new Long-Float, without mantissa
13229 It will only be a LISP-object when the mantissa has been entered!
13230 can trigger GC */
13231 extern maygc object allocate_lfloat (uintC len, uintL expo, signean sign);
13232 /* is used by LISPARIT */
13233
13234 /* UP: makes a rational number
13235 make_ratio(num,den)
13236 > object num: numerator (has to be an integer /= 0, relatively prime to den)
13237 > object den: denominator (has to be an Integer > 1)
13238 < result: rational number
13239 can trigger GC */
13240 extern maygc object make_ratio (object num, object den);
13241 /* is used by LISPARIT */
13242
13243 /* UP: makes a complex number
13244 make_complex(real,imag)
13245 > real: real part (has to be a real number)
13246 > imag: imaginary part (has to be a real number /= Fixnum 0)
13247 < result: complex number
13248 can trigger GC */
13249 extern maygc object make_complex (object real, object imag);
13250 /* is used by LISPARIT */
13251
13252 #ifdef MULTITHREAD
13253 /* allocate a thread object
13254 allocate_thread()
13255 > *name_ : thread name (usually a symbol)
13256 < result : new thread object (not started)
13257 can trigger GC */
13258 global maygc object allocate_thread (gcv_object_t *name_);
13259 /* used by ZTHREAD */
13260
13261 /* allocate a mutex object and inserts it in O(all_mutexes)
13262 allocate_mutex()
13263 > *name_ : mutex name (usually a symbol)
13264 < result : new mutex object (initialized)
13265 can trigger GC */
13266 global maygc object allocate_mutex (gcv_object_t *name_);
13267 /* used by ZTHREAD */
13268
13269 /* allocate an exemption object and inserts it in O(all_exemptions)
13270 allocate_exemption()
13271 > *name_ : exemption name (usually a symbol)
13272 < result : new exemption object (initialized)
13273 can trigger GC */
13274 global maygc object allocate_exemption (gcv_object_t *name_);
13275 /* used by ZTHREAD */
13276 #endif
13277
13278 /* Adds a freshly allocated object to the list of weak pointers.
13279 activate_weak(obj);
13280 > obj: A fresh but filled object of type Rectype_Weak* */
13281 extern void activate_weak (object obj);
13282 /* is used by WEAK */
13283
13284 /* True if we are in the process of quitting */
13285 extern bool quit_on_signal_in_progress;
13286 /* used by ERROR */
13287
13288 /* UP: return the length of the ASCIZ-String
13289 asciz_length(asciz)
13290 > char* asciz: ASCIZ-String
13291 (added with a NULL byte determines the end of string)
13292 < result: Length of the character sequence (without the NULL byte) */
13293 extern uintL asciz_length (const char * asciz);
13294 #if defined(GNU) && (SAFETY < 2)
13295 #ifdef HAVE_BUILTIN_STRLEN
13296 #define asciz_length(a) ((uintL)__builtin_strlen(a))
13297 #endif
13298 #endif
13299 #ifndef asciz_length
13300 #ifdef HAVE_SAVED_STACK
13301 /* can not use strlen() instead of asciz_length() , because this would
13302 require a begin_system_call()/end_system_call() . */
13303 #else
13304 /* let us presume, that strlen() is implemented efficiently. */
13305 #define asciz_length(a) ((uintL)strlen(a))
13306 #endif
13307 #endif
13308 /* is used by SPVW */
13309 %% #ifdef asciz_length
13310 %% export_def(asciz_length(a));
13311 %% #else
13312 %% exportF(uintL,asciz_length,(const char * asciz));
13313 %% #endif
13314
13315 /* UP: Compares two ASCIZ-Strings.
13316 asciz_equal(asciz1,asciz2)
13317 > char* asciz1: first ASCIZ-String
13318 > char* asciz2: second ASCIZ-String
13319 < result: true if the number-sequences are equal */
13320 extern bool asciz_equal (const char * asciz1, const char * asciz2);
13321 /* is used by STREAM, ENCODING, SPVW, CHARSTRG */
13322 %% #if notused
13323 %% exportF(bool,asciz_equal,(const char * asciz1, const char * asciz2));
13324 %% #endif
13325
13326 /* UP: check that the first ASCIZ-string starts with the second one.
13327 asciz_startswith(asciz,prefix) === (strncmp(asciz,prefix,strlen(prefix))==0)
13328 > char* asciz: first ASCIZ-string
13329 > char* prefix: second ASCIZ-string
13330 < result: true if both sequences are equal up to the length of the second */
13331 extern bool asciz_startswith (const char *asciz, const char *prefix);
13332 /* used by PATHNAME */
13333 %% #if notused
13334 %% exportF(bool,asciz_startswith,(const char *asciz, const char *prefix));
13335 %% #endif
13336
13337 /* allocate memory and check for success */
13338 extern void* clisp_malloc (size_t size);
13339 /* used by FOREIGN and modules */
13340 %% exportF(void*,clisp_malloc,(size_t size));
13341
13342 /* reallocate memory and check for success */
13343 extern void* clisp_realloc (void* ptr, size_t size);
13344 /* used by modules */
13345 %% exportF(void*,clisp_realloc,(void *ptr, size_t size));
13346
13347 /* UP: Returns a Table of all circularities within an Object.
13348 (A circularity is a Sub-Object contained within this Object,
13349 which has more than one access-path to it.)
13350 get_circularities(obj,pr_array,pr_closure)
13351 > object obj: Object
13352 > bool pr_array: Flag, if Array-Elements recursively count as Sub-Objects
13353 > bool pr_closure: Flag, if Closure-Components recursively count as Sub-Objects
13354 < result: T if Stack-Overflow occurred,
13355 NIL if no circularities available,
13356 #(0 ...) an (n+1)-element Vector, that contains the number 0 and the n
13357 circularities as Elements, n>0.
13358 can trigger GC */
13359 extern maygc object get_circularities (object obj, bool pr_array, bool pr_closure);
13360 /* is used by IO */
13361
13362 /* UP: unentangles #n# - References in Object *ptr with help from Aliste alist.
13363 > *ptr : Object
13364 > alist : Alist (Read-Label --> Object, to be substituted)
13365 < *ptr : Object with unentangled References
13366 < result : erroneous Reference or nullobj if everything is OK */
13367 extern object subst_circ (gcv_object_t* ptr, object alist);
13368 /* is used by IO */
13369
13370 /* UP: Runs through the whole memory, and calls for each
13371 Object obj: fun(arg,obj,bytelen) .
13372 map_heap_objects(fun,arg);
13373 > fun: C-Function
13374 > arg: arbitrary given Argument */
13375 typedef void map_heap_function_t (void* arg, object obj, uintM bytelen);
13376 extern void map_heap_objects (map_heap_function_t* fun, void* arg);
13377 /* is used by PREDTYPE */
13378
13379 /* UP: returns the size (in Bytes) of an object.
13380 varobject_bytelength(obj)
13381 > obj: Heap-object with variable length
13382 < result; the number of bytes occupied by it (header included) */
13383 extern uintM varobject_bytelength (object obj);
13384 /* is used by PREDTYPE */
13385
13386 /* Break-Semaphores
13387 As long as a Break-Semaphore is set, the Lisp-Program can not
13388 be interrupted. Purpose:
13389 - backup of Consistencies,
13390 - Non-reentrant Data-Structures (like e.g. DTA_buffer) can not
13391 be used recursively. */
13392 typedef union {uintB einzeln[8]; uintL gesamt[2]; } break_sems_;
13393
13394 #define break_sem_0 break_sems.einzeln[0]
13395 #define break_sem_1 break_sems.einzeln[1]
13396 #define break_sem_2 break_sems.einzeln[2]
13397 #define break_sem_3 break_sems.einzeln[3]
13398 #define break_sem_4 break_sems.einzeln[4]
13399 #define break_sem_5 break_sems.einzeln[5]
13400 #define break_sem_6 break_sems.einzeln[6]
13401 #define break_sem_7 break_sems.einzeln[7]
13402 /* is used by SPVW, Macros set/clr_break_sem_0/1/2/3/4/5/6/7 */
13403
13404 /* MULTITHREAD:
13405 Semaphores are not used. Async signals may come only on two
13406 points - immediately after the world is resumed and when
13407 inside blocking system calls. So there is no way to
13408 interrupt critical initialization of lisp objects.
13409 Of course it is possible a thread to access others threads
13410 objects - but this is responsibility of the threads themsleves
13411 not of the runtime (and break_sems cannot prevent it as well).
13412 */
13413 #if defined(MULTITHREAD)
13414 #define SEMA_(statement)
13415 #define SEGV_SEMA_(statement)
13416 #define break_sems_cleared()
13417 #define clear_break_sems()
13418 #else /* !MULTITHREAD*/
13419 extern break_sems_ break_sems;
13420 #define SEMA_(statement) (statement)
13421 #define SEGV_SEMA_(statement) SEMA_(statement)
13422 /* Tests whether all break-semaphores have been cleared. */
13423 #define break_sems_cleared() \
13424 (break_sems.gesamt[0] == 0 && break_sems.gesamt[1] == 0)
13425 /* is used by SPVW, WIN32AUX */
13426 /* clears all break-semaphores. Very dangerous! */
13427 #define clear_break_sems() \
13428 (break_sems.gesamt[0] = 0, break_sems.gesamt[1] = 0)
13429 /* is used by SPVW */
13430 #endif
13431
13432 /* sets break-semaphore 0 and thus protects against interrupts
13433 set_break_sem_0(); */
13434 #define set_break_sem_0() SEGV_SEMA_(break_sem_0 = 1)
13435 /* is used by SPVW */
13436
13437 /* clears the break-semaphore 0 and thus releases the interrupts
13438 clr_break_sem_0(); */
13439 #define clr_break_sem_0() SEGV_SEMA_(break_sem_0 = 0)
13440 /* is used by SPVW */
13441
13442 /* sets break-semaphore 1 and thus protects against interrupts
13443 set_break_sem_1(); */
13444 #define set_break_sem_1() SEMA_(break_sem_1 = 1)
13445 /* is used by SPVW, ARRAY */
13446
13447 /* clears the break-semaphore 1 and thus releases the interrupts
13448 clr_break_sem_1(); */
13449 #define clr_break_sem_1() SEMA_(break_sem_1 = 0)
13450 /* is used by SPVW, ARRAY */
13451
13452 /* sets break-semaphore 2 and thus protects against interrupts
13453 set_break_sem_2(); */
13454 #define set_break_sem_2() SEMA_(break_sem_2 = 1)
13455 /* is used by PACKAGE, HASHTABL */
13456
13457 /* clears the break-semaphore 2 and thus releases the interrupts
13458 clr_break_sem_2(); */
13459 #define clr_break_sem_2() SEMA_(break_sem_2 = 0)
13460 /* is used by PACKAGE, HASHTABL */
13461
13462 /* sets break-semaphore 3 and thus protects against interrupts
13463 set_break_sem_3(); */
13464 #define set_break_sem_3() SEMA_(break_sem_3 = 1)
13465 /* is used by PACKAGE */
13466
13467 /* clears the break-semaphore 3 and thus releases the interrupts
13468 clr_break_sem_3(); */
13469 #define clr_break_sem_3() SEMA_(break_sem_3 = 0)
13470 /* is used by PACKAGE */
13471
13472 /* sets break-semaphore 4 and thus protects against interrupts
13473 set_break_sem_4(); */
13474 #define set_break_sem_4() SEMA_(break_sem_4 = 1)
13475 /* is used by STREAM, PATHNAME */
13476
13477 /* clears the break-semaphore 4 and thus releases the interrupts
13478 clr_break_sem_4(); */
13479 #define clr_break_sem_4() SEMA_(break_sem_4 = 0)
13480 /* is used by STREAM, PATHNAME */
13481
13482 /* increments break-semaphore 5 and thus protects against interrupts
13483 inc_break_sem_5(); */
13484 #define inc_break_sem_5() SEMA_(break_sem_5++)
13485 /* is used by SPVW */
13486
13487 /* decrements break-semaphore 5 and thus releases interrupts
13488 dec_break_sem_5(); */
13489 #define dec_break_sem_5() SEMA_(break_sem_5--)
13490 /* is used by SPVW */
13491
13492 /* clears the break-semaphore 5 and thus releases the interrupts
13493 clr_break_sem_5(); */
13494 #define clr_break_sem_5() SEMA_(break_sem_5 = 0)
13495 /* is used by SPVW */
13496
13497 /* Flag, whether SYS::READ-FORM should behave compatibly to ILISP */
13498 extern bool ilisp_mode;
13499
13500 /* Flag, whether libreadline should be avoided */
13501 extern bool disable_readline;
13502
13503 /* returns the amount of space occupied by static LISP-objects */
13504 extern uintM static_space (void);
13505 /* is used by DEBUG */
13506
13507 /* returns the amount of space occupied by LISP-objects */
13508 extern uintM used_space (void);
13509 /* is used by TIME, DEBUG */
13510
13511 /* returns the amount of space still available for LISP-objects */
13512 extern uintM free_space (void);
13513 /* is used by DEBUG */
13514
13515 /* UP: saves memory image to disc
13516 savemem(stream,executable);
13517 > object stream: open File-Output-Stream, will be closed
13518 > uintL executable: 0: no runtime; 1: runtime; 2: also delegate command line
13519 < file length
13520 can trigger GC */
13521 extern maygc off_t savemem (object stream, uintL executable);
13522 /* used by PATHNAME */
13523
13524 #ifdef HAVE_SIGNALS
13525 /* Temporarily do not ignore the status of subprocesses. */
13526 extern void begin_want_sigcld (void);
13527 extern void end_want_sigcld (void);
13528 /* is used by PATHNAME and module syscalls */
13529 #endif
13530 %% #ifdef HAVE_SIGNALS
13531 %% exportF(void,begin_want_sigcld,(void));
13532 %% exportF(void,end_want_sigcld,(void));
13533 %% #endif
13534
13535
13536 #if defined(HAVE_SIGNALS) && defined(SIGPIPE) && !defined(MULTITHREAD)
13537 /* Set ONLY during write() calls to pipes directed to subprocesses. */
13538 extern bool writing_to_subprocess;
13539 #endif
13540 %% #if defined(HAVE_SIGNALS) && defined(SIGPIPE) && !defined(MULTITHREAD)
13541 %% exportV(bool,writing_to_subprocess);
13542 %% #endif
13543
13544
13545 /* Declaration of the FSUBRs.
13546 As C-functions: C_name, of the type fsubr_function_t (no arguments, no value) */
13547
13548 /* make C-functions visible: */
13549 #define LISPSPECFORM LISPSPECFORM_A
13550 #include "fsubr.c"
13551 #undef LISPSPECFORM
13552 /* is used by */
13553
13554 /* make Fsubr-table visible: */
13555 #define LISPSPECFORM LISPSPECFORM_C
13556 struct fsubr_tab_ {
13557 #include "fsubr.c"
13558 };
13559 #undef LISPSPECFORM
13560 extern const struct fsubr_tab_ fsubr_tab;
13561 /* is used by CONTROL, SPVW */
13562
13563
13564 /* Declaration of the SUBR-table:
13565 As C-functions: C_name
13566 of the type subr_norest_function_t (no arguments, no value)
13567 resp. subr_rest_function_t (two arguments, no value): */
13568 typedef Values subr_norest_function_t (void);
13569 typedef Values subr_rest_function_t (uintC argcount, gcv_object_t* rest_args_pointer);
13570 %% #if notused
13571 %% emit_typedef_f("Values %s(void)","subr_norest_function_t");
13572 %% emit_typedef_f("Values %s(uintC argcount, object* rest_args_pointer)","subr_rest_function_t");
13573 %% #endif
13574
13575 /* As LISP-Subr: L(name) */
13576
13577 /* Make C-functions visible: */
13578 #define LISPFUN LISPFUN_A
13579 #include "subr.c"
13580 #undef LISPFUN
13581 /* is used by */
13582
13583 /* Make Subr-tables visible: */
13584 #define LISPFUN LISPFUN_C
13585 extern struct subr_tab_ {
13586 VAROBJECTS_ALIGNMENT_DUMMY_DECL
13587 #include "subr.c"
13588 } subr_tab_data;
13589 #undef LISPFUN
13590 /* is used by Macro L */
13591 %% puts(STRINGIFY(modimp) " struct subr_tab_ {");
13592 %% puts(" VAROBJECTS_ALIGNMENT_DUMMY_DECL");
13593 %% #undef LISPFUN
13594 %% #define LISPFUN(name,sec,req_count,opt_count,rest_flag,key_flag,key_count,keywords) \
13595 %% printf(" subr_t %s;\n",STRING(D_##name));
13596 %% #include "subr.c"
13597 %% #undef LISPFUN
13598 %% puts("} subr_tab_data;");
13599 %% emit_dll_def("subr_tab_data");
13600
13601 /* Abbreviation for LISP-Subr with a given name: L(name) */
13602 #if !defined(MAP_MEMORY_TABLES)
13603 #define subr_tab subr_tab_data
13604 #ifdef TYPECODES
13605 #define subr_tab_ptr_as_object(subr_addr) (type_constpointer_object(subr_type,subr_addr))
13606 #else
13607 #if defined(OBJECT_STRUCT)
13608 #define subr_tab_ptr_as_object(subr_addr) as_object((oint)(subr_addr)+subr_bias)
13609 #else
13610 #define subr_tab_ptr_as_object(subr_addr) objectplus(subr_addr,subr_bias)
13611 #endif
13612 #endif
13613 #define L_help_(name) subr_tab_ptr_as_object(&subr_tab.name)
13614 #else
13615 #ifdef SINGLEMAP_MEMORY
13616 #define subr_tab_addr ((struct subr_tab_ *)(type_zero_oint(subr_type)+SINGLEMAP_ADDRESS_BASE))
13617 #else
13618 #define subr_tab_addr ((struct subr_tab_ *)type_zero_oint(subr_type))
13619 #endif
13620 #define subr_tab (*subr_tab_addr)
13621 #define subr_tab_ptr_as_object(subr_addr) (as_object((oint)(subr_addr)))
13622 #define L_help_(name) subr_tab_ptr_as_object(&subr_tab_addr->name)
13623 #endif
13624 #define L(name) L_help_(D_##name)
13625 /* is used by all modules */
13626 %% #if defined(MAP_MEMORY_TABLES)
13627 %% export_def(subr_tab_addr);
13628 %% #endif
13629 %% export_def(subr_tab);
13630 %% export_def(subr_tab_ptr_as_object(subr_addr));
13631 %% export_def(L_help_(name));
13632 %% emit_define("L(name)","L_help_(D_##name)");
13633
13634
13635 /* Pseudofunctions are addresses of C functions (to be called directly, not via
13636 FUNCALL) or constant C data.
13637 For SAVEMEM/LOADMEM we have a table of all such pseudofunctions. */
13638 typedef const void * Pseudofun; /* assume function pointers fit in a void* */
13639 %% emit_typedef("const void *","Pseudofun");
13640
13641 /* Declaration of the tables of relocatable pointers: */
13642 #define PSEUDO PSEUDO_A
13643 extern struct pseudocode_tab_ {
13644 #include "pseudofun.c"
13645 } pseudocode_tab;
13646 #undef PSEUDO
13647 #define PSEUDO PSEUDO_B
13648 extern struct pseudodata_tab_ {
13649 #include "pseudofun.c"
13650 #if defined(MICROSOFT) && !defined(ENABLE_UNICODE)
13651 Pseudofun dummy_pseudofun;
13652 #endif
13653 } pseudodata_tab;
13654 #undef PSEUDO
13655 /* is used by STREAM, SPVW */
13656
13657 /* Declaration of the functions that can be stored in Lisp objects. */
13658 #define PSEUDO PSEUDO_C
13659 #include "pseudofun.c"
13660 #undef PSEUDO
13661 /* is used by STREAM, and to avoid gcc -Wmissing-declarations warnings */
13662
13663 /* Return an ADDRESS object encapsulating a pseudofunction. */
13664 #ifdef TYPECODES
13665 #define P(fun) type_constpointer_object(machine_type,(Pseudofun)&(fun))
13666 #else
13667 #define P(fun) make_machine_code((Pseudofun)&(fun))
13668 #endif
13669 /* is used by STREAM, ENCODING */
13670
13671
13672 /* Declaration if the Symbol-table: */
13673 #define LISPSYM LISPSYM_A
13674 extern struct symbol_tab_ {
13675 VAROBJECTS_ALIGNMENT_DUMMY_DECL
13676 #include "constsym.c"
13677 } symbol_tab_data;
13678 #undef LISPSYM
13679 /* is used by Macro S, gcinvariant_symbol_p */
13680 %% puts(STRINGIFY(modimp) " struct symbol_tab_ {");
13681 %% puts(" VAROBJECTS_ALIGNMENT_DUMMY_DECL");
13682 %% #define LISPSYM(name,printname,package) \
13683 %% printf(" symbol_ %s;\n",STRING(S_##name));
13684 %% #include "constsym.c"
13685 %% #undef LISPSYM
13686 %% puts("} symbol_tab_data;");
13687 %% emit_dll_def("symbol_tab_data");
13688
13689 /* Abbreviation for LISP-Symbol with a given name: S(name) */
13690 #define S(name) S_help_(S_##name)
13691 #if !defined(MAP_MEMORY_TABLES)
13692 #define symbol_tab symbol_tab_data
13693 #ifdef TYPECODES
13694 #define S_help_(name) (type_constpointer_object(symbol_type,&symbol_tab.name))
13695 #else
13696 #if defined(OBJECT_STRUCT)
13697 #define S_help_(name) as_object((oint)&symbol_tab.name+varobject_bias)
13698 #else
13699 #define S_help_(name) objectplus(&symbol_tab.name,varobject_bias)
13700 #endif
13701 #endif
13702 #else
13703 #ifdef SINGLEMAP_MEMORY
13704 #define symbol_tab_addr ((struct symbol_tab_ *)(type_zero_oint(symbol_type)+SINGLEMAP_ADDRESS_BASE))
13705 #else
13706 #define symbol_tab_addr ((struct symbol_tab_ *)type_zero_oint(symbol_type))
13707 #endif
13708 #define symbol_tab (*symbol_tab_addr)
13709 #define S_help_(name) (as_object((oint)(&symbol_tab_addr->name)))
13710 #if 0 /* Some compilers do not allow the above expression */
13711 /* - even though it's a 'constant expression' -
13712 as initializer of static variables.
13713 We have to assist: */
13714 #undef S_help_
13715 #define S_help_(name) (as_object( (char*)(&((struct symbol_tab_ *)0)->name) + (uintP)symbol_tab_addr ))
13716 #endif
13717 #endif
13718 /* is used by all modules */
13719 %% emit_define("S(name)","S_help_(S_##name)");
13720 %% #if defined(MAP_MEMORY_TABLES)
13721 %% export_def(symbol_tab_addr);
13722 %% #endif
13723 %% export_def(symbol_tab);
13724 %% export_def(S_help_(name));
13725
13726 #define NIL S(nil)
13727 #define T S(t)
13728 %% export_def(NIL);
13729 %% export_def(T);
13730
13731 #if defined(DEBUG_GCSAFETY)
13732 /* gcinvariant_symbol_p(obj)
13733 > obj: an object
13734 < result: true if obj is a symbol in symbol_tab */
gcinvariant_symbol_p(object obj)13735 static inline bool gcinvariant_symbol_p (object obj) {
13736 if (
13737 #ifdef TYPECODES
13738 symbolp(obj)
13739 #else
13740 varobjectp(obj)
13741 #endif
13742 &&
13743 (
13744 #if !defined(MAP_MEMORY_TABLES)
13745 #ifdef TYPECODES
13746 (as_oint(obj) >> (oint_addr_shift-addr_shift)) - ((aint)(tint)symbol_type<<oint_type_shift)
13747 #else
13748 as_oint(obj) - varobject_bias
13749 #endif
13750 #else
13751 as_oint(obj)
13752 #endif
13753 - (aint)&symbol_tab < sizeof(symbol_tab))
13754 )
13755 return true;
13756 else
13757 return false;
13758 }
13759 #endif
13760 %% #if defined(DEBUG_GCSAFETY)
13761 %% print("static inline bool gcinvariant_symbol_p (object obj) { if (");
13762 %% #ifdef TYPECODES
13763 %% print("symbolp(obj)");
13764 %% #else
13765 %% print("varobjectp(obj)");
13766 %% #endif
13767 %% print(" && (");
13768 %% #if !defined(MAP_MEMORY_TABLES)
13769 %% #ifdef TYPECODES
13770 %% printf2("(as_oint(obj) >> %d) - %d", oint_addr_shift-addr_shift, (aint)(tint)symbol_type<<oint_type_shift);
13771 %% #else
13772 %% printf1("as_oint(obj) - %d", varobject_bias);
13773 %% #endif
13774 %% #else
13775 %% print("as_oint(obj)");
13776 %% #endif
13777 %% puts(" - (aint)&symbol_tab < sizeof(symbol_tab))) return true; else return false; }");
13778 %% #endif
13779
13780 /* The macro NIL_IS_CONSTANT tells , whether NIL is recognized
13781 as 'constant expression' by the C-Compiler. If so, tables can
13782 already be initialized largely by the C-Compiler. */
13783 #if (oint_addr_shift==0)
13784 #define NIL_IS_CONSTANT true
13785 #else
13786 #define NIL_IS_CONSTANT false
13787 #endif
13788
13789 /* Declaration of the table with the remaining constant objects: */
13790 #define LISPOBJ LISPOBJ_A
13791 extern struct object_tab_ {
13792 #include "constobj.c"
13793 } object_tab;
13794 #undef LISPOBJ
13795 /* is used by Macro O */
13796 %% puts(STRINGIFY(modimp) " struct object_tab_ {");
13797 %% #define LISPOBJ(name,init) printf(" gcv_object_t %s;\n",STRING(name));
13798 %% #include "constobj.c"
13799 %% #undef LISPOBJ
13800 %% puts("} object_tab;");
13801 %% emit_dll_def("object_tab");
13802
13803 /* Abbreviation for other LISP-object with a given Name: */
13804 #define O(name) (object_tab.name)
13805 #if !defined(MULTITHREAD)
13806 #define TLO O
13807 #endif
13808 %% /* FIXME: Difference between lispbibl.d and clisp.h */
13809 %% puts("#define GLO(name) (object_tab.name)");
13810
13811 #if defined(GENERATIONAL_GC) && defined(SPVW_MIXED)
13812 /* handle_fault_range(PROT_READ,start,end) makes an address range readable.
13813 handle_fault_range(PROT_READ_WRITE,start,end) makes an address range writable. */
13814 extern bool handle_fault_range (int prot, aint start_address, aint end_address);
13815 #endif
13816 %% export_def(PROT_READ);
13817 %% export_def(PROT_READ_WRITE);
13818 %% #if defined(GENERATIONAL_GC) && defined(SPVW_MIXED)
13819 %% exportF(bool,handle_fault_range,(int prot, aint start_address, aint end_address));
13820 %% #else
13821 %% puts("#define handle_fault_range(p,s,e) ((void)(p),(void)(s),(void)(e))");
13822 %% #endif
13823
13824
13825 /* ###################### MODBIBL for MODULES.D ########################### */
13826
13827 #if defined(DYNAMIC_MODULES) && !defined(HAVE_DYNLOAD) && !defined(WIN32_NATIVE)
13828 /* if you want DYNAMIC_MODULES to work on a non-WIN32_NATIVE platform
13829 which does not HAVE_DYNLOAD (e.g., via ltdl), you will need to
13830 implement libopen() and find_name() in spvw.d for your platform */
13831 #error Dynamic modules require dynamic loading!
13832 #endif
13833
13834 /* Number of external modules: */
13835 extern uintC module_count;
13836 %% exportV(uintC,module_count);
13837
13838 /* Data for initialization of a module's subr_tab: */
13839 typedef struct {
13840 const char* packname; /* Name of the Home-Package of the Symbol or NULL */
13841 const char* symname; /* Name of the Symbol */
13842 } subr_initdata_t;
13843 %% emit_typedef("struct { const char* packname; const char* symname; }","subr_initdata_t");
13844
13845 /* Data for initialization of a module's object_tab: */
13846 typedef struct {
13847 const char* initstring; /* Initialization-String */
13848 } object_initdata_t;
13849 %% emit_typedef("struct { const char* initstring; }","object_initdata_t");
13850
13851 /* Table resp. List of Modules: */
13852 typedef struct module_t {
13853 const char* name; /* Name */
13854 subr_t* stab; const uintC* stab_size; /* a separate subr_tab */
13855 gcv_object_t* otab; const uintC* otab_size; /* a separate object_tab */
13856 bool initialized;
13857 /* Data for Initialization: */
13858 const subr_initdata_t* stab_initdata;
13859 const object_initdata_t* otab_initdata;
13860 /* Functions for Initialization */
13861 void (*initfunction1) (struct module_t *); /* only once */
13862 void (*initfunction2) (struct module_t *); /* always at start up */
13863 void (*finifunction) (struct module_t *); /* before termination */
13864 #ifdef DYNAMIC_MODULES
13865 struct module_t * next; /* linked List */
13866 #endif
13867 } module_t;
13868 #ifdef DYNAMIC_MODULES
13869 extern module_t modules[]; /* List-Start */
13870 BEGIN_DECLS
13871 extern void add_module (module_t * new_module);
13872 END_DECLS
13873 #else
13874 extern module_t modules[]; /* 1+module_count entries, then an empty entry */
13875 #endif
13876 %% strcpy(buf,"struct module_t { const char* name; subr_t* stab; const uintC* stab_size; gcv_object_t* otab; const uintC* otab_size; bool initialized; const subr_initdata_t* stab_initdata; const object_initdata_t* otab_initdata; void (*initfunction1) (struct module_t *); void (*initfunction2) (struct module_t *); void (*finifunction) (struct module_t *);");
13877 %% #ifdef DYNAMIC_MODULES
13878 %% strcat(buf," struct module_t * next;");
13879 %% #endif
13880 %% strcat(buf," }"); emit_typedef(buf,"module_t");
13881 %% #ifdef DYNAMIC_MODULES
13882 %% puts("BEGIN_DECLS");
13883 %% exportF(void,add_module,(module_t * new_module));
13884 %% puts("END_DECLS");
13885 %% #else
13886 %% exportF(module_t,modules,[]);
13887 %% #endif
13888
13889 #if defined(HAVE_DYNLOAD) || defined(WIN32_NATIVE)
13890 /* open the dynamic library
13891 libname is the name of the library
13892 returns a handle suitable for find_name()
13893 calls dlopen() or LoadLibrary() */
13894 extern void * libopen (const char* libname);
13895 /* used by FOREIGN and spvw.d:dynload_modules() */
13896
13897 /* find the name in the dynamic library handle
13898 calls dlsym() or GetProcAddress()
13899 handle is an object returned by libopen()
13900 or NULL, which means emulate RTLD_DEFAULT on UNIX_FREEBSD
13901 and WIN32_NATIVE by searching through all libraries
13902 name is the name of the function (or variable) in the library */
13903 extern void* find_name (void *handle, const char *name);
13904 /* used by FOREIGN and spvw.d:dynload_modules() */
13905 #endif
13906
13907 #if defined(DYNAMIC_MODULES)
13908 /* Attaches a shared library to this process' memory, and attempts to load
13909 a number of clisp modules from it. */
13910 extern maygc void dynload_modules (const char * library, uintC modcount,
13911 const char * const * modnames);
13912 #endif
13913
13914 /* find the module with the given name */
13915 extern module_t* find_module (const char *name);
13916 /* push all module names to STACK and return the number of modules pushed
13917 can trigger GC */
13918 extern maygc uintC modules_names_to_stack (void);
13919
13920 /* ####################### EVALBIBL for EVAL.D #############################
13921
13922 Specifications for the Evaluator
13923 ################################
13924
13925 SUBRs and FSUBRs
13926 ================
13927
13928 They're constructed through
13929 LISPFUN for general LISP-functions,
13930 LISPFUNN for normal LISP-functions (only required parameters),
13931 LISPSPECFORM for special forms (FSUBRs).
13932 Note that SUBRs with KEY_COUNT=0 will be seen as SUBRs without keyword-
13933 parameters by the evaluator (which in consequence means that in this case the
13934 ALLOW_FLAG is meaningless and no keyword, not even :ALLOW-OTHER-KEYS,
13935 will be accepted)!
13936
13937 Values
13938 ======
13939
13940 The following format is used for the passing of multiple values:
13941 value1 contains the first value (NIL if there aren't values).
13942 mv_count contains the number of values..
13943 If there is at least one value : value1 = first value.
13944 If there are at least two values : value2 = second value.
13945 If there are at least three values : value3 = third value .
13946 All values are in mv_space .
13947 Recommended commands for returning of values to the caller:
13948 0 values: VALUES0;
13949 1 value : VALUES1(...);
13950 2 values: value1=...; value2=...; mv_count=2;
13951 3 values: value1=...; value2=...; value3=...; mv_count=3;
13952 more than 3 values:
13953 if (number of values >= mv_limit) goto error_too_many_values;
13954 Put the values one after another onto the STACK
13955 STACK_to_mv(number of values);
13956
13957 Passing of parameters to SUBRs
13958 ==============================
13959
13960 The arguments are passed on the LISP-stack, with the first one being on the
13961 top. The required arguments come first, then the optional ones
13962 (each #UNBOUND, if not specified), then come the
13963 keyword-arguments (again, each #UNBOUND, if not specified).
13964 The SUBR-object can be found in back_trace.
13965 This is all if no &REST-argument is planned. But if a &REST-argument
13966 is planned, all further arguments follow (the optional ones) on the stack
13967 one by one, and this will be passed: the number of these arguments and a pointer
13968 above the first of these arguments. (This means that the number of LISP-objects on
13969 the stack is not always the same!)
13970 All arguments have to be removed from the LISP-stack at the return jump.
13971 (for example. for SUBRs with &REST: the stackpointer STACK has to have the value
13972 args_pointer = rest_args_pointer STACKop (fixed number of arguments)
13973 = pointer above the very first argument), and mv_count/mv_space
13974 has to hold the values.
13975
13976 Passing of parameters to FSUBRs
13977 ===============================
13978
13979 The parameters are passed on the LISP-stack with the first one being on top.
13980 At first there are the required parametes, followed by the optional ones
13981 (#UNBOUND, if not specifired), then - if body-flag true -
13982 the whole rest of the body (most of the time a list).
13983 So the number of objects on the LISP-stack is always the same, namely
13984 numReqParameter + numOptParameter + (0 or 1 if body-flag).
13985 At the call, back_trace holds the FSUBR-object, and the whole form is
13986 in the EVAL-frame, directly above the parameters.
13987 All parameters have to be removed from the LISP-stack at the return jump
13988 (ie. the stackpointer STACK has to be incemented by the number of objects),
13989 and mv_count/mv_space has to hold the values.
13990
13991 Environments
13992 ============
13993
13994 General
13995 -------
13996 The lexical environment is separated into 5 components:
13997 - the variables-environment (VAR_ENV),
13998 - the functions- and macro-environment (FUN_ENV),
13999 - the block-environment (BLOCK_ENV),
14000 - the tagbody-environment (GO_ENV),
14001 - the declarations-environment (DECL_ENV).
14002 The environment is kept in 5 "global variables". They are dynamically bound
14003 with special frames on change.
14004 A single functions- and macro environment is passed to SYM_FUNCTION,
14005 MACROEXP, MACROEXP0, PARSE_DD.
14006 GET_CLOSURE expects a pointer to all environments en bloc: A3 with
14007 VAR_(A3)=VAR_ENV, FUN_(A3)=FUN_ENV, BLOCK_(A3)=BLOCK_ENV, GO_(A3)=GO_ENV,
14008 DECL_(A3)=DECL_ENV.
14009
14010 The variables-environment
14011 -------------------------
14012 It contains the local variable-bindings.
14013 A variables-enviroment is given through a pointer to a
14014 variable-binding frame, or NIL (which means an empty lexical
14015 environment) or a vector that is built as follows:
14016 The vector contains n bindings and has the length 2n+1. The elements are
14017 n-times each variable (a symbol) and the value that belongs to it ("value" can
14018 be #<SPECDECL> as well, and then the variable has to be referenced dynamically,
14019 or it can be #<IMPLEMENTATION-DEPENDENT>, then a warning is emitted during
14020 lookup) and as last element the predecessor environment.
14021
14022 The functions- and macro-environment
14023 ------------------------------------
14024 It contains the local function- and macro-definitions.
14025 A functions- and macro-environment is given through a pointer to
14026 a functions- or macrobindings-frame or NIL (which means an empty
14027 lexical environment) or through a vector that is built as follows:
14028 The vector contains n bindings and has length 2n+1. The elements are
14029 n-time each function-name (a symbol) and the definiton that belongs to it (a
14030 closure or NIL or a SYS::MACRO object) and as last element
14031 the predecessor environment.
14032
14033 The block-environment
14034 ---------------------
14035 It contains the lexically visible block-exitpoints.
14036 A block-environment is given through a pointer to a block-frame
14037 or through an association-list, whose elements each have the block-name (a symbol)
14038 as CAR and as CDR either the pointer to the appropriate
14039 frame or #DISABLED, if the block has already been left.
14040
14041 The tagbody-environment
14042 -----------------------
14043 It contains the lexically visible Go-labels of the tagbodies.
14044 A tagbody-environment is given through a pointer to a
14045 tagbody-frame or an associations-list, whose elements have a vector (with the
14046 Go-tags as elements) as CAR and as CDR either the pointer to the
14047 related frame or #DISABLED, if the tagbody has already
14048 been left.
14049
14050 The declarations-environment
14051 ----------------------------
14052 It contains the lexically visible declarations.
14053 A declarations-environment is given through a list of declaration-
14054 specifiers, whose CAR is each either OPTIMIZE or DECLARATION or
14055 a user-specified declaration-type.
14056
14057 Passing of environtments to LISP-functions
14058 ------------------------------------------
14059 There are two data structures for this:
14060 When it is passed as second argument to macro-expander-functions (CLTL p.
14061 145-146) and when it is receipted by MACROEXPAND and MACROEXPAND-1 (CLTL p. 151)
14062 it is simply a Simple-Vector with 2 elements, consisting of a nested
14063 variable-environment and a nested functions- and macro-environment.
14064 The same for passing to SYSTEM::%EXPAND-LAMBDABODY-MAIN and the like.
14065 If it is passed as second argument to the value of *EVALHOOK* or as third one
14066 to the value of *APPLYHOOK* (CLTL p. 322) and on reception by
14067 EVALHOOK and APPLYHOOK (CLTL p. 323) it is a Simple-Vector with
14068 five elements with all five components nested.
14069
14070 Frames
14071 ======
14072 Frames are not used to call SUBRs, FSUBRs and compiled closures.
14073
14074 There are the following 14 kinds of frames:
14075 - Environmentbinding-Frame (ENV_FRAME),
14076 - APPLY-frame (APPLY_FRAME),
14077 - EVAL-frame (EVAL_FRAME),
14078 - dynamic variable-bindings-frame (DYNBIND_FRAME),
14079 - Variable-bindings-frame (VAR_FRAME),
14080 - Function- or Macrobindings-Frame (FUN_FRAME),
14081 - interpreted block-frame (IBLOCK_FRAME),
14082 - compiled block-frame (CBLOCK_FRAME),
14083 - interpreted tagbody-frame (ITAGBODY_FRAME),
14084 - compiled tagbody-frame (CTAGBODY_FRAME),
14085 - Catch-Frame (CATCH_FRAME),
14086 - Unwind-Protect-frame (UNWIND_PROTECT_FRAME),
14087 - Handler-frame (HANDLER_FRAME),
14088 - C-Handler-frame (C_HANDLER_FRAME),
14089 - Driver-frame (DRIVER_FRAME).
14090 Right at the bottom of a frame there is a long-word, that contains the
14091 frame-type information and a pointer above the frame (= the value of the
14092 STACK before and after the frame has been built).
14093 In the frame-info there are the bits
14094 SKIP2_BIT deleted, if another long-word comes above it,
14095 that is not a LISP-object and thus has to be skipped
14096 by the GC,
14097 EXITPOINT_BIT set for all but VAR and FUN,
14098 NESTED_BIT set for IBLOCK and ITAGBODY, if the exitpoint or
14099 the Go-label has already been put into an Alist.
14100 The default-values for the frame-type info-bytes are ENVxx_FRAME_INFO,
14101 APPLY_FRAME_INFO, EVAL_FRAME_INFO, VAR_FRAME_INFO, FUN_FRAME_INFO,
14102 IBLOCK_FRAME_INFO, CBLOCK_FRAME_INFO, ITAGBODY_FRAME_INFO, CTAGBODY_FRAME_INFO,
14103 CATCH_FRAME_INFO, UNWIND_PROTECT_FRAME_INFO, DRIVER_FRAME_INFO.
14104 The routine that is in (SP).L with SP=SP_(STACK) (for IBLOCK-, CBLOCK-,
14105 ITAGBODY-, CTAGBODY-, CATCH-, UNWIND-PROTECT-frames), is being
14106 jumped to by MOVE.L SP_(STACK),SP ! RTS .
14107 For DRIVER-frames by MOVE.L SP_(STACK),SP ! MOVE.L (SP),-(SP) ! RTS .
14108 In the portable C-version in SP_(STACK) there is a pointer to a
14109 setjmp/longjmp-buffer.
14110
14111 Environmentbindings-frames
14112 --------------------------
14113 They contain dynamic bindings of a maximum of 5 environments.
14114 ENVxx_FRAME_INFO is frame-info (xx depending on the environment that is
14115 bound here). Structure:
14116 Offset Stack-Contents
14117 20/16/12/8/4 [old value ofDECL_ENV]
14118 16/12/8/4 [old value ofGO_ENV]
14119 12/8/4 [old value ofBLOCK_ENV]
14120 8/4 [old value ofFUN_ENV]
14121 4 [old value ofVAR_ENV]
14122 0 Frame-Info; pointer above frame
14123
14124 ENV1V_frame for 1 VAR_ENV
14125 ENV1F_frame for 1 FUN_ENV
14126 ENV1B_frame for 1 BLOCK_ENV
14127 ENV1G_frame for 1 GO_ENV
14128 ENV1D_frame for 1 DECL_ENV
14129 ENV2VD_frame for 1 VAR_ENV and 1 DECL_ENV
14130 ENV5_frame for all 5 environments
14131
14132 APPLY-frames
14133 ------------
14134 They are created at every call (APPLY or FUNCALL) of an interpreted
14135 closure.
14136 Structure:
14137 Offset Stack-contents
14138 4n+12
14139 4n+8 Argument 1
14140 ...
14141 12 Argument n
14142 8 Function that is being called
14143 4 SP
14144 0 Frame-info; pointer above frame
14145 SP is a pointer into the program-stack. Jumping back to (SP).L after dissolving
14146 the APPLY-fame returns the contents of A0/... as values of the form.
14147 The frame-info has the value APPLY_FRAME_INFO or TRAPPED_APPLY_FRAME_INFO.
14148
14149 EVAL-frames
14150 -----------
14151 They are created for every call of the EVAL-procedure.
14152 Layout:
14153 Offset Stack-content
14154 8 Form that is being evaluated
14155 4 SP
14156 0 Frame-info; pointer above frame
14157 SP is a pointer into the program stack. Jumping back to (SP).L after dissolving
14158 the EVAL-frame returns the contents of A0/... as values of the form.
14159 The frame-info has the value EVAL_FRAME_INFO or TRAPPED_EVAL_FRAME_INFO.
14160
14161 Dynamic variable-bindings frames
14162 -----------------------------------
14163 They bind symbols to values dynamically.
14164 The structure of such a frame with n bindings is as follows::
14165 Offset stack contents
14166 8n+4
14167 8n value 1
14168 8n-4 symbol 1
14169 ... ...
14170 8 value n
14171 4 symbol n
14172 0 frame-info; pointer above frame
14173 The content of the frameinfo-byte is DYNBIND_FRAME_INFO.
14174
14175 Variable-bindings-frames
14176 ------------------------
14177 They are created when interpreted closures are being used (for the variable
14178 bindings specified in the Lambda-list and in the dynamic references that might
14179 be specified in the declarations) and by LET and LET*, as well as by all
14180 constructs, that use LET or LET* implicitly (such as DO, DO*, PROG, PROG*,
14181 DOLIST, DOTIMES, ...).
14182 The structure of a variable-bindings-frame with n bindings is as follows:
14183 #ifndef NO_symbolflags
14184 Offset stack contents
14185 12+8n
14186 8+8n value 1
14187 4+8n symbol 1
14188 ... ...
14189 16 value n
14190 12 symbol n
14191 8 NEXT_ENV
14192 4 m
14193 0 frame-info; pointer above frame
14194 #else
14195 Offset stack contents
14196 12+12n
14197 8+12n value 1
14198 4+12n symbol 1
14199 12n marker bits 1
14200 ... ...
14201 20 value n
14202 16 symbol n
14203 12 marker bits n
14204 8 NEXT_ENV
14205 4 m
14206 0 frame-info; pointer above frame
14207 #endif
14208 The symbol/value-pairs are numbered and stored in the order in which the
14209 bindings become active (i.e. for interpreted closures: at first the dynamic
14210 references (SPECIAL-declarations), then the required-parameters, then the
14211 optional parameters, then the remaining parameters, then the keyword
14212 parameters, then the AUX-variables).
14213 The symbols contain the following marker bits on the stack: ACTIVE_BIT, is
14214 set, if the binding is active, DYNAM_BIT is set, if the binding is
14215 dynamic. (Dynamic references are marked as lexical with
14216 the special value #<SPECDECL>!).
14217 NEXT_ENV is next upper variables-environment.
14218 m is a long-word, 0 <= m <= n, and stands for the number of bindings that
14219 have not yet been put into a vector by NEST-operations. Thus
14220 the symbol/value-pairs 1,...,n-m have been active but been nested meanwhile
14221 and thus inactive again on the stack (if the bindings were static).
14222 Only some of the pairs n-m+1,...,n can be static and active.
14223 The frameinfo-byte contains VAR_FRAME_INFO.
14224
14225 Function- and Macrobindings-Frames
14226 -----------------------------------
14227 They are created by FLET and MACROLET.
14228 The structure of a variable-bindings-frame with n bindings is as follows:
14229 Offset stack contents
14230 12+8n
14231 8+8n value 1
14232 4+8n symbol 1
14233 ... ...
14234 16 value n
14235 12 symbol n
14236 8 NEXT_ENV
14237 4 m
14238 0 Frame-Info; pointer above frame
14239 NEXT_ENV is the next higher function-environment.
14240 m is a long word, 0 <= m <= n, and stands for the number of bindings, that
14241 have not yet been put into a vector by NEST-operations. So the
14242 symbol/value pais 1,...,n-m have been active, but nested meanwhile and thus
14243 inactive on the stack again. Only the pairs n-m+1,...,n are active.
14244 Marker bits are not needed here, as opposed to the variable-bindings frames
14245
14246 All values are closures or SYS::MACRO objects.
14247 The content of the Frameinfo-bytes is FUN_FRAME_INFO.
14248
14249 Interpreted Block-Frames
14250 ------------------------
14251 They are created by BLOCK and all constructs that contain an implicit
14252 BLOCK (e.g. DO, DO*, LOOP, PROG, PROG*, ...). The structure is as follows:
14253 Offset stack contents
14254 16
14255 12 NAME
14256 8 NEXT_ENV
14257 4 SP
14258 0 Frame-Info; pointer above frame
14259 NAME is the name of the block. NEXT_ENV is the next higher Block-Environment.
14260 SP is a pointer into the program stack, (SP).L is a routine, that unwinds the
14261 Block-Frame and leaves the block with the values A0-A2/...
14262 Frame-Info is IBLOCK_FRAME_INFO, possibly with set NESTED_BIT (then NEXT_ENV
14263 points to an Alist, whose first element is the pair (NAME . <Framepointer>),
14264 because the block is not DISABLED yet).
14265
14266 Compiled Block-Frames
14267 ---------------------
14268 Structure:
14269 Offset stack contents
14270 12
14271 8 Cons (NAME . <Framepointer>)
14272 4 SP
14273 0 Frame-Info; pointer above frame
14274 NAME is the name of the block.
14275 SP is a pointer into the program stack, (SP).L is a routine, that
14276 unwinds the Block-Frame and leaves the block with the values A0-A2/...
14277 Frame-Info is CBLOCK_FRAME_INFO.
14278
14279 Interpreted Tagbody-Frames
14280 --------------------------
14281 They are created by TAGBODY and all constructs that contain an implicit
14282 TAGBODY (e.g. DO, DO*, PROG, PROG*, ...).
14283 The structure of a Tagbody-Frames with n tags is as follows:
14284 Offset stack contents
14285 12+8n
14286 8+8n BODY 1
14287 4+8n TAG 1
14288 ... ...
14289 16 BODY n
14290 12 TAG n
14291 8 NEXT_ENV
14292 4 SP
14293 0 Frame-Info; pointer above frame
14294 The tags are the jump destinations ; they are symbols and Integers, that are in
14295 the Body. The corresponding "value" BODY i contains the part of the body
14296 that follows TAG i. NEXT_ENV is the next higher Tagbody-Environment.
14297 SP is a pointer into the program stack, (SP).L is a routine, that executes
14298 the action (GO TAGi), if it is jumped to with BODYi in A0.
14299 Frame-Info is ITAGBODY_FRAME_INFO, poss. with set NESTED_BIT (then
14300 NEXT_ENV points to an Alist, whose first element has the form
14301 (#(TAG1 ... TAGn) . <Framepointer>), because the Tagbody is not
14302 DISABLED yet).
14303
14304 Compiled Tagbody-Frames
14305 -----------------------
14306 Structure:
14307 Offset stack contents
14308 12
14309 8 Cons (#(TAG1 ... TAGn) . <Framepointer>)
14310 4 SP
14311 0 Frame-Info; above frame
14312 TAG1, ..., TAGn are the names of the tags (actually only contained in
14313 the compiled code to create error messages).
14314 SP is a pointer into the program stack, (SP).L is a routine, that executes
14315 the action (GO TAGi), if it has been jumped at with value1 = i (1 <= i <= n)
14316
14317 Frame-Info is CTAGBODY_FRAME_INFO.
14318
14319 Catch-Frames
14320 ------------
14321 They are created by the Special-Form CATCH. Its structure is as follows:
14322 Offset stack contents
14323 12
14324 8 TAG
14325 4 SP
14326 0 Frame-Info; pointer above frame
14327 TAG is the tag of the catcher.
14328 SP is a pointer into the program stack, (SP).L is a routine, that unwinds
14329 the Frame and returns the values A0-A2/...
14330 Frame-Info is CATCH_FRAME_INFO.
14331
14332 Unwind-Protect-Frames
14333 ---------------------
14334 They are created by the Special-Form UNWIND-PROTECT and all constructs
14335 that contain an implicit UNWIND-PROTECT (like WITH-OPEN-STREAM or
14336 WITH-OPEN-FILE). Their structure is as follows:
14337 Offset Stack-contents
14338 8
14339 4 SP
14340 0 Frame-Info; pointer above frame
14341 SP is a pointer into the program stack. (SP).L a routine, that unwinds the
14342 Frame,saves the current values A0-A2/... executes the cleanup,
14343 writes the saved values back and finally jumps to the address
14344 (with RTS), that has been entered into the program stack in place of their own
14345 and leaves D6 unchanged.
14346
14347 Handler-Frames
14348 --------------
14349 They are created by the macro HANDLER-BIND. Their structure is as follows:
14350 Offset Stack-contens
14351 16
14352 12 Cons (#(type1 label1 ... typem labelm) . SPdepth)
14353 8 Closure
14354 4 SP
14355 0 Frame-Info; pointer above frame
14356 SP is a pointer into the program stack.
14357 If there is a condition of the type typei
14358 the closure starting at Byte labeli is interpreted as Handler, where at first
14359 a piece of the program stack with the length SPdepth is duplicated.
14360
14361 C-Handler-Frames
14362 ----------------
14363 This is a variant of Handler-Frames, which calls a C handler:
14364 Offset Stack-contents
14365 16
14366 12 Cons (#(type1 label1 ... typem labelm))
14367 8 Handler-function
14368 4 SP
14369 0 Frame-Info; pointer above frame
14370 SP is a pointer into the program stack.
14371 If there is a condition of the type typei
14372 the handler-function is called with the arguments SP
14373 (arbitrary pointer into the C-Stack, or NULL), frame (pointer above the frame),
14374 labeli (arbitrary Lisp-object), condition.
14375 If the Handler wants to yield control via unwind_upto(FRAME) by itself,
14376 the Frame has to be created with finish_entry_frame.
14377
14378 Driver-Frames
14379 -------------
14380 They are created upon entry into a top-level loop (most of the time
14381 a READ-EVAL-PRINT-loop) and are used to continue the previous top-level
14382 loop after an error message. The structure is simple
14383 Offset Stack-contens
14384 8
14385 4 SP
14386 0 Frame-Info; pointer above Frame
14387 SP is a pointer into the program stack. (SP).L is a routine, that
14388 re-enters the corresponding top-level loop.
14389
14390 STACK:
14391 ------
14392 STACK is the LISP-Stack.
14393 STACK_0 is the first object on the STACK.
14394 STACK_1 is the second object on the STACK.
14395 etc., generally STACK_(n) = (n+1)th object on the STACK.
14396 pushSTACK(object) puts an object onto the Stack. Synonym: -(STACK).
14397 popSTACK() returns STACK_0 and removes it from the stack.
14398 skipSTACK(n); removes n objects from the STACK.
14399 If you want to save the value of the stack, you do this:
14400 var gcv_object_t* temp = STACK; ... (no access through temp !) ... setSTACK(STACK = temp);
14401 but: access through STACKpointable(temp) is possible.
14402 If you want a pointer that can traverse through the Stack, you do this:
14403 var gcv_object_t* ptr = &STACK_0; or = STACKpointable(STACK);
14404 assert( *(ptr STACKop 0) == STACK_0 );
14405 assert( *(ptr STACKop 1) == STACK_1 );
14406 ...
14407 ptr skipSTACKop n;
14408 assert( *(ptr STACKop 0) == STACK_(n) );
14409 ...
14410 This pointer must not be assigned to the STACK again!
14411 If you store blocks of objects on the STACK and want to get the (n+1)-th block,
14412 you do this: STACKblock_(type,n). type should be a
14413 struct-type with sizeof(type) a multiple of sizeof(gcv_object_t). */
14414
14415 #ifdef STACK_DOWN
14416 #define STACK_(n) (STACK[(sintP)(n)])
14417 #define STACKpointable(STACKvar) ((gcv_object_t*)(STACKvar))
14418 #define skipSTACKop +=
14419 #define STACKop +
14420 #define cmpSTACKop <
14421 #define STACKblock_(type,n) (((type*)STACK)[(sintP)(n)])
14422 #endif
14423 #ifdef STACK_UP
14424 #define STACK_(n) (STACK[-1-(sintP)(n)])
14425 #define STACKpointable(STACKvar) ((gcv_object_t*)(STACKvar)-1)
14426 #define skipSTACKop -=
14427 #define STACKop -
14428 #define cmpSTACKop >
14429 #define STACKblock_(type,n) (((type*)STACK)[-1-(sintP)(n)])
14430 #endif
14431 #define pushSTACK(obj) (STACK_(-1) = (obj), STACK skipSTACKop -1)
14432 /* Almost equivalent with *--STACK = obj resp. *STACK++ = obj , but
14433 Careful: first enter the object into STACK_(-1), THEN modify the STACK! */
14434 #define popSTACK() (STACK skipSTACKop 1, STACK_(-1))
14435 #define skipSTACK(n) (STACK skipSTACKop (sintP)(n))
14436
14437 #if defined(GNU) && defined(M68K) && !defined(NO_ASM) && !defined(WIDE) && defined(STACK_register)
14438 /* With GNU and a M68K, STACK is in a register. Access and
14439 modification of the STACK are an atomic unit that cannot be interrupted. */
14440 #undef pushSTACK
14441 #undef popSTACK
14442 #ifdef STACK_DOWN
14443 /* define pushSTACK(obj) (*--STACK = (obj)) */
14444 #define pushSTACK(obj) \
14445 ({ __asm__ __volatile__ ("movel %0,"REGISTER_PREFIX""STACK_register"@-" : : "g" ((object)(obj)) : STACK_register ); })
14446 /* define popSTACK() (*STACK++) */
14447 #define popSTACK() \
14448 ({var object __result; \
14449 __asm__ __volatile__ ("movel "REGISTER_PREFIX""STACK_register"@+,%0" : "=g" (__result) : : STACK_register ); \
14450 __result; \
14451 })
14452 #endif
14453 #ifdef STACK_UP
14454 /* define pushSTACK(obj) (*STACK++ = (obj)) */
14455 #define pushSTACK(obj) \
14456 ({ __asm__ __volatile__ ("movel %0,"REGISTER_PREFIX""STACK_register"@+" : : "g" ((object)(obj)) : STACK_register ); })
14457 /* define popSTACK() (*--STACK) */
14458 #define popSTACK() \
14459 ({var object __result; \
14460 __asm__ __volatile__ ("movel "REGISTER_PREFIX""STACK_register"@-,%0" : "=g" (__result) : : STACK_register ); \
14461 __result; \
14462 })
14463 #endif
14464 #endif
14465 #if defined(SPARC) && !defined(GNU) && !defined(__SUNPRO_C) && !defined(MULTITHREAD) && (SAFETY < 2)
14466 #undef pushSTACK
14467 #undef popSTACK
14468 #undef skipSTACK
14469 #define pushSTACK(obj) (STACK_(-1) = (obj), _setSTACK(STACK STACKop -1))
14470 #define popSTACK() (_setSTACK(STACK STACKop 1), STACK_(-1))
14471 #define skipSTACK(n) (_setSTACK(STACK STACKop (sintP)(n)))
14472 #endif
14473 %% export_def(STACK_(n));
14474 %% export_def(skipSTACKop);
14475 %% export_def(STACKop);
14476 %% export_def(pushSTACK(obj));
14477 %% export_def(popSTACK());
14478 %% export_def(skipSTACK(n));
14479
14480 #define STACK_0 (STACK_(0))
14481 #define STACK_1 (STACK_(1))
14482 #define STACK_2 (STACK_(2))
14483 #define STACK_3 (STACK_(3))
14484 #define STACK_4 (STACK_(4))
14485 #define STACK_5 (STACK_(5))
14486 #define STACK_6 (STACK_(6))
14487 #define STACK_7 (STACK_(7))
14488 #define STACK_8 (STACK_(8))
14489 #define STACK_9 (STACK_(9))
14490 #define STACK_10 (STACK_(10))
14491 /* etc. */
14492 %% { int i;
14493 %% for (i=0; i<=10; i++)
14494 %% printf("#define STACK_%d (STACK_(%d))\n",i,i);
14495 %% }
14496
14497 /* Values:
14498
14499 Highest number of multiple values + 1 */
14500 #define mv_limit 128
14501
14502 /* Values are always passed in the MULTIPLE_VALUE_SPACE mv_space:
14503 uintC mv_count : number of values, >=0, <mv_limit
14504 object mv_space [mv_limit-1] : the values.
14505 For mv_count>0 the first mv_count elements are occupied.
14506 For mv_count=0 the first value = NIL.
14507 The values in mv_space are not subject to the Garbage Collection! */
14508 /* VTZ: g++ is very strict about forward declarations. */
14509 #if !defined(MULTITHREAD)
14510 #if !defined(mv_count_register)
14511 /* a global Variable */
14512 extern uintC mv_count;
14513 #else
14514 /* a global register */
14515 register uintC mv_count __asm__(mv_count_register);
14516 #endif
14517 extern object mv_space [mv_limit-1];
14518 #endif
14519 /* Synonyms: */
14520 #if !defined(value1_register)
14521 #define value1 mv_space[0]
14522 #else
14523 /* The first value mv_space[0] is stored permanently in a register: */
14524 register object value1 __asm__(value1_register);
14525 #define VALUE1_EXTRA /* and thus has to be treated extra every time... */
14526 #endif
14527 #define value2 mv_space[1]
14528 #define value3 mv_space[2]
14529 #define value4 mv_space[3]
14530 #define value5 mv_space[4]
14531 #define value6 mv_space[5]
14532 #define value7 mv_space[6]
14533 #define value8 mv_space[7]
14534 #define value9 mv_space[8]
14535 /* You might need global variables to pass with setjmp/longjmp: */
14536 #ifdef NEED_temp_mv_count
14537 extern uintC temp_mv_count;
14538 #define LONGJMP_SAVE_mv_count() temp_mv_count = mv_count
14539 #define LONGJMP_RESTORE_mv_count() mv_count = temp_mv_count
14540 #else
14541 #define LONGJMP_SAVE_mv_count()
14542 #define LONGJMP_RESTORE_mv_count()
14543 #endif
14544 #ifdef NEED_temp_value1
14545 extern object temp_value1;
14546 #define LONGJMP_SAVE_value1() temp_value1 = value1
14547 #define LONGJMP_RESTORE_value1() value1 = temp_value1
14548 #else
14549 #define LONGJMP_SAVE_value1()
14550 #define LONGJMP_RESTORE_value1()
14551 #endif
14552 /* is used by EVAL, CONTROL,
14553 Macros LIST_TO_MV, MV_TO_LIST, STACK_TO_MV, MV_TO_STACK */
14554 %% #if !defined(MULTITHREAD)
14555 %% #if notused
14556 %% export_def(mv_limit);
14557 %% #endif
14558 %% #if !defined(mv_count_register)
14559 %% exportV(uintC,mv_count);
14560 %% #else
14561 %% puts("#ifndef IN_MODULE_CC");
14562 %% printf("register uintC mv_count __asm__(\"%s\");\n",mv_count_register);
14563 %% puts("#endif");
14564 %% #endif
14565 %% printf("%s object mv_space [%d];\n",STRINGIFY(modimp),mv_limit-1);
14566 %% emit_dll_def("mv_space");
14567 %% #if !defined(value1_register)
14568 %% emit_define("value1","mv_space[0]");
14569 %% #else
14570 %% puts("#ifndef IN_MODULE_CC");
14571 %% printf("register object value1 __asm__(\"%s\");\n",value1_register);
14572 %% puts("#endif");
14573 %% #endif
14574 %% { int i = 2;
14575 %% for (; i <=9 ; i++)
14576 %% printf("#define value%d mv_space[%d]\n",i,i-1);
14577 %% }
14578 %% #endif
14579
14580 /* Returns the bottom objects from the STACK as multiple values.
14581 STACK_to_mv(count)
14582 count: number of objects, < mv_limit. */
14583 #if !defined(VALUE1_EXTRA)
14584 #define STACK_to_mv(countx) \
14585 do { var uintC count = (countx); \
14586 mv_count = count; \
14587 if (count == 0) value1 = NIL; \
14588 else { /* pointer behind space for last value */\
14589 object* mvp = &mv_space[count]; \
14590 dotimespC(count,count, { *--mvp = popSTACK(); } ); \
14591 } } while(0)
14592 #else
14593 #define STACK_to_mv(countx) \
14594 do { var uintC count = (countx); \
14595 mv_count = count; \
14596 if (count == 0) value1 = NIL; \
14597 else { \
14598 count--; \
14599 if (count > 0) { /* pointer behind space for last value */\
14600 object* mvp = &mv_space[1+count]; \
14601 dotimespC(count,count, { *--mvp = popSTACK(); } ); \
14602 } \
14603 value1 = popSTACK(); \
14604 } } while(0)
14605 #endif
14606 /* is used by EVAL, CONTROL */
14607 %% export_def(STACK_to_mv(countx));
14608
14609 /* Puts all values onto the STACK.
14610 mv_to_STACK()
14611 > mv_count/mv_space : values
14612 < values on the Stack (first value on top)
14613 STACK-Overflow is checked.
14614 modifies STACK */
14615 #if !defined(VALUE1_EXTRA)
14616 #define mv_to_STACK() \
14617 do { var uintC count = mv_count; \
14618 if (count!=0) { /* no values-> nothing onto the STACK */\
14619 var object* mvp = &mv_space[0]; \
14620 get_space_on_STACK(count); \
14621 dotimespC(count,count, { pushSTACK(*mvp++); } ); \
14622 } } while(0)
14623 #else
14624 #define mv_to_STACK() \
14625 do { var uintC count = mv_count; \
14626 if (count!=0) { /* no values -> nothing onto the STACK */\
14627 get_space_on_STACK(count); \
14628 pushSTACK(value1); \
14629 count--; \
14630 if (count > 0) { \
14631 var object* mvp = &mv_space[1]; \
14632 dotimespC(count,count, { pushSTACK(*mvp++); } ); \
14633 } \
14634 } } while(0)
14635 #endif
14636 /* is used by EVAL, CONTROL */
14637
14638 /* Returns the elements of a list as multiple values.
14639 list_to_mv(list,error_statement)
14640 error_statement: if there's an error (too many values). */
14641 #define NEXT_MV *mvp++ = Car(l); l = Cdr(l); count++
14642 #if !defined(VALUE1_EXTRA)
14643 #define list_to_mv(lst,error_statement) \
14644 do { var object l = (lst); \
14645 var uintC count = 0; \
14646 if (atomp(l)) value1 = NIL; \
14647 else { \
14648 var object* mvp = &mv_space[0]; \
14649 NEXT_MV; if (atomp(l)) goto mv_done; \
14650 NEXT_MV; if (atomp(l)) goto mv_done; \
14651 NEXT_MV; if (atomp(l)) goto mv_done; \
14652 do { if (count==mv_limit-1) { error_statement; } NEXT_MV; \
14653 } while (consp(l)); \
14654 } \
14655 mv_done: \
14656 if (!nullp(l)) error_proper_list_dotted(S(values_list),l); \
14657 mv_count = count; \
14658 } while(0)
14659 #else
14660 #define list_to_mv(lst,error_statement) \
14661 do { var object l = (lst); \
14662 var uintC count = 0; \
14663 if (atomp(l)) value1 = NIL; \
14664 else { \
14665 value1 = Car(l); l = Cdr(l); count++; if (atomp(l)) goto mv_done; \
14666 {var object* mvp = &mv_space[1]; \
14667 NEXT_MV; if (atomp(l)) goto mv_done; \
14668 NEXT_MV; if (atomp(l)) goto mv_done; \
14669 do { if (count==mv_limit-1) { error_statement; } NEXT_MV; \
14670 } while (consp(l)); \
14671 }} \
14672 mv_done: \
14673 if (!nullp(l)) error_proper_list_dotted(S(values_list),l); \
14674 mv_count = count; \
14675 } while(0)
14676 #endif
14677 /* is used by EVAL, CONTROL */
14678
14679 /* Gives the list of the multiple values on -(STACK).
14680 mv_to_list()
14681 can trigger GC */
14682 #define mv_to_list() \
14683 do { \
14684 mv_to_STACK(); /* at first all values onto the stack */\
14685 GCTRIGGER(); \
14686 pushSTACK(NIL); /* head of the list */\
14687 { var uintC count; \
14688 dotimesC(count,mv_count, { /* until all values have been used: */\
14689 var object l = allocate_cons(); /* new cell */\
14690 Cdr(l) = popSTACK(); /* list so far */\
14691 Car(l) = STACK_0; /* next value */\
14692 STACK_0 = l; /* save new cons */\
14693 }); \
14694 } } while(0)
14695 /* is used by EVAL, CONTROL, DEBUG */
14696
14697 /* Error message if there are too many values
14698 error_mv_toomany(caller);
14699 > caller: caller, a Symbol */
14700 extern _Noreturn void error_mv_toomany (object caller);
14701 /* is used by EVAL, CONTROL, LISPARIT */
14702 %% #if notused
14703 %% exportE(error_mv_toomany,(object caller));
14704 %% #endif
14705
14706 #if !defined(back_trace_register)
14707 extern p_backtrace_t back_trace;
14708 #else
14709 register p_backtrace_t back_trace __asm__(back_trace_register);
14710 #endif
14711 #define subr_self back_trace->bt_function
14712 %% #if defined(back_trace_register)
14713 %% puts("#ifndef IN_MODULE_CC");
14714 %% printf("register p_backtrace_t back_trace __asm__(\"%s\");\n",back_trace_register);
14715 %% puts("#endif");
14716 %% #elif !defined(back_trace)
14717 %% exportV(p_backtrace_t,back_trace);
14718 %% #endif
14719 %% export_def(subr_self);
14720
14721 /* Within the body of a SUBR: Access to the arguments.
14722 A SUBR with a fixed number of arguments can access them through the STACK:
14723 STACK_0 = last argument, STACK_1 = second to last argument etc.
14724 Clean STACK: with skipSTACK(number of arguments) .
14725 A SUBR with arbitrarily many arguments (&REST-Parameter) gets passed:
14726 uintC argcount the number of the remaining arguments
14727 gcv_object_t* rest_args_pointer Pointer above the remaining arguments
14728 Additionally:
14729 gcv_object_t* args_end_pointer Pointer below all arguments, depends on the STACK
14730 Additionally possible:
14731 gcv_object_t* args_pointer = rest_args_pointer STACKop (fixed number of arguments);
14732 Pointer above the first argument
14733 Typical Loop-Processing:
14734 from the front:
14735 while (argcount != 0) {
14736 var object arg = NEXT(rest_args_pointer); ...; argcount--;
14737 }
14738 while (rest_args_pointer != args_end_pointer) {
14739 var object arg = NEXT(rest_args_pointer); ...;
14740 }
14741 from the back:
14742 while (argcount != 0) {
14743 var object arg = BEFORE(args_end_pointer); ...; argcount--;
14744 }
14745 while (rest_args_pointer != args_end_pointer) {
14746 var object arg = BEFORE(args_end_pointer); ...;
14747 }
14748 The macros NEXT and BEFORE modify their arguments!
14749 Clean STACK: with set_args_end_pointer(args_pointer)
14750 or skipSTACK((fixed number of arguments) + (uintL) (number of remainung arguments)) . */
14751 #define args_end_pointer STACK
14752 #define set_args_end_pointer(new_args_end_pointer) \
14753 setSTACK(STACK = (new_args_end_pointer))
14754 #ifdef STACK_DOWN
14755 #define NEXT(argpointer) (*(--(argpointer)))
14756 #define BEFORE(argpointer) (*((argpointer)++))
14757 #endif
14758 #ifdef STACK_UP
14759 #define NEXT(argpointer) (*((argpointer)++))
14760 #define BEFORE(argpointer) (*(--(argpointer)))
14761 #endif
14762 /* Next(pointer) yields the same value as NEXT(pointer),
14763 but without changing the value of pointer.
14764 Before(pointer) yields the same value as BEFORE(pointer),
14765 but without changing the value of pointer. */
14766 #define Next(pointer) (*(STACKpointable(pointer) STACKop -1))
14767 #define Before(pointer) (*(STACKpointable(pointer) STACKop 0))
14768 %% #if !defined(MULTITHREAD)
14769 %% emit_define("args_end_pointer","STACK");
14770 %% #if notused
14771 %% emit_define("set_args_end_pointer(new_args_end_pointer)","STACK = (new_args_end_pointer)");
14772 %% export_def(NEXT(argpointer));
14773 %% export_def(BEFORE(argpointer));
14774 %% emit_define("Next(pointer)","(*(STACKpointable(pointer) STACKop -1))");
14775 %% emit_define("Before(pointer)","(*(STACKpointable(pointer) STACKop 0))");
14776 %% #endif
14777 %% #endif
14778
14779 /* Environments: */
14780
14781 typedef struct {
14782 object var_env; /* Variable-Bindings-Environment */
14783 object fun_env; /* Function-Bindings-Environment */
14784 object block_env; /* Block-Environment */
14785 object go_env; /* Tagbody/Go-Environment */
14786 object decl_env; /* Declarations-Environment */
14787 } environment_t;
14788 typedef struct {
14789 gcv_object_t var_env; /* Variable-Bindings-Environment */
14790 gcv_object_t fun_env; /* Function-Bindings-Environment */
14791 gcv_object_t block_env; /* Block-Environment */
14792 gcv_object_t go_env; /* Tagbody/Go-Environment */
14793 gcv_object_t decl_env; /* Declarations-Environment */
14794 } gcv_environment_t;
14795
14796 /* The current Environment: */
14797 extern gcv_environment_t aktenv;
14798
14799 /* Macro: Puts five single Environments on the STACK
14800 and makes a single Environment out of them.
14801 make_STACK_env(venv,fenv,benv,genv,denv, env5 = );
14802 > object venv,fenv,benv,genv,denv: 5 single Environments
14803 < gcv_environment_t* env5: pointer to the Environment on the Stack */
14804 #ifdef STACK_UP
14805 #define make_STACK_env(venv,fenv,benv,genv,denv,env5_assignment) \
14806 do { pushSTACK(venv); pushSTACK(fenv); pushSTACK(benv); \
14807 pushSTACK(genv); pushSTACK(denv); \
14808 env5_assignment &STACKblock_(gcv_environment_t,0); } while(0)
14809 #endif
14810 #ifdef STACK_DOWN
14811 #define make_STACK_env(venv,fenv,benv,genv,denv,env5_assignment) \
14812 do { pushSTACK(denv); pushSTACK(genv); pushSTACK(benv); \
14813 pushSTACK(fenv); pushSTACK(venv); \
14814 env5_assignment &STACKblock_(gcv_environment_t,0); } while(0)
14815 #endif
14816
14817 /* Frameinfobits in Frames:
14818 in the Frame-Info-Byte (tint): */
14819 #if (oint_type_len>=7) && 0 /* provisionally?? */
14820 /* Bit numbers in the Frame-Info-Byte:
14821 occupy Bits 6..0 (resp. Bits 7,5..0 if garcol_bit_t=7). */
14822 #ifdef TYPECODES
14823 #define FB7 garcol_bit_t
14824 #define FB6 (garcol_bit_t>TB5 ? TB5 : TB6)
14825 #define FB5 (garcol_bit_t>TB4 ? TB4 : TB5)
14826 #define FB4 (garcol_bit_t>TB3 ? TB3 : TB4)
14827 #define FB3 (garcol_bit_t>TB2 ? TB2 : TB3)
14828 #define FB2 (garcol_bit_t>TB1 ? TB1 : TB2)
14829 #define FB1 (garcol_bit_t>TB0 ? TB0 : TB1)
14830 #else
14831 #define FB7 garcol_bit_o
14832 #define FB6 30
14833 #define FB5 29
14834 #define FB4 28
14835 #define FB3 27
14836 #define FB2 26
14837 #define FB1 25
14838 #endif
14839 /* depending on it: */
14840 #define frame_bit_t FB7 /* garcol_bit as FRAME-identifier */
14841 /* define skip2_limit_t ... (below)
14842 frame_info < skip2_limit_t if the GC has to skip two long words
14843 frame_info >= skip2_limit_t if the GC has to skip only the frame bottom word */
14844 #define unwind_bit_t FB5 /* set if there's something to do while */
14845 /* unwinding the frame */
14846 /* frame_info >= skip2_limit_t ==> unwind-Bit=1. */
14847 /* for further Information within the Frames with frame_info >= skip2_limit_t: */
14848 #define envbind_bit_t FB4 /* Bit set for ENV-Frames. */
14849 /* Bit is unset for DYNBIND-Frames. */
14850 /* for further identification of the ENV-Frames: */
14851 #define envbind_case_mask_t (bit(FB3)|bit(FB2)|bit(FB1))
14852 /* for further discrimination within the Frames with frame_info < skip2_limit_t: */
14853 #define entrypoint_bit_t FB4 /* Bit is set, if FRAME contains */
14854 /* a non-local entrypoint, with Offset SP_, SP is on the STACK.
14855 Bit is unset for VAR/FUN-Frame and CALLBACK-Frame. */
14856 /* for further discrimination in BLOCK/TAGBODY/APPLY/EVAL/CATCH/UNWIND_PROTECT/HANDLER/C_HANDLER/DRIVER: */
14857 /* define blockgo_max_t (below)
14858 >= all BLOCK/TAGBODY frame infos,
14859 < UNWIND_PROTECT_frame_info, DRIVER_frame_info. */
14860 /* for further discrimination in BLOCK/TAGBODY: */
14861 #define nested_bit_t unwind_bit_t /* set for IBLOCK and ITAGBODY, */
14862 /* if Exitpoint resp. Tags were nested */
14863 /* for further discrimination in APPLY/EVAL/CATCH/UNWIND_PROTECT/HANDLER/C_HANDLER/DRIVER: */
14864 #define dynjump_mask_t bit(FB2) /* unset for APPLY and EVAL, */
14865 /* partially set for UNWIND_PROTECT/DRIVER-Frames */
14866 #define trapped_bit_t unwind_bit_t /* set for APPLY and EVAL, if */
14867 /* interrupted while unwinding the Frame */
14868 /* unwind-Bit set for UNWIND_PROTECT/DRIVER/TRAPPED_APPLY/TRAPPED_EVAL,
14869 else unset. */
14870 #define eval_bit_t FB1 /* set for EVAL-Frames, */
14871 /* unset for APPLY-Frames */
14872 #define driver_bit_t FB1 /* set for DRIVER-Frames, */
14873 /* unset for UNWIND_PROTECT-Frames */
14874 #define handler_bit_t FB2 /* set for HANDLER/C_HANDLER-Frames, */
14875 /* unset for CATCH-Frames */
14876 /* for further discrimination in VAR/FUN/CALLBACK: */
14877 #define callback_bit_t FB3 /* Bit is unset for CALLBACK-Frames. */
14878 /* Bit is set for VAR/FUN-Frames. */
14879 /* for further discrimination in VAR/FUN: */
14880 #define fun_bit_t FB2 /* set for FUN-Frame, unset for VAR-Frame */
14881 /* on objects on the STACK (oint): */
14882 #define frame_bit_o (frame_bit_t+oint_type_shift)
14883 #define unwind_bit_o (unwind_bit_t+oint_type_shift)
14884 #define envbind_bit_o (envbind_bit_t+oint_type_shift)
14885 #define callback_bit_o (callback_bit_t+oint_type_shift)
14886 #define entrypoint_bit_o (entrypoint_bit_t+oint_type_shift)
14887 #define nested_bit_o (nested_bit_t+oint_type_shift)
14888 #define trapped_bit_o (trapped_bit_t+oint_type_shift)
14889 #define eval_bit_o (eval_bit_t+oint_type_shift)
14890 #define driver_bit_o (driver_bit_t+oint_type_shift)
14891 #define handler_bit_o (handler_bit_t+oint_type_shift)
14892 #define fun_bit_o (fun_bit_t+oint_type_shift)
14893 /* single Frame-Info-Bytes: */
14894 #define DYNBIND_frame_info /* %1110... */ (bit(FB7)|bit(FB6)|bit(FB5))
14895 #define ENV1V_frame_info /* %1111000 */ (bit(FB7)|bit(FB6)|bit(FB5)|bit(FB4))
14896 #define ENV1F_frame_info /* %1111001 */ (bit(FB7)|bit(FB6)|bit(FB5)|bit(FB4)|bit(FB1))
14897 #define ENV1B_frame_info /* %1111010 */ (bit(FB7)|bit(FB6)|bit(FB5)|bit(FB4)|bit(FB2))
14898 #define ENV1G_frame_info /* %1111011 */ (bit(FB7)|bit(FB6)|bit(FB5)|bit(FB4)|bit(FB2)|bit(FB1))
14899 #define ENV1D_frame_info /* %1111100 */ (bit(FB7)|bit(FB6)|bit(FB5)|bit(FB4)|bit(FB3))
14900 #define ENV2VD_frame_info /* %1111101 */ (bit(FB7)|bit(FB6)|bit(FB5)|bit(FB4)|bit(FB3)|bit(FB1))
14901 #define ENV5_frame_info /* %1111110 */ (bit(FB7)|bit(FB6)|bit(FB5)|bit(FB4)|bit(FB3)|bit(FB2))
14902 #define skip2_limit_t (bit(FB7)|bit(FB6)|bit(FB5))
14903 #ifdef HAVE_SAVED_REGISTERS
14904 #define CALLBACK_frame_info /* %10100.. */ (bit(FB7)|bit(FB5))
14905 #endif
14906 #define VAR_frame_info /* %101010. */ (bit(FB7)|bit(FB5)|bit(FB3))
14907 #define FUN_frame_info /* %101011. */ (bit(FB7)|bit(FB5)|bit(FB3)|bit(FB2))
14908 #define IBLOCK_frame_info /* %1001000 */ (bit(FB7)|bit(FB4))
14909 #define NESTED_IBLOCK_frame_info /* %1011000 */ (bit(FB7)|bit(FB5)|bit(FB4))
14910 #define ITAGBODY_frame_info /* %1001010 */ (bit(FB7)|bit(FB4)|bit(FB2))
14911 #define NESTED_ITAGBODY_frame_info /* %1011010 */ (bit(FB7)|bit(FB5)|bit(FB4)|bit(FB2))
14912 #define CBLOCK_CTAGBODY_frame_info /* %1011001 */ (bit(FB7)|bit(FB5)|bit(FB4)|bit(FB1))
14913 #define APPLY_frame_info /* %1001100 */ (bit(FB7)|bit(FB4)|bit(FB3))
14914 #define TRAPPED_APPLY_frame_info /* %1011100 */ (bit(FB7)|bit(FB5)|bit(FB4)|bit(FB3))
14915 #define EVAL_frame_info /* %1001101 */ (bit(FB7)|bit(FB4)|bit(FB3)|bit(FB1))
14916 #define TRAPPED_EVAL_frame_info /* %1011101 */ (bit(FB7)|bit(FB5)|bit(FB4)|bit(FB3)|bit(FB1))
14917 #define CATCH_frame_info /* %1101000 */ (bit(FB7)|bit(FB6)|bit(FB4))
14918 #define HANDLER_frame_info /* %1101010 */ (bit(FB7)|bit(FB6)|bit(FB4)|bit(FB2))
14919 #define C_HANDLER_frame_info /* %1101011 */ (bit(FB7)|bit(FB6)|bit(FB4)|bit(FB2)|bit(FB1))
14920 #define UNWIND_PROTECT_frame_info /* %1011110 */ (bit(FB7)|bit(FB5)|bit(FB4)|bit(FB3)|bit(FB2))
14921 #define DRIVER_frame_info /* %1011111 */ (bit(FB7)|bit(FB5)|bit(FB4)|bit(FB3)|bit(FB2)|bit(FB1))
14922 #define blockgo_max_t (bit(FB7)|bit(FB5)|bit(FB4)|bit(FB2))
14923 #endif
14924 #if (oint_type_len==6) || 1 /* provisionally?? */
14925 /* bit numbers in Frame-Info-Byte:
14926 occupy Bits 5..0 (resp. Bits 7,4..0 if garcol_bit_t=7). */
14927 #ifdef TYPECODES
14928 #define FB6 garcol_bit_t
14929 #define FB5 (garcol_bit_t>TB4 ? TB4 : TB5)
14930 #define FB4 (garcol_bit_t>TB3 ? TB3 : TB4)
14931 #define FB3 (garcol_bit_t>TB2 ? TB2 : TB3)
14932 #define FB2 (garcol_bit_t>TB1 ? TB1 : TB2)
14933 #define FB1 (garcol_bit_t>TB0 ? TB0 : TB1)
14934 #else /* HEAPCODES */
14935 #define FB6 garcol_bit_o
14936 #ifdef ONE_FREE_BIT_HEAPCODES
14937 #define FB5 (garcol_bit_o-1)
14938 #define FB4 (garcol_bit_o-2)
14939 #define FB3 (garcol_bit_o-3)
14940 #define FB2 (garcol_bit_o-4)
14941 #define FB1 (garcol_bit_o-5)
14942 #endif
14943 #if defined(KERNELVOID32_HEAPCODES) || defined(GENERIC64_HEAPCODES)
14944 #define FB5 5
14945 #define FB4 4
14946 #define FB3 3
14947 #define FB2 2
14948 #define FB1 1
14949 #endif
14950 #endif
14951 /* depending on it: */
14952 #define frame_bit_t FB6 /* garcol_bit as FRAME-indicator */
14953 /* define skip2_limit_t ... (below)
14954 frame_info < skip2_limit_t if the GC has to skip two long words
14955 frame_info >= skip2_limit_t if the GC has to skip only the frame bottom word */
14956 /* define unwind_limit_t ... (below)
14957 frame_info >= unwind_limit_t if there's something to be done while unwinding the frame
14958 Note: skip2_limit_t >= unwind_limit_t. */
14959 /* for further information within the Frames with frame_info >= skip2_limit_t: */
14960 #define envbind_bit_t FB4 /* Bit is set for ENV-Frames. */
14961 /* Bit unset for DYNBIND-Frames. */
14962 /* for further identification within the ENV-Frames: */
14963 #define envbind_case_mask_t (bit(FB3)|bit(FB2)|bit(FB1))
14964 /* for further discrimination with the Frames with frame_info < skip2_limit_t:
14965 define entrypoint_limit_t ... (below)
14966 frame_info < entrypoint_limit_t
14967 if FRAME contains a non-local entry point
14968 with Offset SP_ SP is on the STACK.
14969 frame_info >= entrypoint_limit_t
14970 for VAR/FUN-Frame and CALLBACK-Frame. */
14971 /* for further discrimination in BLOCK/TAGBODY/APPLY/EVAL/CATCH/UNWIND_PROTECT/HANDLER/C_HANDLER/DRIVER: */
14972 /* define blockgo_max_t (below)
14973 >= all BLOCK/TAGBODY frame infos,
14974 < UNWIND_PROTECT_frame_info, DRIVER_frame_info. */
14975 /* for further discrimination in BLOCK/TAGBODY: */
14976 #define nested_bit_t FB4 /* set for IBLOCK and ITAGBODY, */
14977 /* if exit point or Tags have been nested */
14978 /* for further discrimination in APPLY/EVAL/CATCH/UNWIND_PROTECT/HANDLER/C_HANDLER/DRIVER: */
14979 #define dynjump_mask_t bit(FB3) /* unset for APPLY and EVAL, */
14980 /* partially set for UNWIND_PROTECT/DRIVER-Frames */
14981 #define trapped_bit_t FB4 /* set for APPLY and EVAL, if interrupted while */
14982 /* unwinding the Frames */
14983 /* >= unwind_limit_t for UNWIND_PROTECT/DRIVER/TRAPPED_APPLY/TRAPPED_EVAL,
14984 < unwind_limit_t else. */
14985 #define eval_bit_t FB1 /* set for EVAL-Frames, */
14986 /* unset for APPLY-Frames */
14987 #define driver_bit_t FB1 /* set for DRIVER-Frames, */
14988 /* unset for UNWIND_PROTECT-Frames */
14989 #define handler_bit_t FB2 /* set for HANDLER/C_HANDLER-Frames, */
14990 /* unset for CATCH-Frames */
14991 /* for further discrimination in VAR/FUN/CALLBACK: */
14992 #define callback_bit_t FB2 /* Bit is unset for CALLBACK-Frames. */
14993 /* Bit is set for VAR/FUN-Frames. */
14994 /* for further discrimination in VAR/FUN: */
14995 #define fun_bit_t FB1 /* set for FUN-Frame, unset for VAR-Frame */
14996 /* in Objects on the STACK (oint): */
14997 #define frame_bit_o (frame_bit_t+oint_type_shift)
14998 #define envbind_bit_o (envbind_bit_t+oint_type_shift)
14999 #define callback_bit_o (callback_bit_t+oint_type_shift)
15000 #define nested_bit_o (nested_bit_t+oint_type_shift)
15001 #define trapped_bit_o (trapped_bit_t+oint_type_shift)
15002 #define eval_bit_o (eval_bit_t+oint_type_shift)
15003 #define driver_bit_o (driver_bit_t+oint_type_shift)
15004 #define handler_bit_o (handler_bit_t+oint_type_shift)
15005 #define fun_bit_o (fun_bit_t+oint_type_shift)
15006 /* single Frame-Info-Bytes: */
15007 #define CATCH_frame_info /* %100000 */ (bit(FB6))
15008 #define APPLY_frame_info /* %100010 */ (bit(FB6)|bit(FB2))
15009 #define EVAL_frame_info /* %100011 */ (bit(FB6)|bit(FB2)|bit(FB1))
15010 #define HANDLER_frame_info /* %100100 */ (bit(FB6)|bit(FB3))
15011 #define C_HANDLER_frame_info /* %100101 */ (bit(FB6)|bit(FB3)|bit(FB1))
15012 #define IBLOCK_frame_info /* %100110 */ (bit(FB6)|bit(FB3)|bit(FB2))
15013 #define ITAGBODY_frame_info /* %100111 */ (bit(FB6)|bit(FB3)|bit(FB2)|bit(FB1))
15014 #define unwind_limit_t (bit(FB6)|bit(FB4))
15015 #define NESTED_IBLOCK_frame_info /* %101000 */ (bit(FB6)|bit(FB4))
15016 #define NESTED_ITAGBODY_frame_info /* %101001 */ (bit(FB6)|bit(FB4)|bit(FB1))
15017 #define TRAPPED_APPLY_frame_info /* %101010 */ (bit(FB6)|bit(FB4)|bit(FB2))
15018 #define TRAPPED_EVAL_frame_info /* %101011 */ (bit(FB6)|bit(FB4)|bit(FB2)|bit(FB1))
15019 #define CBLOCK_CTAGBODY_frame_info /* %101100 */ (bit(FB6)|bit(FB4)|bit(FB3))
15020 #define blockgo_max_t (bit(FB6)|bit(FB4)|bit(FB3))
15021 #define UNWIND_PROTECT_frame_info /* %101110 */ (bit(FB6)|bit(FB4)|bit(FB3)|bit(FB2))
15022 #define DRIVER_frame_info /* %101111 */ (bit(FB6)|bit(FB4)|bit(FB3)|bit(FB2)|bit(FB1))
15023 #define entrypoint_limit_t (bit(FB6)|bit(FB5))
15024 #ifdef HAVE_SAVED_REGISTERS
15025 #define CALLBACK_frame_info /* %110001 */ (bit(FB6)|bit(FB5)|bit(FB1))
15026 #endif
15027 #define VAR_frame_info /* %110010 */ (bit(FB6)|bit(FB5)|bit(FB2))
15028 #define FUN_frame_info /* %110011 */ (bit(FB6)|bit(FB5)|bit(FB2)|bit(FB1))
15029 #define skip2_limit_t (bit(FB6)|bit(FB5)|bit(FB3))
15030 #define DYNBIND_frame_info /* %1101.. */ (bit(FB6)|bit(FB5)|bit(FB3))
15031 #define ENV1V_frame_info /* %111000 */ (bit(FB6)|bit(FB5)|bit(FB4))
15032 #define ENV1F_frame_info /* %111001 */ (bit(FB6)|bit(FB5)|bit(FB4)|bit(FB1))
15033 #define ENV1B_frame_info /* %111010 */ (bit(FB6)|bit(FB5)|bit(FB4)|bit(FB2))
15034 #define ENV1G_frame_info /* %111011 */ (bit(FB6)|bit(FB5)|bit(FB4)|bit(FB2)|bit(FB1))
15035 #define ENV1D_frame_info /* %111100 */ (bit(FB6)|bit(FB5)|bit(FB4)|bit(FB3))
15036 #define ENV2VD_frame_info /* %111101 */ (bit(FB6)|bit(FB5)|bit(FB4)|bit(FB3)|bit(FB1))
15037 #define ENV5_frame_info /* %111110 */ (bit(FB6)|bit(FB5)|bit(FB4)|bit(FB3)|bit(FB2))
15038 #endif
15039 #define CBLOCK_frame_info CBLOCK_CTAGBODY_frame_info
15040 #define CTAGBODY_frame_info CBLOCK_CTAGBODY_frame_info
15041 %% #ifdef HAVE_SAVED_REGISTERS
15042 %% export_def(CALLBACK_frame_info);
15043 %% #endif
15044
15045 /* Bits for Symbols in VAR-Frames:
15046 bit(active_bit),bit(dynam_bit),bit(svar_bit) must fit into one uintB: */
15047 #if !((active_bit<intBsize) && (dynam_bit<intBsize) && (svar_bit<intBsize))
15048 #error Symbol bits do not fit in a single byte -- Symbol-Bits passen nicht in ein Byte!
15049 #endif
15050 #ifdef NO_symbolflags
15051 /* Bits are separatly stored on the Stack as Fixnums. */
15052 #undef oint_symbolflags_shift
15053 #define oint_symbolflags_shift oint_data_shift
15054 #else
15055 #if (oint_symbolflags_shift==oint_addr_shift)
15056 /* bit(active_bit),bit(dynam_bit),bit(svar_bit) must be true divisors
15057 of varobject_alignment: */
15058 #if (varobject_alignment % bit(active_bit+1)) || (varobject_alignment % bit(dynam_bit+1)) || (varobject_alignment % bit(svar_bit+1))
15059 #error No more room for three bits in a symbol -- Kein Platz fuer drei Bits in der Adresse eines Symbols!
15060 #endif
15061 #endif
15062 #endif
15063 #define active_bit_o (active_bit+oint_symbolflags_shift) /* set: binding is active */
15064 #define dynam_bit_o (dynam_bit+oint_symbolflags_shift) /* set: binding is dynamic */
15065 #define svar_bit_o (svar_bit+oint_symbolflags_shift) /* set: next parameter is supplied-p-parameter for this */
15066
15067 /* Offsets for data in Frames, to be addressed via STACK_(Offset) */
15068 #define frame_form 2 /* EVAL */
15069 #define frame_closure 2 /* APPLY, HANDLER */
15070 #define frame_count 1 /* VAR, FUN */
15071 #define frame_SP 1 /* IBLOCK, CBLOCK, ITAGBODY, CTAGBODY, */
15072 /* EVAL, CATCH, UNWIND-PROTECT, HANDLER, C_HANDLER, DRIVER */
15073 #define frame_next_env 2 /* VAR, FUN, IBLOCK, ITAGBODY */
15074 #define frame_ctag 2 /* CBLOCK, CTAGBODY */
15075 #define frame_tag 2 /* CATCH */
15076 #define frame_handlers 3 /* HANDLER, C_HANDLER */
15077 #define frame_name 3 /* IBLOCK */
15078 #define frame_args 3 /* APPLY */
15079 #define frame_bindings 3 /* VAR, FUN, ITAGBODY */
15080 /* Structure of the different bindings in VAR-Frames: */
15081 #ifdef NO_symbolflags
15082 #define varframe_binding_size 3
15083 #define varframe_binding_mark 0
15084 #define varframe_binding_sym 1
15085 #define varframe_binding_value 2
15086 #define pushSTACK_symbolwithflags(symbol,flags) \
15087 pushSTACK(symbol); pushSTACK(as_object(as_oint(Fixnum_0) | (oint)(flags)))
15088 #else
15089 #define varframe_binding_size 2
15090 #define varframe_binding_mark 0
15091 #define varframe_binding_sym 0
15092 #define varframe_binding_value 1
15093 #define pushSTACK_symbolwithflags(symbol,flags) \
15094 pushSTACK(as_object(as_oint(symbol) | (oint)(flags)))
15095 #endif
15096
15097 /* Special value to mark BLOCK- and TAGBODY-references that are not 'live'
15098 anymore (replaces the Frame-Pointer in the CDR of the corresponding Cons) */
15099 #define disabled make_system(0xDDDDDDUL)
15100
15101 /* Value to mark specially declared references */
15102 #define specdecl make_system(0xECDECDUL)
15103
15104 /* Value to mark implementation-dependent references */
15105 #define impdependent make_system(0xDE6114UL)
15106
15107 /* Handling Frames:
15108 A local variable FRAME contains the value of STACK after
15109 creating a Frame. Then you can access with FRAME_(n) just like
15110 with likeSTACK_(n): */
15111 #ifdef STACK_DOWN
15112 #define FRAME_(n) (FRAME[(sintP)(n)])
15113 #endif
15114 #ifdef STACK_UP
15115 #define FRAME_(n) (FRAME[-1-(sintP)(n)])
15116 #endif
15117 /* make_framepointer(FRAME) is the Frame-Pointer as LISP-object.
15118 framecode(FRAME_(0)) is the Frame-Info-Byte (of Type fcint),
15119 topofframe(FRAME_(0)) is a Pointer above the Frame.
15120 FRAME = uTheFramepointer(obj) is a Frame-Pointer as pointer into the Stack.
15121 [uTheFramepointer is the exact opposite of make_framepointer.]
15122 FRAME = TheFramepointer(obj) as well, but possibly still with type info!
15123 [An attenuation of uTheFramepointer, that is enough for access.] */
15124 #ifdef TYPECODES
15125 #if !defined(SINGLEMAP_MEMORY_STACK)
15126 #define make_framepointer(stack_ptr) type_pointer_object(system_type,stack_ptr)
15127 #define topofframe(bottomword) (gcv_object_t*)upointer(bottomword)
15128 #define uTheFramepointer(obj) (gcv_object_t*)upointer(obj)
15129 #else
15130 #define make_framepointer(stack_ptr) (as_object((oint)(stack_ptr)))
15131 #define topofframe(bottomword) (gcv_object_t*)as_oint(type_pointer_object(system_type,upointer(bottomword)))
15132 #define uTheFramepointer(obj) TheFramepointer(obj) /* = (gcv_object_t*)(obj) */
15133 #endif
15134 #define framecode(bottomword) mtypecode(bottomword)
15135 typedef tint fcint;
15136 #else
15137 /* Here the bottomword consists of the frame size, not the top of frame itself.
15138 This leaves room for the frame info byte. */
15139 #define make_framepointer(stack_ptr) make_machine(stack_ptr)
15140 #ifdef ONE_FREE_BIT_HEAPCODES
15141 #define makebottomword(type,size) as_object((oint)(type)+(oint)(size))
15142 #define framecode(bottomword) (as_oint(bottomword) & minus_wbit(FB1))
15143 #define framesize(bottomword) (as_oint(bottomword)&(wbit(FB1)-1))
15144 #endif
15145 #if defined(KERNELVOID32_HEAPCODES) || defined(GENERIC64_HEAPCODES)
15146 #define makebottomword(type,size) as_object((oint)(type)+((oint)(size)<<6))
15147 #define framecode(bottomword) (as_oint(bottomword) & 0x3F)
15148 #define framesize(bottomword) (as_oint(bottomword) >> 6)
15149 #endif
15150 #ifdef STACK_UP
15151 #define topofframe(bottomword) \
15152 (gcv_object_t*)((uintP)(&(bottomword))-(uintP)framesize(bottomword)+sizeof(gcv_object_t))
15153 #endif
15154 #ifdef STACK_DOWN
15155 #define topofframe(bottomword) \
15156 (gcv_object_t*)((uintP)(&(bottomword))+(uintP)framesize(bottomword))
15157 #endif
15158 #define uTheFramepointer(obj) TheFramepointer(obj) /* = (gcv_object_t*)(obj) */
15159 typedef oint fcint;
15160 #endif
15161 /* is used by EVAL, CONTROL, DEBUG */
15162 %% #ifdef HEAPCODES
15163 %% export_def(makebottomword(type,size));
15164 %% #endif
15165 %% export_def(framecode(bottomword));
15166
15167 /* To determine the size of a frame:
15168 STACK_item_count(new_STACK_ptr,old_STACK_ptr)
15169 calculates the number of STACK-elements between an older stack pointer
15170 old_STACK_ptr and a new one new_STACK_ptr.
15171 (That's count with old_STACK_ptr = new_STACK_ptr STACKop count .) */
15172 #ifdef STACK_DOWN
15173 #define STACK_item_count(new_STACK_ptr,old_STACK_ptr) \
15174 (uintL)((old_STACK_ptr) - (new_STACK_ptr))
15175 #endif
15176 #ifdef STACK_UP
15177 #define STACK_item_count(new_STACK_ptr,old_STACK_ptr) \
15178 (uintL)((new_STACK_ptr) - (old_STACK_ptr))
15179 #endif
15180
15181 /* Finishes a frame.
15182 finish_frame(frametype);
15183 > gcv_object_t* top_of_frame: pointer to the top of the frame
15184 decreases STACK by 1 */
15185 #ifdef TYPECODES
15186 #if !defined(SINGLEMAP_MEMORY_STACK)
15187 #define framebottomword(type,top_of_frame,bot_of_frame) \
15188 type_pointer_object(type,top_of_frame)
15189 #else /* top_of_frame has already Typinfo system_type */
15190 #define framebottomword(type,top_of_frame,bot_of_frame) \
15191 as_object(type_zero_oint(type)-type_zero_oint(system_type)+(oint)(top_of_frame))
15192 #endif
15193 #define finish_frame(frametype) \
15194 pushSTACK(framebottomword(frametype##_frame_info,top_of_frame,bot_of_frame_ignored))
15195 #else
15196 #ifdef STACK_UP
15197 #define framebottomword(type,top_of_frame,bot_of_frame) \
15198 makebottomword(type,(uintP)(bot_of_frame)-(uintP)(top_of_frame))
15199 #endif
15200 #ifdef STACK_DOWN
15201 #define framebottomword(type,top_of_frame,bot_of_frame) \
15202 makebottomword(type,(uintP)(top_of_frame)-(uintP)(bot_of_frame))
15203 #endif
15204 #define finish_frame(frametype) \
15205 (STACK_(-1) = framebottomword(frametype##_frame_info,top_of_frame,STACK STACKop -1), skipSTACK(-1))
15206 #endif
15207 /* is used by EVAL, CONTROL */
15208 %% export_def(framebottomword(type,top_of_frame,bot_of_frame));
15209 %% export_def(finish_frame(frametype));
15210
15211 /* Makes a Frame for all 5 Environments
15212 make_ENV5_frame();
15213 decreases STACK by 5 */
15214 #define make_ENV5_frame() \
15215 do { var gcv_object_t* top_of_frame = STACK; \
15216 pushSTACK(aktenv.decl_env); \
15217 pushSTACK(aktenv.go_env); \
15218 pushSTACK(aktenv.block_env); \
15219 pushSTACK(aktenv.fun_env); \
15220 pushSTACK(aktenv.var_env); \
15221 finish_frame(ENV5); \
15222 } while(0)
15223 /* is used by EVAL, CONTROL, DEBUG */
15224
15225 /* Finishes a Frame with entry point and places jump-point here.
15226 finish_entry_frame(frametype,returner,retval_assignment,reentry_statement);
15227 > gcv_object_t* top_of_frame: pointer to the top of the frame
15228 > sp_jmp_buf* returner: longjmp-Buffer for re-entry
15229 > retval_assignment: allocated of the setjmp()-value to a variable
15230 > reentry_statement: what is to be done immediately after re-entry.
15231 decreases STACK by 1 */
15232 #define finish_entry_frame(frametype,returner,retval_assignment,reentry_statement) \
15233 do { pushSTACK(fake_gcv_object((aint)(returner))); /* SP onto the Stack */\
15234 pushSTACK(nullobj); /* dummy onto the Stack, until re-entry is permitted */\
15235 begin_setjmp_call(); \
15236 if ((retval_assignment setjmpspl(returner))!=0) /* set point for returner */\
15237 { end_longjmp_call(); LONGJMP_RESTORE_mv_count(); LONGJMP_RESTORE_value1(); reentry_statement } /* after re-entry */\
15238 else \
15239 { end_setjmp_call(); STACK_0 = framebottomword(frametype##_frame_info,top_of_frame,STACK); } \
15240 } while(0)
15241 /* is used by EVAL, CONTROL, DEBUG */
15242
15243 #ifdef MULTITHREAD
15244 /* unwind pinned objects up to the current stack location in thread.
15245 executes statement for each object that has been unpinned */
15246 #define unwind_pinned_objects(thread) \
15247 do { \
15248 var clisp_thread_t *thr = thread; \
15249 var pinned_chain_t **p = &(thr->_pinned); \
15250 while (*p && !((aint)(thr->_STACK) cmpSTACKop (aint)(*p)->pc_unwind_stack_ptr)) { \
15251 *p = (*p)->pc_next; \
15252 } \
15253 } while(0)
15254 #else /* !MULTITHREAD */
15255 #define unwind_pinned_objects(thread)
15256 #endif
15257
15258 /* Jumps to a Frame with entry point that starts at STACK.
15259 (Important: The STACK has to have the same values it had when the
15260 frame was created, since the STACK might not be saved at setjmp/longjmp)
15261 Never returns and cleans the SP!!
15262 The multiple values are passed.
15263 enter_frame_at_STACK(); */
15264 #define enter_frame_at_STACK() do { \
15265 /* the returner of finish_entry_frame: */ \
15266 var sp_jmp_buf* returner = (sp_jmp_buf*)(aint)as_oint(STACK_(frame_SP)); \
15267 unwind_back_trace(back_trace,STACK); \
15268 unwind_pinned_objects(current_thread()); \
15269 LONGJMP_SAVE_value1(); LONGJMP_SAVE_mv_count(); \
15270 begin_longjmp_call(); \
15271 longjmpspl(*returner,(aint)returner);/* jump there, pass own addess (/=0) */\
15272 NOTREACHED; \
15273 } while(0)
15274 /* is used by EVAL */
15275
15276 /* Makes a C_HANDLER-Frame.
15277 make_C_HANDLER_frame(types_labels_vector_list,handler,sp_arg);
15278 make_C_HANDLER_entry_frame(types_labels_vector_list,handler,returner,reentry_statement);
15279 > object types_labels_vector_list: a list containing a simple-vector: (#(type1 label1 ... typem labelm))
15280 > handler: void (*) (void* sp, gcv_object_t* frame, object label, object condition)
15281 > sp_arg: a pointer into the C stack, or NULL
15282 > sp_jmp_buf* returner: longjmp-Buffer for re-entry
15283 > reentry_statement: what is to be done right after the re-entry. */
15284 #define make_C_HANDLER_frame(types_labels_vector_list,handler,sp_arg) \
15285 do { var gcv_object_t* top_of_frame = STACK; \
15286 pushSTACK(types_labels_vector_list); \
15287 pushSTACK(fake_gcv_object((aint)(void*)(handler))); \
15288 pushSTACK(fake_gcv_object((aint)(sp_arg))); \
15289 finish_frame(C_HANDLER); \
15290 } while(0)
15291 #define make_C_HANDLER_entry_frame(types_labels_vector_list,handler,returner,reentry_statement) \
15292 do { var gcv_object_t* top_of_frame = STACK; \
15293 pushSTACK(types_labels_vector_list); \
15294 pushSTACK(fake_gcv_object((aint)(void*)(handler))); \
15295 finish_entry_frame(C_HANDLER,returner,,reentry_statement); \
15296 } while(0)
15297 #define unwind_C_HANDLER_frame() skipSTACK(4)
15298
15299 /* UP: Applies a function to its arguments.
15300 apply(function,args_on_stack,other_args);
15301 > function: function
15302 > Arguments: args_on_stack arguments on the STACK,
15303 remaining argument-list in other_args
15304 < STACK: cleaned (ie. STACK is increased by args_on_stack)
15305 < mv_count/mv_space: values
15306 modifies STACK, can trigger GC */
15307 extern maygc Values apply (object fun, uintC args_on_stack, object other_args);
15308 /* is used by EVAL, CONTROL, IO, PATHNAME, ERROR */
15309 %% #if notused
15310 %% exportF(Values,apply,(object fun, uintC args_on_stack, object other_args));
15311 %% #endif
15312
15313 /* UP: Applies a function to its arguments.
15314 funcall(function,argcount);
15315 > function: function
15316 > Arguments: argcount arguments on the STACK
15317 < STACK: cleaned (ie. STACK is increased by argcount)
15318 < mv_count/mv_space: values
15319 modifies STACK, can trigger GC */
15320 extern maygc Values funcall (object fun, uintC argcount);
15321 /* is used by all Modules */
15322 %% exportF(Values,funcall,(object fun, uintC argcount));
15323
15324 /* UP: Evaluates a Form in the current Environment.
15325 eval(form);
15326 > form: Form
15327 < mv_count/mv_space: values
15328 can trigger GC */
15329 extern maygc Values eval (object form);
15330 /* is used by CONTROL, DEBUG */
15331 %% #if notused
15332 %% exportF(Values,eval,(object form));
15333 %% #endif
15334
15335 /* UP: Evaluates a Form in a given Environment.
15336 eval_5env(form,var,fun,block,go,decl);
15337 > var_env: Value for VAR_ENV
15338 > fun_env: Value for FUN_ENV
15339 > block_env: Value for BLOCK_ENV
15340 > go_env: Value for GO_ENV
15341 > decl_env: Value for DECL_ENV
15342 > form: Form
15343 < mv_count/mv_space: Values
15344 can trigger GC */
15345 extern maygc Values eval_5env (object form, object var_env, object fun_env, object block_env, object go_env, object decl_env);
15346 /* is used by */
15347
15348 /* UP: Evaluates a Form in an empty Environment.
15349 eval_noenv(form);
15350 > form: Form
15351 < mv_count/mv_space: Values
15352 can trigger GC */
15353 extern maygc Values eval_noenv (object form);
15354 /* is used by CONTROL, IO, DEBUG, SPVW */
15355
15356 /* UP: Evaluates a Form in the current Environment. Doesn't care about
15357 *EVALHOOK* and *APPLYHOOK*.
15358 eval_no_hooks(form);
15359 > form: Form
15360 < mv_count/mv_space: Values
15361 can trigger GC */
15362 extern maygc Values eval_no_hooks (object form);
15363 /* is used by CONTROL */
15364
15365 /* UP: signal an error on a dotted form in EVAL
15366 error_dotted_form(form,fun)
15367 > form: full form being evaluated
15368 > fun: caller (car form) */
15369 global _Noreturn void error_dotted_form (object form, object fun);
15370 /* is used by CONTROL */
15371
15372 /* UP: binds *EVALHOOK* and *APPLYHOOK* dynamically to the given values.
15373 bindhooks(evalhook_value,applyhook_value);
15374 > evalhook_value: Value for *EVALHOOK*
15375 > applyhook_value: Value for *APPLYHOOK*
15376 modifies STACK */
15377 extern void bindhooks (object evalhook_value, object applyhook_value);
15378 /* is used by CONTROL */
15379
15380 /* UP: Unwinds a Frame, to which STACK points.
15381 unwind();
15382 The values mv_count/mv_space aren't changed.
15383 If it is no Unwind-Protect-Frame: returns normally.
15384 If it is an Unwind-Protect-Frame:
15385 saves the values, climbs up the STACK and SP
15386 and then jumps to unwind_protect_to_save.fun.
15387 modifies STACK
15388 can trigger GC */
15389 typedef _GL_NORETURN_FUNCPTR /*maygc*/ void (*restartf_t) (gcv_object_t* upto_frame);
15390 typedef struct {
15391 restartf_t fun;
15392 gcv_object_t* upto_frame;
15393 } unwind_protect_caller_t;
15394 extern unwind_protect_caller_t unwind_protect_to_save;
15395 extern /*maygc*/ void unwind (void);
15396 /* is used by CONTROL, DEBUG, SPVW */
15397
15398 /* UP: "unwinds" the STACK to the next DRIVER_FRAME and
15399 jumps to the corresponding Top-Level-loop
15400 if count=0, unwind to TOP; otherwise reset that many times */
15401 extern _GL_NORETURN_FUNC void reset (uintL count);
15402 /* is used by SPVW, CONTROL */
15403
15404 /* UP: binds the symbols of the list symlist dynamically
15405 to the values of the list vallist.
15406 progv(symlist,vallist);
15407 > symlist, vallist: two lists
15408 Exactly one variable-bindings-frame is created.
15409 modifies STACK
15410 can trigger GC */
15411 extern maygc void progv (object symlist, object vallist);
15412 /* used by CONTROL, EVAL */
15413
15414 /* UP: Unwinds the dynamic nesting on the STACK until the frame
15415 (exclusively), to which upto points, and jumps to it.
15416 unwind_upto(upto);
15417 > upto: Pointer to a Frame (into the Stack, without type-info).
15418 Saves the values mv_count/mv_space.
15419 modifies STACK,SP
15420 can trigger GC
15421 Jumps to the found Frame. */
15422 extern _GL_NORETURN_FUNC /*maygc*/ void unwind_upto (gcv_object_t* upto_frame);
15423 /* is used by CONTROL, DEBUG */
15424
15425 /* UP: throws to the Tag tag and passes the values mv_count/mv_space.
15426 Only returns, if there is no CATCH-Frame of this tag.
15427 throw_to(tag); */
15428 extern void throw_to (object tag);
15429 /* is used by CONTROL */
15430
15431 /* UP: Invokes all handlers for the condition cond. Only returns, if none
15432 of the handlers feels responsible (ie. if every handler returns).
15433 invoke_handlers(cond);
15434 can trigger GC */
15435 extern maygc void invoke_handlers (object cond);
15436 typedef struct {
15437 object condition;
15438 gcv_object_t* stack;
15439 SPint* sp;
15440 object spdepth;
15441 } handler_args_t;
15442 extern handler_args_t handler_args;
15443 typedef struct stack_range_t {
15444 struct stack_range_t * next;
15445 gcv_object_t* low_limit;
15446 gcv_object_t* high_limit;
15447 } stack_range_t;
15448 extern stack_range_t* inactive_handlers;
15449 /* is used by ERROR */
15450
15451 /* UP: Determines, whether an Object is a function name, ie. a Symbol or
15452 a list of the form (SETF symbol).
15453 funnamep(obj)
15454 > obj: Objekt
15455 < result: true if function name */
15456 extern bool funnamep (object obj);
15457 /* is used by CONTROL */
15458
15459 /* Gives the block-name that belongs to the function name.
15460 funname_blockname(obj)
15461 > obj: a Symbol or (SETF symbol)
15462 < result: Block-name, a Symbol */
15463 #define funname_blockname(obj) \
15464 (atomp(obj) ? (object)obj : (object)Car(Cdr(obj)))
15465
15466 /* UP: Determines, whether a Symbol is a Macro in the current Environment.
15467 sym_macrop(symbol)
15468 > symbol: Symbol
15469 < result: true if sym is a Symbol-Macro
15470 can trigger GC */
15471 extern maygc bool sym_macrop (object sym);
15472 /* is used by CONTROL */
15473
15474 /* UP: Sets the value of a Symbol in the current Environment.
15475 setq(symbol,value);
15476 > symbol: Symbol, not a constant
15477 > value: desired value of the Symbol in the current Environment
15478 < result: value
15479 can trigger GC */
15480 extern maygc object setq (object sym, object value);
15481 /* used by CONTROL */
15482
15483 /* UP: Gives the definition of the function for a Symbol in an Environment
15484 sym_function(sym,fenv)
15485 > sym: name of the function (a Symbol for example)
15486 > fenv: a Functions- and Macrobindings-Environment
15487 < result: Definition of the function, either unbound (if function is undefined)
15488 or Closure/SUBR/FSUBR/Macro/FunctionMacro. */
15489 extern object sym_function (object sym, object fenv);
15490 /* is used by CONTROL */
15491
15492 /* UP: "nests" an FUN-Environment, ie. writes all active bindings
15493 from the Stack to freshly allocated Vectors..
15494 nest_fun(env)
15495 > env: FUN-Env
15496 < result: same Environment, no pointer into the Stack
15497 can trigger GC */
15498 extern maygc object nest_fun (object env);
15499 /* is used by CONTROL */
15500
15501 /* UP: Nests the Environments in *env (ie. write all information
15502 to Stack-independent structures) and pushes it onto the STACK.
15503 nest_env(env)
15504 > gcv_environment* env: Pointer to five single Environments
15505 < gcv_environment* result: Pointer to the Environments on the STACK
15506 modifies STACK, can trigger GC */
15507 extern maygc gcv_environment_t* nest_env (gcv_environment_t* env);
15508 /* is used by Macro nest_aktenv */
15509
15510 /* UP: Nests the current environments (ie. writes all information
15511 to Stack-independent structures) and pushes them onto the STACK.
15512 (The values VAR_ENV, FUN_ENV, BLOCK_ENV, GO_ENV, DECL_ENV aren't
15513 modified, since there might be inactive bindings in frames that cannot
15514 be activated without modifying VAR_ENV .)
15515 nest_aktenv()
15516 < gcv_environment* result: Pointer to the Environments on the STACK
15517 modifies STACK, can trigger GC
15518 extern gcv_environment* nest_aktenv (void); */
15519 #define nest_aktenv() nest_env(&aktenv)
15520 /* is used by CONTROL */
15521
15522 /* UP: Augments a Declarations-Environment with one decl-spec.
15523 augment_decl_env(declspec,env)
15524 > declspec: Declarations-Specifier, a Cons
15525 > env: Declarations-Environment
15526 < result: new (possibly augmented) Declarations-Environment
15527 can trigger GC */
15528 extern maygc object augment_decl_env (object new_declspec, object env);
15529 /* is used by CONTROL */
15530
15531 /* UP: expands a Form, if possible, (but not, if FSUBR-call
15532 or Symbol or FunctionMacro-call) in an Environment
15533 macroexp(form,venv,fenv);
15534 > form: Form
15535 > venv: a Variable- and Symbolmacro-Environment
15536 > fenv: a Function- and Macrobindings-Environment
15537 < value1: the expansion
15538 < value2: NIL, if not expanded,
15539 T, if expanded
15540 can trigger GC */
15541 extern maygc void macroexp (object form, object venv, object fenv);
15542 /* is used by CONTROL */
15543
15544 /* UP: expands a Form if possible, (also, if FSUBR-call or
15545 Symbol, but not if FunctionMacro-call) in an environment
15546 macroexp0(form,env);
15547 > form: Form
15548 > env: a macro-expansion environment
15549 < value1: the expansion
15550 < value2: NIL, if not expanded,
15551 T, if expanded
15552 can trigger GC */
15553 extern maygc void macroexp0 (object form, object env);
15554 /* is used by CONTROL */
15555
15556 /* UP: Parse-Declarations-Docstring. Detaches from a Form-list those,
15557 that must be viewed as Declarations resp. Documentation-string.
15558 parse_dd(formlist)
15559 > formlist: ( {decl|doc-string} . body )
15560 < value1: body
15561 < value2: list of decl-specs
15562 < value3: Doc-String or NIL
15563 < result: name if a (COMPILE name)-declaration occurred,
15564 unbound if a (COMPILE)-declaration occurred, else Fixnum_0
15565 can trigger GC */
15566 extern maygc object parse_dd (object formlist);
15567 /* is used by CONTROL */
15568
15569 /* UP: Creates a corresponding Closure for a Lambda-body by disassembling
15570 the Lambda-list and possibly macro-expanding of all forms.
15571 get_closure(lambdabody,name,blockp,env)
15572 > lambdabody: (lambda-list {decl|doc} {form})
15573 > name: Name, a Symbol or (SETF symbol)
15574 > blockp: whether an implicit BLOCK is to be added
15575 > env: Pointer to the five individual environments:
15576 env->var_env = VENV, env->fun_env = FENV,
15577 env->block_env = BENV, env->go_env = GENV,
15578 env->decl_env = DENV.
15579 < result: Closure
15580 can trigger GC */
15581 extern maygc object get_closure (object lambdabody, object name, bool blockp, gcv_environment_t* env);
15582 /* is used by CONTROL, SYMBOL, PREDTYPE */
15583
15584 /* UP: Converts an argument to a function.
15585 coerce_function(obj)
15586 > obj: Object
15587 < result: Object as function (SUBR or Closure)
15588 can trigger GC */
15589 extern maygc object coerce_function (object obj);
15590 /* is used by IO, FOREIGN */
15591
15592 /* Binds a Symbol dynamically to a value.
15593 Creates a dynamic variable-bindings frame for 1 variable.
15594 dynamic_bind(var,val)
15595 > var: a Symbol
15596 > val: the new value
15597 decreases STACK by 3 entries
15598 modifies STACK */
15599 #define dynamic_bind(variable,val_to_use) \
15600 do { var gcv_object_t* top_of_frame = STACK; \
15601 var object sym_to_bind = (variable); \
15602 /* Create frame : */\
15603 pushSTACK(Symbol_thread_value(sym_to_bind)); \
15604 pushSTACK(sym_to_bind); \
15605 finish_frame(DYNBIND); \
15606 /* modify value */\
15607 Symbol_thread_value(sym_to_bind) = (val_to_use); \
15608 } while(0)
15609 /* is used by IO, EVAL, DEBUG, ERROR */
15610
15611 /* Unbinds a dynamic variable-bindings frame for one variable.
15612 dynamic_unbind_g() - generic
15613 dynamic_unbind(sym) - with an additional check when STACKCHECKB
15614 increases STACK by 3 entries
15615 modifies STACK */
15616 #if STACKCHECKB
15617 #define CHECK_DYNBIND \
15618 if (!((as_oint(STACK_0) & wbit(frame_bit_o)) && framecode(STACK_0))) \
15619 abort()
15620 #else
15621 #define CHECK_DYNBIND
15622 #endif
15623 #define dynamic_unbind_g() do { \
15624 CHECK_DYNBIND; \
15625 Symbol_value(STACK_(1)) = STACK_(2); /* restore the value */ \
15626 skipSTACK(3); /* dismantle Frame */ \
15627 } while(0)
15628 #if STACKCHECKB
15629 #define dynamic_unbind(sym) do { \
15630 if (!eq(sym,STACK_1)) abort(); \
15631 dynamic_unbind_g(); \
15632 } while(0)
15633 #else
15634 #define dynamic_unbind(sym) dynamic_unbind_g()
15635 #endif
15636 /* is used by IO, DEBUG, ERROR, EVAL, PREDTYPE, SPVW */
15637
15638 /* Executes "implicit PROGN" .
15639 implicit_progn(body,default)
15640 Executes body as implicit PROGN.
15641 If the body is empty, the value is the default one.
15642 can trigger GC */
15643 #define implicit_progn(body,default) \
15644 do { \
15645 var object rest = (body); \
15646 if (atomp(rest)) { \
15647 VALUES1(default); /* default as value */\
15648 } else \
15649 do { pushSTACK(Cdr(rest)); eval(Car(rest)); rest = popSTACK(); } \
15650 while (consp(rest)); \
15651 } while(0)
15652 /* is used by EVAL, CONTROL */
15653
15654 /* Highest number of parameters in a lambda-list (< bitm(intCsize))
15655 (= value of LAMBDA-PARAMETERS-LIMIT - 1) */
15656 #define lp_limit_1 ((uintL)(bitm(12)-1))
15657
15658 /* Highest number of arguments for a function call
15659 (= value of CALL-ARGUMENTS-LIMIT - 1) */
15660 #define ca_limit_1 lp_limit_1
15661
15662 /* The macro LISPSPECFORM initiates the declaration of a LISP-Special-Form.
15663 LISPSPECFORM(name,req_count,opt_count,body_flag)
15664 > name: C-name of the function and the Symbol
15665 > req_count: number of required parameters
15666 > opt_count: number of optional parameters
15667 > body_flag: body or nobody, depending on whether &BODY exists or not
15668 See FSUBR.D */
15669 #define LISPSPECFORM LISPSPECFORM_B
15670 /* is used by CONTROL */
15671
15672 /* The macro LISPFUN initiates a declaration of a LISP functions.
15673 LISPFUN(name,seclass,req_count,opt_count,rest_flag,key_flag,key_count,keywords)
15674 > name: the name of the function (a C-Identifier)
15675 > seclass: the side-effect class (seclass_t, see above)
15676 > req_count: number of required parameters (a number)
15677 > opt_count: number of optional parameters (a number)
15678 > rest_flag: either norest or rest, depending on whether &REST exists or not
15679 > key_flag: either nokey or key or key_allow, depending on whether &KEY
15680 exists or not and whether &ALLOW-OTHER-KEYS is present
15681 > key_count: number of keyword-parameters, a number (0 if nokey)
15682 > keywords: either NIL or an expression of the form
15683 v(kw(keyword1),...,kw(keywordn)) (NIL if nokey)
15684 See SUBR.D */
15685 #define LISPFUN LISPFUN_B
15686 /* used by all modules */
15687
15688 /* The macro LISPFUNN initiates a simple declaration of a LISP-function.
15689 LISPFUNN(name,req_count)
15690 > name: the function-name (a C-Identifier)
15691 > req_count: the (fixed) number of arguments (a number)
15692 LISPFUNNF - ditto, but seclass_foldable instead of seclass_default
15693 LISPFUNNR - ditto, but seclass_read instead of seclass_default
15694 LISPFUNNS - ditto, but seclass_rd_sig instead of seclass_default
15695 See SUBR.D
15696 used by all modules */
15697
15698 /* UP: initialize hand-made compiled closures
15699 init_cclosures();
15700 can trigger GC */
15701 extern maygc void init_cclosures (void);
15702
15703 #if defined(USE_JITC)
15704 #if defined(TYPECODES)
15705 #error USE_JITC requires HEAPCODES
15706 #endif
15707 /* GC hooks for JIT code */
15708 extern void gc_mark_jitc_object (void *ptr);
15709 extern void gc_scan_jitc_objects (void);
15710 extern bool gc_drop_jitc;
15711 #endif
15712
15713 /* ##################### CTRLBIBL for CONTROL.D ############################ */
15714
15715 /* the variables declared special appear on the stack twice:
15716 with binding SPECDECL (added when processing declarations)
15717 and the actual value (added when processing bindings).
15718 here we activate the SPECDECL bindings */
15719 #define specdecled_p(sym,ptr,nn) (nn>0 ? specdecled_(sym,ptr,nn) : NULL)
15720 /* Find the SPECDECL binding for the symbol
15721 > spec_pointer & spec_count are returned by make_variable_frame()
15722 < return the pointer to the flags (or symbol+flags)
15723 i.e., something suitable to SET_BIT,
15724 or NULL if no such binding is found */
15725 extern gcv_object_t* specdecled_ (object symbol, gcv_object_t* spec_pointer,
15726 uintL spec_count);
15727 /* used by CONTROL, EVAL */
15728
15729 /* activate the SPECDECL binding if found */
15730 #define activate_specdecl(sym,ptr,nn) do { \
15731 var gcv_object_t *spec = specdecled_p(sym,ptr,nn); \
15732 if (spec) \
15733 *spec = SET_BIT(*spec,active_bit_o); /* activate binding */ \
15734 } while(0)
15735
15736 /* activate all SPECDECL and IMPDEPENDENT declarations */
15737 extern void activate_specdecls (gcv_object_t* spec_ptr, uintC spec_count);
15738 /* used by CONTROL, EVAL */
15739
15740 /* Error if a block has already been left.
15741 error_block_left(name);
15742 > name: Block-name */
15743 extern _Noreturn void error_block_left (object name);
15744 /* is used by EVAL */
15745
15746 /* convert the numeric side-effect class as stored in subr_t or cclosure_t
15747 to the object - CONS or NIL - as used in compiler.lisp and for #Y i/o */
15748 #ifndef COMPILE_STANDALONE
seclass_object(seclass_t sec)15749 static inline object seclass_object (seclass_t sec) {
15750 switch (sec) {
15751 case seclass_foldable: { return NIL; }
15752 case seclass_no_se: { return O(seclass_no_se); }
15753 case seclass_read: { return O(seclass_read); }
15754 case seclass_rd_sig: { return O(seclass_rd_sig); }
15755 case seclass_write: { return O(seclass_write); }
15756 case seclass_default: { return O(seclass_default); }
15757 default: NOTREACHED;
15758 }
15759 }
15760 #endif
15761 /* used by IO and CONTROL */
15762
15763 /* ########################## for ENCODING.D ############################### */
15764
15765 /* Initialize the encodings.
15766 init_encodings(); */
15767 extern void init_encodings_1 (void);
15768 extern void init_encodings_2 (void);
15769 /* is used by SPVW */
15770
15771 /* Initialize the encodings which depend on environment variables.
15772 init_dependent_encodings(); */
15773 extern void init_dependent_encodings (void);
15774 /* is used by SPVW */
15775
15776 /* Maximum number of bytes needed to form a character, over all encodings.
15777 max_bytes_per_chart */
15778 #ifdef ENABLE_UNICODE
15779 #define max_bytes_per_chart 8 /* 6 for JAVA, 7 for ISO-2022-KR, 8 for ISO-2022-CN[-EXT] */
15780 #else
15781 #define max_bytes_per_chart 1
15782 #endif
15783 /* is used by STREAM */
15784
15785 /* UP: Creates a LISP-String with given contents.
15786 n_char_to_string(charptr,len,encoding)
15787 > char* charptr: address of a character sequence
15788 > uintL len: length of the sequence
15789 > object encoding: Encoding
15790 < result: Normal-Simple-String with len characters starting from charptr as contents
15791 can trigger GC */
15792 #ifdef ENABLE_UNICODE
15793 extern maygc object n_char_to_string (const char* charptr, uintL len, object encoding);
15794 #else
15795 #define n_char_to_string(charptr,len,encoding) n_char_to_string_(charptr,len)
15796 extern maygc object n_char_to_string_ (const char* charptr, uintL len);
15797 #endif
15798 /* is used by PATHNAME */
15799 %% #ifdef ENABLE_UNICODE
15800 %% exportF(object,n_char_to_string,(const char* charptr, uintL len, object encoding));
15801 %% #else
15802 %% emit_define("n_char_to_string(charptr,len,encoding)","n_char_to_string_(charptr,len)");
15803 %% exportF(object,n_char_to_string_,(const char* charptr, uintL len));
15804 %% #endif
15805
15806 /* UP: Converts an ASCIZ-String to a LISP-String.
15807 asciz_to_string(asciz,encoding)
15808 ascii_to_string(asciz)
15809 > char* asciz: ASCIZ-String
15810 (address of a null-terminated character-sequence)
15811 > object encoding: Encoding
15812 < result: Normal-Simple-String with the character sequence (without null-byte) as contents.
15813 can trigger GC */
15814 #ifdef ENABLE_UNICODE
15815 extern maygc object asciz_to_string (const char * asciz, object encoding);
15816 #else
15817 #define asciz_to_string(asciz,encoding) asciz_to_string_(asciz)
15818 extern maygc object asciz_to_string_ (const char * asciz);
15819 #endif
15820 extern maygc object ascii_to_string (const char * asciz);
15821 /* is used by SPVW/CONSTSYM, STREAM, PATHNAME, PACKAGE, GRAPH */
15822 %% #ifdef ENABLE_UNICODE
15823 %% exportF(object,asciz_to_string,(const char * asciz, object encoding));
15824 %% #else
15825 %% emit_define("asciz_to_string(asciz,encoding)","asciz_to_string_(asciz)");
15826 %% exportF(object,asciz_to_string_,(const char * asciz));
15827 %% #endif
15828 %% exportF(object,ascii_to_string,(const char * asciz));
15829
15830 /* UP: Converts a String to an ASCIZ-String.
15831 string_to_asciz(obj,encoding)
15832 > object obj: String
15833 > object encoding: Encoding
15834 < result: Simple-Bit-Vector with the same characters as bytes and one
15835 additional null-byte at the end
15836 < TheAsciz(result): address of the byte-sequence contained in there
15837 can trigger GC */
15838 #ifdef ENABLE_UNICODE
15839 extern maygc object string_to_asciz (object obj, object encoding);
15840 #else
15841 #define string_to_asciz(obj,encoding) string_to_asciz_(obj)
15842 extern maygc object string_to_asciz_ (object obj);
15843 #endif
15844 #define TheAsciz(obj) ((char*)(&TheSbvector(obj)->data[0]))
15845 /* is used by STREAM, PATHNAME */
15846 %% #ifdef ENABLE_UNICODE
15847 %% exportF(object,string_to_asciz,(object obj, object encoding));
15848 %% #else
15849 %% export_def(string_to_asciz(obj,encoding));
15850 %% exportF(object,string_to_asciz_,(object obj));
15851 %% #endif
15852 %% export_def(TheAsciz(obj));
15853
15854 /* Converts a String to an ASCIZ-String on the C-Stack.
15855 with_string_0(string,encoding,asciz,statement);
15856 with_sstring_0(simple_string,encoding,asciz,statement);
15857 copies the contents of string (which should be a Lisp string) to a safe area
15858 (zero-terminating it), binds the variable asciz pointing to it, and
15859 executes the statement. */
15860 #if 0
15861 #define with_string_0(string,encoding,ascizvar,statement) \
15862 do { var char* ascizvar = TheAsciz(string_to_asciz(string,encoding)); \
15863 statement \
15864 } while(0)
15865 #define with_sstring_0 with_string_0
15866 #else
15867 #define with_string_0_help_(string,encoding,ascizvar,statement,ascizvar_len,ascizvar_offset,ascizvar_string,ascizvar_bytelen,ascizvar_data,asserter,notreached) \
15868 do { var uintL ascizvar_len; \
15869 var uintL ascizvar_offset; \
15870 var object ascizvar_string = unpack_string_ro(string,&ascizvar_len,&ascizvar_offset); \
15871 var const chart* ptr1; \
15872 unpack_sstring_alloca_help_(ascizvar_string,ascizvar_len,ascizvar_offset, ptr1=,notreached); \
15873 {var uintL ascizvar_bytelen = cslen(encoding,ptr1,ascizvar_len); \
15874 var DYNAMIC_ARRAY(ascizvar_data,uintB,ascizvar_bytelen+1); \
15875 cstombs_help_(encoding,ptr1,ascizvar_len,&ascizvar_data[0],ascizvar_bytelen,asserter); \
15876 ascizvar_data[ascizvar_bytelen] = '\0'; \
15877 {var char* ascizvar = (char*) &ascizvar_data[0]; \
15878 statement} \
15879 FREE_DYNAMIC_ARRAY(ascizvar_data); \
15880 }} while(0)
15881 #define with_string_0(string,encoding,ascizvar,statement) \
15882 with_string_0_help_(string,encoding,ascizvar,statement,ascizvar##_len,ascizvar##_offset,ascizvar##_string,ascizvar##_bytelen,ascizvar##_data,ASSERT,NOTREACHED)
15883 #define with_sstring_0_help_(string,encoding,ascizvar,statement,ascizvar_len,ascizvar_string,ascizvar_bytelen,ascizvar_data,asserter,notreached) \
15884 do { var object ascizvar_string = (string); \
15885 sstring_un_realloc(ascizvar_string); \
15886 {var uintL ascizvar_len = Sstring_length(ascizvar_string); \
15887 var const chart* ptr1; \
15888 unpack_sstring_alloca_help_(ascizvar_string,ascizvar_len,0, ptr1=,notreached); \
15889 {var uintL ascizvar_bytelen = cslen(encoding,ptr1,ascizvar_len); \
15890 var DYNAMIC_ARRAY(ascizvar_data,uintB,ascizvar_bytelen+1); \
15891 cstombs_help_(encoding,ptr1,ascizvar_len,&ascizvar_data[0],ascizvar_bytelen,asserter); \
15892 ascizvar_data[ascizvar_bytelen] = '\0'; \
15893 {var char* ascizvar = (char*) &ascizvar_data[0]; \
15894 statement} \
15895 FREE_DYNAMIC_ARRAY(ascizvar_data); \
15896 }}} while(0)
15897 #define with_sstring_0(string,encoding,ascizvar,statement) \
15898 with_sstring_0_help_(string,encoding,ascizvar,statement,ascizvar##_len,ascizvar##_string,ascizvar##_bytelen,ascizvar##_data,ASSERT,NOTREACHED)
15899 #endif
15900 /* is used by PATHNAME, MISC, FOREIGN */
15901 %% export_def(with_string_0_help_(string,encoding,ascizvar,statement,ascizvar_len,ascizvar_offset,ascizvar_string,ascizvar_bytelen,ascizvar_data,asserter,notreached));
15902 %% export_def(with_sstring_0_help_(string,encoding,ascizvar,statement,ascizvar_len,ascizvar_string,ascizvar_bytelen,ascizvar_data,asserter,notreached));
15903 %% /* cannot use emit_define because Rectype_* is not a define in lispbibl.d */
15904 %% puts("#define with_string_0(string,encoding,ascizvar,statement) with_string_0_help_(string,encoding,ascizvar,statement,ascizvar##_len,ascizvar##_offset,ascizvar##_string,ascizvar##_bytelen,ascizvar##_data,ASSERT,NOTREACHED)");
15905 %% puts("#define with_sstring_0(string,encoding,ascizvar,statement) with_sstring_0_help_(string,encoding,ascizvar,statement,ascizvar##_len,ascizvar##_string,ascizvar##_bytelen,ascizvar##_data,ASSERT,NOTREACHED)");
15906
15907 /* In some foreign modules, we call library functions that can do callbacks.
15908 When we pass a parameter to such a library function, maybe it first does a
15909 callback - which may involve garbage collection - and only then looks at
15910 the parameter. Therefore all the parameters, especially strings, must be
15911 located in areas that are not moved by garbage collection. The following
15912 macro helps achieving this. */
15913
15914 /* Converts a String to a String on the C-Stack.
15915 with_string(string,encoding,charptr,len,statement);
15916 with_sstring(simple_string,encoding,charptr,len,statement);
15917 copies the contents of string (which should be a Lisp string) to a safe area,
15918 binds the variable charptr pointing to it and the variable len to its length,
15919 and executes the statement. */
15920 #define with_string(string,encoding,charptrvar,lenvar,statement) \
15921 do { var uintL charptrvar##_len; \
15922 var uintL charptrvar##_offset; \
15923 var object charptrvar##_string = unpack_string_ro(string,&charptrvar##_len,&charptrvar##_offset); \
15924 var const chart* ptr1; \
15925 unpack_sstring_alloca(charptrvar##_string,charptrvar##_len,charptrvar##_offset, ptr1=); \
15926 {var uintL lenvar = cslen(encoding,ptr1,charptrvar##_len); \
15927 var DYNAMIC_ARRAY(charptrvar##_data,uintB,lenvar); \
15928 cstombs(encoding,ptr1,charptrvar##_len,&charptrvar##_data[0],lenvar); \
15929 {var char* charptrvar = (char*) &charptrvar##_data[0]; \
15930 statement \
15931 } \
15932 FREE_DYNAMIC_ARRAY(charptrvar##_data); \
15933 }} while(0)
15934 #define with_sstring(string,encoding,charptrvar,lenvar,statement) \
15935 do { var object charptrvar##_string = (string); \
15936 sstring_un_realloc(charptrvar##_string); \
15937 {var uintL charptrvar##_len = Sstring_length(charptrvar##_string); \
15938 var const chart* ptr1; \
15939 unpack_sstring_alloca(charptrvar##_string,charptrvar##_len,0, ptr1=); \
15940 {var uintL lenvar = cslen(encoding,ptr1,charptrvar##_len); \
15941 var DYNAMIC_ARRAY(charptrvar##_data,uintB,lenvar); \
15942 cstombs(encoding,ptr1,charptrvar##_len,&charptrvar##_data[0],lenvar); \
15943 {var char* charptrvar = (char*) &charptrvar##_data[0]; \
15944 statement \
15945 } \
15946 FREE_DYNAMIC_ARRAY(charptrvar##_data); \
15947 }}} while(0)
15948 /* is used by PATHNAME */
15949
15950 /* Error, when a character cannot be converted to an encoding.
15951 error_unencodable(encoding,ch); */
15952 extern _Noreturn void error_unencodable (object encoding, chart ch);
15953 /* is used by STREAM */
15954
15955 /* ####################### ARRBIBL for ARRAY.D ############################# */
15956
15957 /* ARRAY-TOTAL-SIZE-LIMIT is chosen as large as possible, respecting the
15958 constraint that the total-size of any array is a fixnum and (from ANSI CL)
15959 that ARRAY-TOTAL-SIZE-LIMIT itself is also a fixnum.
15960 (>=0, <2^oint_data_len): */
15961 #if (oint_data_len<=intLsize)
15962 #define arraysize_limit_1 ((uintV)(vbitm(oint_data_len)-2))
15963 #else
15964 #if defined(UNIX_MACOSX) && defined(WIDE_HARD)
15965 /* on 64 bit Darwin HEAPCODES are used - limit the size of arrays.*/
15966 #define arraysize_limit_1 ((uintV)(vbitm(24)-2))
15967 #else
15968 /* Respect the constraint that the total-size of any array is an uintL. */
15969 #define arraysize_limit_1 ((uintV)(vbitm(intLsize)-1))
15970 #endif
15971 #endif
15972
15973 /* ARRAY-RANK-LIMIT is chosen as large as possible, respecting the constraint
15974 that the rank of any array is an uintWC:
15975 #define arrayrank_limit_1 ((uintL)(bitm(intWCsize)-1))
15976 array dimensions are pushed on STACK in array_dimensions()
15977 so we are limited like with LAMBDA-PARAMETERS-LIMIT */
15978 #define arrayrank_limit_1 lp_limit_1
15979
15980 /* Macro: Follows the Sistring chain, to get from a simple array (actually,
15981 a string) to its storage vector.
15982 sstring_un_realloc(array);
15983 sstring_un_realloc1(array); [when at most one Sistring is involved]
15984 > array: a simple array
15985 < array: its storage vector */
15986 #ifdef HAVE_SMALL_SSTRING
15987 #ifdef TYPECODES
15988 #define sarray_reallocstringp(array) \
15989 (typecode(array) == sstring_type \
15990 && (sstring_flags(TheSstring(array)) & sstringflags_forwarded_B) \
15991 )
15992 #else
15993 #define sarray_reallocstringp(array) \
15994 (Record_type(array) == Rectype_reallocstring)
15995 #endif
15996 #define sstring_un_realloc(array) \
15997 while (sarray_reallocstringp(array)) \
15998 (array) = TheSistring(array)->data/*;*/
15999 #define sstring_un_realloc1(array) \
16000 if (sarray_reallocstringp(array)) \
16001 (array) = TheSistring(array)->data/*;*/
16002 #else
16003 #define sstring_un_realloc(array) (void)0 /*nop*/
16004 #define sstring_un_realloc1(array) (void)0 /*nop*/
16005 #endif
16006
16007 /* Function: Copies a simple-vector.
16008 copy_svector(vector)
16009 > vector: simple-vector
16010 < result: fresh simple-vector with the same contents
16011 can trigger GC */
16012 extern maygc object copy_svector (object vector);
16013 /* used by IO */
16014
16015 /* Function: allocate a simple-bit/byte-vector and copy data there
16016 > atype: array type
16017 > vec_len: the length of the new array
16018 > data: pointer to the memory area to be copied
16019 > byte_len: the memory size to be copied, in bytes
16020 < returns a fresh simple-bit/byte-vector with the same contents
16021 can trigger GC */
16022 extern maygc object data_to_sbvector (uintB atype, uintL vec_len,
16023 const void *data, uintL byte_len);
16024 #define data_to_sb8vector(data,bytelen) data_to_sbvector(Atype_8Bit,bytelen,data,bytelen)
16025 %% exportF(object,data_to_sbvector,(uintB atype, uintL vec_len, const void *data, uintL byte_len));
16026 %% export_def(data_to_sb8vector(data,bytelen));
16027 /* used by RAWSOCK, NEW-CLX, DIRKEY, GDBM, SYSCALLS, BERKELEY-DB, PCRE */
16028
16029 /* Function: Copies a simple-bit/byte-vector.
16030 copy_sbvector(vector)
16031 > vector: simple-bit/byte-vector
16032 < result: fresh simple-bit/byte-vector with the same contents
16033 can trigger GC */
16034 extern maygc object copy_sbvector (object vector);
16035 /* used by RECORD */
16036
16037 /* Function: Returns the active length of a vector (same as LENGTH).
16038 vector_length(vector)
16039 > vector: a vector
16040 < result: its length */
16041 extern uintL vector_length (object vector);
16042 /* used by many modules */
16043 %% exportF(uintL,vector_length,(object vector));
16044
16045 /* Function: Canonicalizes an array element-type and returns its
16046 element type code.
16047 eltype_code(element_type)
16048 > element_type: type specifier
16049 < result: element type code Atype_xxx
16050 The canonicalized types are the possible results of ARRAY-ELEMENT-TYPE
16051 (symbols T, BIT, CHARACTER and lists (UNSIGNED-BYTE n)).
16052 The result type is a supertype of element_type.
16053 can trigger GC */
16054 extern maygc uintB eltype_code (object element_type);
16055 /* is used by SEQUENCE */
16056
16057 /* Function: Creates a simple-vector with given elements.
16058 vectorof(len)
16059 > uintC len: desired vector length
16060 > STACK_(len-1), ..., STACK_(0): len objects
16061 < result: simple-vector containing these objects
16062 Pops n objects off STACK.
16063 can trigger GC */
16064 extern maygc object vectorof (uintC len);
16065 /* used by PREDTYPE */
16066 %% exportF(object,vectorof,(uintC len));
16067
16068 /* Function: For an indirect array, returns the storage vector and the offset.
16069 Also verifies that all elements of the array are physically present.
16070 iarray_displace_check(array,size,&index)
16071 > object array: indirect array
16072 > uintL size: size
16073 < result: storage vector
16074 < index: is incremented by the offset into the storage vector */
16075 extern object iarray_displace_check (object array, uintL size, uintL* index);
16076 /* used by IO, CHARSTRG, HASHTABL, PREDTYPE, STREAM, SEQUENCE */
16077
16078 /* Function: For an array, returns the storage vector and the offset.
16079 Also verifies that all elements of the array are physically present.
16080 array_displace_check(array,size,&index)
16081 > object array: array
16082 > uintV size: size
16083 < result: storage vector
16084 < index: is incremented by the offset into the storage vector */
16085 extern object array_displace_check (object array, uintV size, uintL* index);
16086 /* used by HASHTABL, PREDTYPE, IO, FOREIGN */
16087 %% exportF(object,array_displace_check,(object array, uintV size, uintL* index));
16088
16089 /* Tests for the storage vector of an array of element type NIL.
16090 simple_nilarray_p(obj) */
16091 #define simple_nilarray_p(obj) nullp(obj)
16092 %% export_def(simple_nilarray_p(obj));
16093
16094 /* error-message
16095 > array: array (usually a Vector)
16096 > STACK_0: (erroneous) Index */
16097 extern _Noreturn void error_index_range (object array, uintL bound);
16098 /* used by SEQUENCE */
16099
16100 /* error message: attempt to retrieve a value from (ARRAY NIL) */
16101 extern _Noreturn void error_nilarray_retrieve (void);
16102 /* used by PREDTYPE */
16103 %% exportE(error_nilarray_retrieve,(void));
16104
16105 /* error message: attempt to store a value in (ARRAY NIL) */
16106 extern _Noreturn void error_nilarray_store (void);
16107
16108 /* error message: attempt to access a value from (ARRAY NIL) */
16109 extern _Noreturn void error_nilarray_access (void);
16110
16111 /* Function: Performs an AREF access.
16112 storagevector_aref(storagevector,index)
16113 > storagevector: a storage vector (simple vector or semi-simple byte vector)
16114 > index: (already checked) index into the storage vector
16115 < result: (AREF storagevector index)
16116 can trigger GC - if the element type is (UNSIGNED-BYTE 32) */
16117 extern /*maygc*/ object storagevector_aref (object storagevector, uintL index);
16118 /* used by IO */
16119
16120 /* Error when attempting to store an invalid value in an array.
16121 error_store(array,value); */
16122 extern _Noreturn void error_store (object array, object value);
16123 /* used by SEQUENCE */
16124
16125 /* Macro: Tests a bit in a simple-bit-vector.
16126 if (sbvector_btst(sbvector,index)) ...
16127 > sbvector: a simple-bit-vector
16128 > index: index (a variable, must be < (length sbvector)) */
16129 #define sbvector_btst(sbvector,index) \
16130 ( /* in byte number (index div 8), the bit number 7 - (index mod 8) : */\
16131 TheSbvector(sbvector)->data[(uintL)(index)/8] \
16132 & bit((~(uintL)(index)) % 8) \
16133 )
16134 /* used by SEQUENCE, IO */
16135
16136 /* Macro: Clears a bit in a simple-bit-vector.
16137 sbvector_bclr(sbvector,index);
16138 > sbvector: a simple-bit-vector
16139 > index: index (a variable, must be < (length sbvector)) */
16140 #define sbvector_bclr(sbvector,index) \
16141 ( /* in byte number (index div 8), the bit number 7 - (index mod 8) : */\
16142 TheSbvector(sbvector)->data[(uintL)(index)/8] \
16143 &= ~bit((~(uintL)(index)) % 8) \
16144 )
16145 /* used by IO */
16146
16147 /* Macro: Sets a bit in a simple-bit-vector.
16148 sbvector_bset(sbvector,index);
16149 > sbvector: a simple-bit-vector
16150 > index: index (a variable, must be < (length sbvector)) */
16151 #define sbvector_bset(sbvector,index) \
16152 ( /* in byte number (index div 8), the bit number 7 - (index mod 8) : */\
16153 TheSbvector(sbvector)->data[(uintL)(index)/8] \
16154 |= bit((~(uintL)(index)) % 8) \
16155 )
16156 /* used by SEQUENCE, IO */
16157
16158 /* return Atype for the given array */
16159 global uintBWL array_atype (object array);
16160 /* used by socket.d and modules */
16161 %% exportF(uintBWL,array_atype,(object array));
16162
16163 /* Function: Returns the element-type of an array.
16164 array_element_type(array)
16165 > array: an array
16166 < result: element-type, one of the symbols T, BIT, CHARACTER, or a list
16167 can trigger GC */
16168 extern maygc object array_element_type (object array);
16169 /* used by PREDTYPE, IO */
16170
16171 /* Returns the rank of an array.
16172 array_rank(array)
16173 > array: an array
16174 < uintL result: its rank = number of dimensions */
16175 extern uintL array_rank (object array);
16176 /* used by modules */
16177 %% exportF(uintL,array_rank,(object array));
16178
16179 /* Returns the dimensions of an array.
16180 get_array_dimensions(array,rank,&dimensions[]);
16181 > array: an array
16182 > uintL rank: = array_rank(array)
16183 > uintL dimensions[0..rank-1]: room for rank dimensions
16184 < uintL dimensions[0..rank-1]: the array's dimensions */
16185 extern void get_array_dimensions (object array, uintL rank, uintL* dimensions);
16186 /* used by modules */
16187 %% exportF(void,get_array_dimensions,(object array, uintL rank, uintL* dimensions));
16188
16189 /* Function: Returns the list of dimensions of an array.
16190 array_dimensions(array)
16191 > array: an array
16192 < result: list of its dimensions
16193 can trigger GC */
16194 extern maygc object array_dimensions (object array);
16195 /* used by PREDTYPE, IO */
16196
16197 /* Function: Returns the dimensions of an array and their partial products.
16198 iarray_dims_sizes(array,&dims_sizes);
16199 > array: indirect array of rank r
16200 > struct { uintL dim; uintL dimprod; } dims_sizes[r]: room for the result
16201 < for i=1,...r: dims_sizes[r-i] = { Dim_i, Dim_i * ... * Dim_r } */
16202 typedef struct { uintL dim; uintL dimprod; } array_dim_size_t;
16203 extern void iarray_dims_sizes (object array, array_dim_size_t* dims_sizes);
16204 /* used by IO */
16205
16206 /* Function: Returns the total-size of an array.
16207 array_total_size(array)
16208 > array: an array (a variable)
16209 < uintL result: its total-size */
16210 #ifndef COMPILE_STANDALONE
array_total_size(object array)16211 static inline uintL array_total_size (object array) {
16212 if (array_simplep(array)) {
16213 sstring_un_realloc(array);
16214 if (simple_string_p(array))
16215 return Sstring_length(array); /* simple string: total length */
16216 else
16217 return Sarray_length(array); /* simple vector: total length */
16218 } else
16219 return TheIarray(array)->totalsize; /* indirect array: contains totalsize */
16220 }
16221 #endif
16222 /* used by ARRAY, SEQUENCE, FOREIGN */
16223
16224 /* Function: Compares two slices of simple-bit-vectors.
16225 bit_compare(array1,index1,array2,index2,count)
16226 > array1: first simple-bit-vector
16227 > index1: absolute index into array1
16228 > array2: second simple-bit-vector
16229 > index2: absolute index into array2
16230 > count: number of bits to be compared, > 0
16231 < result: true, if both slices are the same, bit for bit, else false. */
16232 extern bool bit_compare (object array1, uintL index1,
16233 object array2, uintL index2,
16234 uintL bitcount);
16235 /* used by PREDTYPE */
16236
16237 /* Function: Copies a slice of an array array1 into another array array2.
16238 elt_copy(dv1,index1,dv2,index2,count);
16239 > dv1: source storage-vector
16240 > index1: start index in dv1
16241 > dv2: destination storage-vector
16242 > index2: start index in dv2
16243 > count: number of elements to be copied, > 0
16244 can trigger GC - if dv1 and dv2 have different element types or
16245 if both are strings and dv1 is wider than dv2 */
16246 extern /*maygc*/ void elt_copy (object dv1, uintL index1, object dv2, uintL index2, uintL count);
16247 /* used by SEQUENCE, STREAM */
16248
16249 /* Function: Copies a slice of an array array1 into another array array2 of
16250 the same element type. Handles overlapping arrays correctly.
16251 elt_move(dv1,index1,dv2,index2,count);
16252 > dv1: source storage-vector
16253 > index1: start index in dv1
16254 > dv2: destination storage-vector
16255 > index2: start index in dv2
16256 > count: number of elements to be copied, > 0
16257 can trigger GC - if both are strings and dv1 is wider than dv2 */
16258 extern /*maygc*/ void elt_move (object dv1, uintL index1, object dv2, uintL index2, uintL count);
16259 /* used by SEQUENCE */
16260
16261 /* Function: Fills a slice of an array with an element.
16262 elt_fill(dv,index,count,element)
16263 > dv: destination storage-vector
16264 > index: start index in dv
16265 > count: number of elements to be filled
16266 < result: true if element does not fit, false when done
16267 can trigger GC */
16268 extern maygc bool elt_fill (object dv, uintL index, uintL count, object element);
16269 /* used by SEQUENCE */
16270
16271 /* Function: Reverses a slice of an array, copying it into another array
16272 of the same element type.
16273 elt_reverse(dv1,index1,dv2,index2,count);
16274 > dv1: source storage-vector
16275 > index1: start index in dv1
16276 > dv2: destination storage-vector
16277 > index2: start index in dv2
16278 > count: number of elements to be copied, > 0
16279 can trigger GC */
16280 extern maygc void elt_reverse (object dv1, uintL index1, object dv2, uintL index2, uintL count);
16281 /* used by SEQUENCE */
16282
16283 /* Function: Reverses a slice of an array destructively.
16284 elt_nreverse(dv,index,count);
16285 > dv: storage-vector
16286 > index: start index in dv
16287 > count: number of elements to be reversed, > 0 */
16288 extern void elt_nreverse (object dv, uintL index, uintL count);
16289 /* used by SEQUENCE */
16290
16291 /* Function: Tests whether an array has a fill-pointer.
16292 array_has_fill_pointer_p(array)
16293 > array: ein Array
16294 < result: true, if it has a fill-pointer, else false. */
16295 extern bool array_has_fill_pointer_p (object array);
16296 /* used by SEQUENCE, STREAM, IO */
16297
16298 /* Function: Allocates a new simple-bit-vector, filled with zeroes.
16299 allocate_bit_vector_0(len)
16300 > uintL len: length of the desired bit-vector (number of bits)
16301 < result: fresh simple-bit-vector, filled with zeroes
16302 can trigger GC */
16303 extern maygc object allocate_bit_vector_0 (uintL len);
16304 /* used by SEQUENCE */
16305 %% #if notused
16306 %% exportF(object,allocate_bit_vector_0,(uintL len));
16307 %% #endif
16308
16309 /* The following functions work on "semi-simple string"s.
16310 That are CHARACTER arrays with FILL-POINTER, (pro forma) not adjustable and
16311 not displaced, whose storagevector is a normal-simple-string. When their
16312 length is exceeded, the length is doubled (so that the resizing effort
16313 becomes unimportant: adding a character is still O(1) on average.) */
16314
16315 /* Function: Returns a fresh semi-simple-string of given length, with
16316 fill-pointer = 0.
16317 make_ssstring(len)
16318 > uintL len: desired length, must be >0
16319 < result: fresh semi-simple-string of the given length
16320 can trigger GC */
16321 extern maygc object make_ssstring (uintL len);
16322 #define SEMI_SIMPLE_DEFAULT_SIZE 50
16323 /* used by STREAM, IO */
16324
16325 /* Function: Adds a character to a semi-simple-string, thereby possibly
16326 extending it.
16327 ssstring_push_extend(ssstring,ch)
16328 > ssstring: a semi-simple-string
16329 > ch: a character
16330 < result: the same semi-simple-string
16331 can trigger GC */
16332 extern maygc object ssstring_push_extend (object ssstring, chart ch);
16333 /* used by STREAM, IO */
16334
16335 /* Function: Ensures that a semi-simple-string has at least a given length,
16336 possibly extending it.
16337 ssstring_extend(ssstring,size)
16338 > ssstring: a semi-simple-string
16339 > size: desired minimum length
16340 < result: the same semi-simple-string
16341 can trigger GC */
16342 extern maygc object ssstring_extend (object ssstring, uintL needed_len);
16343 /* used by STREAM */
16344
16345 /* Function: Adds a substring to a semi-simple-string, thereby possibly
16346 extending it.
16347 ssstring_append_extend(ssstring,srcstring,start,len)
16348 > ssstring: a semi-simple-string
16349 > srcstring: a simple-string
16350 > start: the start index into the sstring
16351 > len: the number of characters to be pushed, starting from start
16352 < result: the same semi-simple-string
16353 can trigger GC */
16354 extern maygc object ssstring_append_extend (object ssstring, object srcstring, uintL start, uintL len);
16355 /* used by STREAM */
16356
16357 /* The following functions work on "semi-simple byte-vector"s.
16358 That are bit vectors with FILL-POINTER, (pro forma) not adjustable and
16359 not displaced, whose storagevector is a simple-bit-vector. When their
16360 length is exceeded, the length is doubled (so that the resizing effort
16361 becomes unimportant: adding a character is still O(1) on average.) */
16362
16363 /* Function: Returns a fresh semi-simple byte-vector of given length, with
16364 fill-pointer = 0.
16365 make_ssbvector(len)
16366 > uintL len: length (number of bytes!), must be >0
16367 < fresh: fresh semi-simple byte-vector of the given length
16368 can trigger GC */
16369 extern maygc object make_ssbvector (uintL len);
16370 /* used by IO */
16371
16372 /* Function: Adds a byte to a semi-simple byte vector, thereby possibly
16373 extending it.
16374 ssbvector_push_extend(ssbvector,b)
16375 > ssbvector: a semi-simple byte-vector
16376 > b: byte
16377 < result: the same semi-simple byte-vector
16378 can trigger GC */
16379 extern maygc object ssbvector_push_extend (object ssbvector, uintB b);
16380 /* used by IO */
16381
16382 /* ##################### CHARBIBL for CHARSTRG.D ########################### */
16383
16384 /* Special Characters: (refer to above)
16385 #define BEL 7 # #\Bell
16386 #define BS 8 # #\Backspace
16387 #define TAB 9 # #\Tab
16388 #define LF 10 # #\Linefeed
16389 #define CR 13 # #\Return
16390 #define PG 12 # #\Page */
16391 #define NL 10 /* #\Newline */
16392 #define NLstring "\n" /* C-String, that contains #\Newline */
16393 #define ESC 27 /* #\Escape */
16394 #define ESCstring "\033" /* C-String, that contains #\Escape */
16395
16396 /* Converts Byte ch to upcase
16397 up_case(ch) */
16398 extern chart up_case (chart ch);
16399 /* is used by IO, PREDTYPE, PATHNAME */
16400 %% #if notused
16401 %% exportF(chart,up_case,(chart ch));
16402 %% #endif
16403
16404 /* Converts Byte ch to downcase
16405 down_case(ch) */
16406 extern chart down_case (chart ch);
16407 /* is used by IO, PATHNAME */
16408 %% #if notused
16409 %% exportF(chart,down_case,(chart ch));
16410 %% #endif
16411
16412 /* Checks whether a Character is alphanumeric.
16413 alphanumericp(ch)
16414 > ch: Character-Code
16415 < result: true if alphanumeric, else false. */
16416 extern bool alphanumericp (chart ch);
16417 /* is used by IO, PATHNAME */
16418
16419 /* Checks, whether a Character is a Graphic-Character ("printing").
16420 graphic_char_p(ch)
16421 > ch: Character-Code
16422 < result: true if printing, else false. */
16423 extern bool graphic_char_p (chart ch);
16424 /* is used by STREAM, PATHNAME */
16425
16426 /* Returns the screen display width of a character.
16427 char_width(ch)
16428 > ch: character code
16429 < result: number of output columns occupied by ch */
16430 extern uintL char_width (chart ch);
16431 /* is used by IO, STREAM */
16432
16433 #if !defined(ENABLE_UNICODE) || defined(HAVE_SMALL_SSTRING)
16434 /* Copies an array of uint8 to an array of uint8.
16435 copy_8bit_8bit(src,dest,len);
16436 > uint8* src: source
16437 > uint8* dest: destination
16438 > uintL len: number of elements to be copied, > 0 */
16439 extern void copy_8bit_8bit (const uint8* src, uint8* dest, uintL len);
16440 #endif
16441
16442 #if defined(HAVE_SMALL_SSTRING)
16443 /* Copies an array of uint8 to an array of uint16.
16444 copy_8bit_16bit(src,dest,len);
16445 > uint8* src: source
16446 > uint16* dest: destination
16447 > uintL len: number of elements to be copied, > 0 */
16448 extern void copy_8bit_16bit (const uint8* src, uint16* dest, uintL len);
16449 #endif
16450 %% #ifdef HAVE_SMALL_SSTRING
16451 %% exportF(void,copy_8bit_16bit,(const uint8* src, uint16* dest, uintL len));
16452 %% #endif
16453
16454 #if defined(HAVE_SMALL_SSTRING)
16455 /* Copies an array of uint8 to an array of uint32.
16456 copy_8bit_32bit(src,dest,len);
16457 > uint8* src: source
16458 > uint32* dest: destination
16459 > uintL len: number of elements to be copied, > 0 */
16460 extern void copy_8bit_32bit (const uint8* src, uint32* dest, uintL len);
16461 #endif
16462 %% #ifdef HAVE_SMALL_SSTRING
16463 %% exportF(void,copy_8bit_32bit,(const uint8* src, uint32* dest, uintL len));
16464 %% #endif
16465
16466 #if defined(HAVE_SMALL_SSTRING)
16467 /* Copies an array of uint16 to an array of uint8.
16468 All source elements must fit into uint8.
16469 copy_16bit_8bit(src,dest,len);
16470 > uint16* src: source
16471 > uint8* dest: destination
16472 > uintL len: number of elements to be copied, > 0 */
16473 extern void copy_16bit_8bit (const uint16* src, uint8* dest, uintL len);
16474 #endif
16475 %% #ifdef HAVE_SMALL_SSTRING
16476 %% exportF(void,copy_16bit_8bit,(const uint16* src, uint8* dest, uintL len));
16477 %% #endif
16478
16479 #if defined(HAVE_SMALL_SSTRING)
16480 /* Copies an array of uint16 to an array of uint16.
16481 copy_16bit_16bit(src,dest,len);
16482 > uint16* src: source
16483 > uint16* dest: destination
16484 > uintL len: number of elements to be copied, > 0 */
16485 extern void copy_16bit_16bit (const uint16* src, uint16* dest, uintL len);
16486 #endif
16487 %% #ifdef HAVE_SMALL_SSTRING
16488 %% exportF(void,copy_16bit_16bit,(const uint16* src, uint16* dest, uintL len));
16489 %% #endif
16490
16491 #if defined(HAVE_SMALL_SSTRING)
16492 /* Copies an array of uint16 to an array of uint32.
16493 copy_16bit_32bit(src,dest,len);
16494 > uint16* src: source
16495 > uint32* dest: destination
16496 > uintL len: number of elements to be copied, > 0 */
16497 extern void copy_16bit_32bit (const uint16* src, uint32* dest, uintL len);
16498 #endif
16499 %% #ifdef HAVE_SMALL_SSTRING
16500 %% exportF(void,copy_16bit_32bit,(const uint16* src, uint32* dest, uintL len));
16501 %% #endif
16502
16503 #if defined(HAVE_SMALL_SSTRING)
16504 /* Copies an array of uint32 to an array of uint8.
16505 All source elements must fit into uint8.
16506 copy_32bit_8bit(src,dest,len);
16507 > uint32* src: source
16508 > uint8* dest: destination
16509 > uintL len: number of elements to be copied, > 0 */
16510 extern void copy_32bit_8bit (const uint32* src, uint8* dest, uintL len);
16511 #endif
16512 %% #ifdef HAVE_SMALL_SSTRING
16513 %% exportF(void,copy_32bit_8bit,(const uint32* src, uint8* dest, uintL len));
16514 %% #endif
16515
16516 #if defined(HAVE_SMALL_SSTRING)
16517 /* Copies an array of uint32 to an array of uint16.
16518 All source elements must fit into uint16.
16519 copy_32bit_16bit(src,dest,len);
16520 > uint32* src: source
16521 > uint16* dest: destination
16522 > uintL len: number of elements to be copied, > 0 */
16523 extern void copy_32bit_16bit (const uint32* src, uint16* dest, uintL len);
16524 #endif
16525 %% #ifdef HAVE_SMALL_SSTRING
16526 %% exportF(void,copy_32bit_16bit,(const uint32* src, uint16* dest, uintL len));
16527 %% #endif
16528
16529 #if defined(ENABLE_UNICODE)
16530 /* Copies an array of uint32 to an array of uint32.
16531 copy_32bit_32bit(src,dest,len);
16532 > uint32* src: source
16533 > uint32* dest: destination
16534 > uintL len: number of elements to be copied, > 0 */
16535 extern void copy_32bit_32bit (const uint32* src, uint32* dest, uintL len);
16536 #endif
16537
16538 #if defined(HAVE_SMALL_SSTRING)
16539
16540 /* Determines the smallest string element type capable of holding a
16541 set of 8-bit characters. */
16542 #define smallest_string_flavour8(src,len) \
16543 (unused (src), unused(len), Sstringtype_8Bit)
16544
16545 /* Determines the smallest string element type capable of holding a
16546 set of 16-bit characters.
16547 smallest_string_flavour16(src,len)
16548 > uint16* src: source
16549 > uintL len: number of characters at src
16550 < result: Sstringtype_8Bit or Sstringtype_16Bit */
16551 extern uintBWL smallest_string_flavour16 (const uint16* src, uintL len);
16552
16553 /* Determines the smallest string element type capable of holding a
16554 set of 32-bit characters.
16555 smallest_string_flavour32(src,len)
16556 > uint32* src: source
16557 > uintL len: number of characters at src
16558 < result: Sstringtype_8Bit or Sstringtype_16Bit or Sstringtype_32Bit */
16559 extern uintBWL smallest_string_flavour32 (const uint32* src, uintL len);
16560
16561 /* Determines the smallest string element type capable of holding a
16562 set of characters.
16563 smallest_string_flavour(src,len)
16564 > chart* src: source
16565 > uintL len: number of characters at src
16566 < result: Sstringtype_8Bit or Sstringtype_16Bit or Sstringtype_32Bit */
16567 #ifndef COMPILE_STANDALONE
smallest_string_flavour(const chart * src,uintL len)16568 static inline uintBWL smallest_string_flavour (const chart* src, uintL len) {
16569 return smallest_string_flavour32((const uint32*)src,len);
16570 }
16571 #endif
16572
16573 #endif
16574
16575 /* Dispatches among S8string, S16string, S32string and nilvector.
16576 SstringCase(string,s8string_statement,s16string_statement,s32string_statement,nilvector_statement);
16577 > string: a not-reallocated simple-string or simple-nilvector (i.e. NIL)
16578 Executes one of the three statement, depending on the element size of string. */
16579 #ifdef ENABLE_UNICODE
16580 #ifdef HAVE_SMALL_SSTRING
16581 #define SstringCase(string,s8string_statement,s16string_statement,s32string_statement,nilvector_statement) \
16582 if (Array_type(string) == Array_type_snilvector) { nilvector_statement } else \
16583 if (sstring_eltype(TheSstring(string)) == Sstringtype_8Bit) { s8string_statement } else \
16584 if (sstring_eltype(TheSstring(string)) == Sstringtype_16Bit) { s16string_statement } else \
16585 if (sstring_eltype(TheSstring(string)) == Sstringtype_32Bit) { s32string_statement } else \
16586 NOTREACHED;
16587 #else
16588 #define SstringCase(string,s8string_statement,s16string_statement,s32string_statement,nilvector_statement) \
16589 if (Array_type(string) == Array_type_snilvector) { nilvector_statement } else \
16590 { s32string_statement }
16591 #endif
16592 #else
16593 /* In this case we take the s32string_statement, not the s8string_statement,
16594 because the s32string_statement is the right one for normal simple strings. */
16595 #define SstringCase(string,s8string_statement,s16string_statement,s32string_statement,nilvector_statement) \
16596 if (Array_type(string) == Array_type_snilvector) { nilvector_statement } else \
16597 { /*s8string_statement*/ s32string_statement }
16598 #endif
16599 /* is used by CHARSTRG, ARRAY, HASHTABL, PACKAGE, PATHNAME, PREDTYPE, STREAM */
16600
16601 /* Dispatches among S8string, S16string, S32string and nilvector.
16602 SstringDispatch(string,suffix,statement)
16603 > string: a not-reallocated simple-string or simple-nilvector (i.e. NIL)
16604 Executes the statement with cint##suffix being bound to the appropriate
16605 integer type (cint8, cint16 or cint32) and with Sstring being bound to the
16606 appropriate struct pointer type (S8string, S16string or S32string).
16607 Gives an error for simple-nilvector; must therefore only be called if the
16608 contents of the string is really to be accessed. */
16609 #define SstringDispatch(string,suffix,statement) \
16610 SstringCase(string, \
16611 { typedef cint8 cint##suffix; typedef S8string Sstring##suffix; \
16612 statement \
16613 }, \
16614 { typedef cint16 cint##suffix; typedef S16string Sstring##suffix; \
16615 statement \
16616 }, \
16617 { typedef cint32 cint##suffix; typedef S32string Sstring##suffix; \
16618 statement \
16619 }, \
16620 { error_nilarray_access(); \
16621 })
16622 /* is used by CHARSTRG, ARRAY, HASHTABL, PACKAGE, PATHNAME, PREDTYPE, STREAM */
16623
16624 /* Tests whether a simple-string is a normal-simple-string.
16625 sstring_normal_p(string)
16626 > string: a not-reallocated simple-string */
16627 #ifdef HAVE_SMALL_SSTRING
16628 #define sstring_normal_p(string) \
16629 (sstring_eltype(TheSstring(string)) == Sstringtype_32Bit)
16630 #else
16631 #define sstring_normal_p(string) 1
16632 #endif
16633
16634 /* Makes a string contents available.
16635 unpack_sstring_alloca(string,len,offset, charptr = );
16636 > object string: a not-reallocated simple-string
16637 > uintL len: the number of characters to be accessed
16638 > uintL offset: where the characters to be accessed start
16639 < const chart* charptr: pointer to the characters
16640 (may be in string, may be on the stack) */
16641 #ifdef HAVE_SMALL_SSTRING
16642 #define unpack_sstring_alloca_help_(string,len,offset,charptr_assignment,notreached) \
16643 if (simple_nilarray_p(string)) { \
16644 if ((len) > 0) error_nilarray_retrieve(); \
16645 charptr_assignment NULL; \
16646 } else if (sstring_eltype(TheSstring(string)) == Sstringtype_32Bit) { \
16647 charptr_assignment (const chart*) &TheS32string(string)->data[offset]; \
16648 } else { \
16649 var chart* _unpacked_ = (chart*)alloca((len)*sizeof(chart)); \
16650 if ((len) > 0) { \
16651 if (sstring_eltype(TheSstring(string)) == Sstringtype_16Bit) \
16652 copy_16bit_32bit(&TheS16string(string)->data[offset],(cint32*)_unpacked_,len);\
16653 else if (sstring_eltype(TheSstring(string)) == Sstringtype_8Bit) \
16654 copy_8bit_32bit(&TheS8string(string)->data[offset],(cint32*)_unpacked_,len);\
16655 else \
16656 notreached; \
16657 } \
16658 charptr_assignment (const chart*) _unpacked_; \
16659 }
16660 #else
16661 #define unpack_sstring_alloca_help_(string,len,offset,charptr_assignment,notreached) \
16662 if (simple_nilarray_p(string)) { \
16663 if ((len) > 0) error_nilarray_retrieve(); \
16664 charptr_assignment NULL; \
16665 } else { \
16666 charptr_assignment (const chart*) &TheSnstring(string)->data[offset]; \
16667 }
16668 #endif
16669 #define unpack_sstring_alloca(string,len,offset,charptr_assignment) \
16670 unpack_sstring_alloca_help_(string,len,offset,charptr_assignment,NOTREACHED)
16671 /* is used by */
16672 %% export_def(unpack_sstring_alloca_help_(string,len,offset,charptr_assignment,notreached));
16673 %% puts("#define unpack_sstring_alloca(s,l,o,c) unpack_sstring_alloca_help_(s,l,o,c,NOTREACHED)");
16674
16675 /* UP: Fetches a character from a simple string.
16676 schar(string,index)
16677 > object string: a not-reallocated simple-string or simple-nilvector (i.e. NIL)
16678 > uintL index: >= 0, < length of string
16679 < chart result: character at the given position */
16680 #ifndef COMPILE_STANDALONE
schar(object string,uintL index)16681 static inline chart schar (object string, uintL index) {
16682 SstringDispatch(string,X, {
16683 return as_chart(((SstringX)TheVarobject(string))->data[index]);
16684 });
16685 return as_chart(0); /* not reached - just pacify the compiler */
16686 }
16687 #endif
16688 /* is used by PATHNAME, STREAM */
16689
16690 /* UP: unpacks a String.
16691 unpack_string_ro(string,&len,&offset) [for read-only access]
16692 > object string: a String.
16693 < uintL len: number of characters of the String.
16694 < uintL offset: offset into the datastorage vector
16695 < object result: datastorage vector, a simple-string or NIL */
16696 extern object unpack_string_ro (object string, uintL* len, uintL* offset);
16697 /* is used by STREAM, HASHTABL, PACKAGE, SEQUENCE, ENCODING */
16698 %% exportF(object,unpack_string_ro,(object string, uintL* len, uintL* offset));
16699
16700 /* UP: tests two Strings for equality
16701 string_eq(string1,string2)
16702 > string1: String
16703 > string2: simple-string
16704 < result: /=0, if equal */
16705 extern bool string_eq (object string1, object string2);
16706 /* is used by PACKAGE, STREAM, IO */
16707
16708 /* UP: tests two Strings for equality, case-insensitive
16709 string_equal(string1,string2)
16710 > string1: String
16711 > string2: simple-string
16712 < result: /=0, if equal */
16713 extern bool string_equal (object string1, object string2);
16714 /* is used by IO, PATHNAME */
16715 %% exportF(bool,string_equal,(object string1, object string2));
16716
16717 /* UP: Stores a character in a string.
16718 > string: a mutable string that is or was simple
16719 > index: (already checked) index into the string
16720 > element: a character
16721 < result: the possibly reallocated string
16722 can trigger GC */
16723 extern maygc object sstring_store (object string, uintL index, chart element);
16724 /* is used by STREAM */
16725
16726 /* UP: Stores an array of characters in a string.
16727 > string: a mutable string that is or was simple
16728 > offset: (already checked) offset into the string
16729 > charptr[0..len-1]: a character array, not GC affected
16730 < result: the possibly reallocated string
16731 can trigger GC */
16732 extern maygc object sstring_store_array (object string, uintL offset,
16733 const chart *charptr, uintL len);
16734 /* is used by FFI */
16735
16736 #ifdef ENABLE_UNICODE
16737 /* UP: Creates a Simple-String with given elements.
16738 stringof(len)
16739 > uintL len: desired length of vector
16740 > on STACK: len Characters, first one on top
16741 < result: Simple-String with these objects
16742 increases STACK
16743 modifies STACK, can trigger GC */
16744 extern maygc object stringof (uintL len);
16745 /* is used by ENCODING, STREAM */
16746 #endif
16747
16748 /* UP: copies a String and turns it into a Simple-String.
16749 copy_string_normal(string)
16750 > string: String
16751 < result: mutable Normal-Simple-String with the same characters
16752 can trigger GC */
16753 extern maygc object copy_string_normal (object string);
16754 /* is used by IO, PATHNAME */
16755
16756 /* UP: copies a String and turns it into a Simple-String.
16757 copy_string(string)
16758 > string: String
16759 < result: mutable Simple-String with the same characters
16760 can trigger GC */
16761 #ifdef HAVE_SMALL_SSTRING
16762 extern maygc object copy_string (object string);
16763 #else
16764 #define copy_string(string) copy_string_normal(string)
16765 #endif
16766 /* is used by IO, PATHNAME */
16767
16768 /* UP: Converts a String to a Simple-String.
16769 coerce_ss(obj)
16770 > obj: Lisp-Object, should be a String.
16771 < result: Simple-String with the same characters.
16772 can trigger GC */
16773 extern maygc object coerce_ss (object obj);
16774 /* is used by STREAM, PATHNAME */
16775
16776 /* UP: Converts a String to a immutable Simple-String.
16777 coerce_imm_ss(obj)
16778 > obj: Lisp-Object, should be a String.
16779 < result: immutable Simple-String with the same characters.
16780 can trigger GC */
16781 extern maygc object coerce_imm_ss (object obj);
16782 /* is used by PACKAGE */
16783
16784 /* UP: Converts a String to a Normal-Simple-String.
16785 coerce_normal_ss(obj)
16786 > obj: Lisp-Object, should be a String.
16787 < result: Normal-Simple-String with the same characters.
16788 can trigger GC */
16789 #ifndef HAVE_SMALL_SSTRING
16790 #define coerce_normal_ss coerce_ss
16791 #else
16792 extern maygc object coerce_normal_ss (object obj);
16793 #endif
16794 /* is used by PATHNAME */
16795
16796 #if 0 /* unused */
16797 /* UP: converts a String to an immutable Normal-Simple-String.
16798 coerce_imm_normal_ss(obj)
16799 > obj: Lisp-Object, should be a String.
16800 < result: immutable Normal-Simple-String with the same characters
16801 can trigger GC */
16802 #ifndef HAVE_SMALL_SSTRING
16803 #define coerce_imm_normal_ss coerce_imm_ss
16804 #else
16805 extern maygc object coerce_imm_normal_ss (object obj);
16806 #endif
16807 /* is used by */
16808 #endif
16809
16810 /* UP: Converts Object to a Character
16811 coerce_char(obj)
16812 > obj: Lisp-Object
16813 < result: Character or NIL */
16814 extern object coerce_char (object obj);
16815 /* is used by PREDTYPE */
16816
16817 /* UP: Returns the name of a character
16818 char_name(code)
16819 > chart code: Code of a character
16820 < result: Simple-String (this char's name) or NIL
16821 can trigger GC */
16822 extern maygc object char_name (chart code);
16823 /* is used by IO */
16824
16825 /* UP: Determines the Character with a given Name
16826 name_char(string)
16827 > string: String
16828 < result: Character with this Name, or NIL if none exists */
16829 extern object name_char (object string);
16830 /* is used by IO */
16831
16832 /* Converts a character to opposite case.
16833 invert_case(ch)
16834 > ch: a character
16835 < result: a character, either ch or up_case(ch) or down_case(ch)
16836 Note that always invert_case(invert_case(ch)) == ch. */
16837 extern chart invert_case (chart ch);
16838 /* is used by PACKAGE */
16839
16840 /* UP: compares two strings for equality modulo case-invert
16841 string_eq_inverted(string1,string2)
16842 > string1: string
16843 > string2: simple-string
16844 < result: /=0, if equal modulo case-invert */
16845 extern bool string_eq_inverted (object string1, object string2);
16846 /* is used by PACKAGE */
16847
16848 /* UP: converts a string to opposite case
16849 string_invertcase(string)
16850 > string: string
16851 < result: new normal-simple-string
16852 can trigger GC */
16853 extern object string_invertcase (object string);
16854 /* is used by SYMBOL, PACKAGE */
16855
16856 /* UP: tests the limits for a String argument
16857 test_string_limits_ro(&arg) [for read-only access]
16858 > STACK_2: String-Argument
16859 > STACK_1: optional :start-Argument
16860 > STACK_0: optional :end-Argument
16861 < stringarg arg: description of the argument
16862 < result: String-Argument
16863 increases STACK by 3
16864 can trigger GC */
16865 typedef struct stringarg {
16866 object string; /* data vector - not-reallocated simple-string or -array */
16867 uintL offset; /* offset into this string */
16868 uintL index; /* :start index */
16869 uintL len; /* :end - :start */
16870 } stringarg;
16871 %% emit_typedef("struct stringarg { object string; uintL offset; uintL index; uintL len; }","stringarg");
16872 extern maygc object test_string_limits_ro (stringarg* arg);
16873 /* used by STREAM, PATHNAME, IO, ENCODING */
16874
16875 /* UP: checks :START and :END limits for a vector argument
16876 > STACK_1: optional :start-argument
16877 > STACK_0: optional :end-argument
16878 > stringarg arg: arg.string its data vector,
16879 [arg.offset .. arg.offset+arg.len-1] the range within the
16880 data vector corresponding to the entire vector-argument
16881 < stringarg arg: arg.string and arg.offset unchanged,
16882 [arg.offset+arg.index .. arg.offset+arg.index+arg.len-1] the
16883 range within the data vector corresponding to the selected
16884 vector slice
16885 removes 2 elements from STACK */
16886 extern void test_vector_limits (stringarg* arg);
16887 /* used by ENCODING */
16888 %% exportF(void,test_vector_limits,(stringarg* arg));
16889 /* used by RAWSOCK, NEW-CLX */
16890
16891 /* UP: checks a string/symbol/character-argument
16892 test_stringsymchar_arg(obj,invert)
16893 > obj: argument
16894 > invert: whether to implicitly case-invert a symbol's printname
16895 < result: argument as string
16896 can trigger GC */
16897 extern maygc object test_stringsymchar_arg (object obj, bool invert);
16898 /* used by IO, PACKAGE */
16899
16900 /* UP: tests two equally long strings for equality
16901 > string1,offset1: Chars in String1 start from here
16902 > string2,offset2: Chars in String2 start from here
16903 > len: number of chars in String1 and String2, > 0
16904 < result: true if equal, else false. */
16905 extern bool string_eqcomp (object string1, uintL offset1, object string2, uintL offset2, uintL len);
16906 /* is used by PREDTYPE */
16907
16908 /* UP: compares two equally long strings, case-insensitive
16909 > string1,offset1: Chars in String1 start from here
16910 > string2,offset2: Chars in String2 start from here
16911 > len: number of chars in String1 and String2, > 0
16912 < result: true if equal, else false. */
16913 extern bool string_eqcomp_ci (object string1, uintL offset1, object string2, uintL offset2, uintL len);
16914 /* is used by PREDTYPE */
16915
16916 /* UP: converts the Characters of a partial string to upcase
16917 nstring_upcase(dv,offset,len);
16918 > object dv: the character storage vector
16919 > uintL offset: index of first affected character
16920 > uintL len: number of affected characters
16921 can trigger GC */
16922 extern maygc void nstring_upcase (object dv, uintL offset, uintL len);
16923 /* is not used at this time (except in CHARSTRG, of course) */
16924
16925 /* UP: converts the Characters of a partial string to downcase
16926 nstring_downcase(dv,offset,len);
16927 > object dv: the character storage vector
16928 > uintL offset: index of first affected character
16929 > uintL len: number of affected characters
16930 can trigger GC */
16931 extern maygc void nstring_downcase (object dv, uintL offset, uintL len);
16932 /* is used by PATHNAME */
16933
16934 /* UP: changes the words of a part of a string so they start
16935 with capital letters and continue with lowercase ones
16936 nstring_capitalize(dv,offset,len);
16937 > object dv: the character storage vector
16938 > uintL offset: index of first affected character
16939 > uintL len: number of affected characters
16940 can trigger GC */
16941 extern maygc void nstring_capitalize (object dv, uintL offset, uintL len);
16942 /* is used by PATHNAME */
16943
16944 /* UP: converts a String to upcase
16945 string_upcase(string)
16946 > string: String
16947 < result: new Normal-Simple-String, in upcase
16948 can trigger GC */
16949 extern maygc object string_upcase (object string);
16950 /* is used by MISC, PATHNAME */
16951
16952 /* UP: converts a String to downcase
16953 string_downcase(string)
16954 > string: String
16955 < result: new Normal-Simple-String, in downcase
16956 can trigger GC */
16957 extern maygc object string_downcase (object string);
16958 /* is used by PATHNAME */
16959
16960 /* Returns a substring of a simple-string.
16961 subsstring(string,start,end)
16962 > object string: a simple-string
16963 > uintL start: start index
16964 > uintL end: end index
16965 with 0 <= start <= end <= Sstring_length(string)
16966 < object result: (subseq string start end),
16967 a freshly created normal-simple-string
16968 can trigger GC */
16969 extern maygc object subsstring (object string, uintL start, uintL end);
16970 /* is used by CHARSTRG, PATHNAME */
16971
16972 /* UP: Concatenates several Strings to one String.
16973 string_concat(argcount)
16974 > uintC argcount: Number of arguments
16975 > on STACK: the argument (should be Strings)
16976 < result: newly created string
16977 < STACK: cleaned
16978 can trigger GC */
16979 extern maygc object string_concat (uintC argcount);
16980 /* is used by PACKAGE, PATHNAME, DEBUG, SYMBOL */
16981 %% exportF(object,string_concat,(uintC argcount));
16982
16983 /* ###################### DEBUGBIB for DEBUG.D ########################### */
16984
16985 /* Starts the normal driver (Read-Eval-Print-Loop)
16986 driver(); */
16987 extern void driver (void);
16988 /* is used by SPVW */
16989
16990 /* Starts a secondary driver (Read-Eval-Print-Loop)
16991 break_driver(continuable_p);
16992 > continuable_p == can be continued after the driver finishes
16993 can trigger GC */
16994 extern maygc void break_driver (bool continuable_p);
16995 /* is used by ERROR, EVAL */
16996
16997 /* ##################### HASHBIBL for HASHTABL.D ######################### */
16998
16999 /* UP: Gets the hash of an object from a hash-table.
17000 gethash(obj,ht,allowgc)
17001 > obj: Object, as key
17002 > ht: hash-table
17003 > allowgc: whether GC is allowed during hash lookup
17004 (should be true if the hash-table has a user-defined test)
17005 < result: corresponding value, if found, else nullobj
17006 can trigger GC - if allowgc is true */
17007 extern /*maygc*/ object gethash (object obj, object ht, bool allowgc);
17008 /* is used by EVAL, RECORD, PATHNAME, FOREIGN */
17009 %% exportF(object,gethash,(object obj, object ht, bool allowgc));
17010
17011 /* UP: Locates a key in a hash-table and gives the older value.
17012 shifthash(ht,obj,value) == (SHIFTF (GETHASH obj ht) value)
17013 > ht: hash-table
17014 > obj: object
17015 > value: new value
17016 > allowgc: whether GC is allowed during hash lookup
17017 (should be true if the hash-table has a user-defined test or
17018 if the hash-table is not known to already contain a value for obj)
17019 < result: old value
17020 can trigger GC - if allowgc is true */
17021 extern /*maygc*/ object shifthash (object ht, object obj, object value, bool allowgc);
17022 /* is used by SEQUENCE, PATHNAME, FOREIGN */
17023
17024 /* hash_table_weak_type(ht)
17025 > ht: hash-table
17026 < result: symbol NIL/:KEY/:VALUE/:KEY-AND-VALUE/:KEY-OR-VALUE */
17027 extern object hash_table_weak_type (object ht);
17028 /* used by PREDTYPE */
17029
17030 /* HASH-TABLE-TEST (EQ/EQL/EQUAL/EQUALP)
17031 > ht: hash-table
17032 < result: symbol EQ/EQL/EQUAL/EQUALP or cons (TEST . HASH)
17033 can trigger GC - for user-defined ht_test */
17034 extern maygc object hash_table_test (object ht);
17035 /* used by HASHTABL, IO */
17036
17037 /* Macro: Runs through a Hash-Tabelle.
17038 map_hashtable(ht,key,value,statement)
17039 map_hashtable_nogc(ht,key,value,statement)
17040 > ht: Hash-Tabelle
17041 Calls 'statement', where key and value are a pair from the table.
17042 The first form is necessary, if the statement can trigger GC. */
17043 #define map_hashtable(ht,key,value,statement) \
17044 do { \
17045 var object ht_from_map_hashtable = (ht); \
17046 var uintL index_from_map_hashtable = \
17047 3*posfixnum_to_V(TheHashtable(ht_from_map_hashtable)->ht_maxcount); \
17048 pushSTACK(TheHashtable(ht_from_map_hashtable)->ht_kvtable); \
17049 while (1) { \
17050 if (index_from_map_hashtable==0) break; \
17051 index_from_map_hashtable -= 3; \
17052 {var gcv_object_t* KVptr_from_map_hashtable = \
17053 &TheHashedAlist(STACK_0)->hal_data[index_from_map_hashtable]; \
17054 var object key = KVptr_from_map_hashtable[0]; \
17055 if (boundp(key)) { \
17056 var object value = KVptr_from_map_hashtable[1]; \
17057 statement; \
17058 } } } \
17059 skipSTACK(1); \
17060 } while(0)
17061 #define map_hashtable_nogc(ht,key,value,statement) \
17062 do { \
17063 var object ht_from_map_hashtable = (ht); \
17064 var uintL index_from_map_hashtable = \
17065 posfixnum_to_V(TheHashtable(ht_from_map_hashtable)->ht_maxcount); \
17066 var gcv_object_t* KVptr_from_map_hashtable = \
17067 &TheHashedAlist(TheHashtable(ht_from_map_hashtable)->ht_kvtable)->hal_data[3*index_from_map_hashtable]; \
17068 while (1) { \
17069 if (index_from_map_hashtable==0) break; \
17070 index_from_map_hashtable--; KVptr_from_map_hashtable -= 3; \
17071 { var object key = KVptr_from_map_hashtable[0]; \
17072 if (boundp(key)) { \
17073 var object value = KVptr_from_map_hashtable[1]; \
17074 statement; \
17075 } } } \
17076 } while(0)
17077 /* is used by IO */
17078
17079 /* ######################### IOBIBL for IO.D ############################# */
17080
17081 /* check a cint for being a whitespace */
17082 #define cint_white_p(c) \
17083 ((c)==' ' || (c)=='\n' || (c)=='\r' || (c)=='\t' || (c)=='\v' || (c)=='\f')
17084
17085 /* special Object, that indicates EOF */
17086 #define eof_value make_system(0xE0FE0FUL)
17087 /* is used by IO, STREAM, DEBUG, SPVW */
17088
17089 /* aux. value to recognize certain Dots */
17090 #define dot_value make_system(0xD0DD0DUL)
17091 /* is used by IO, SPVW */
17092
17093 /* UP: Initializes the reader.
17094 init_reader();
17095 can trigger GC */
17096 extern maygc void init_reader (void);
17097 #if defined(MULTITHREAD)
17098 #define INIT_READER_LOW_ARGS struct clisp_thread_t* thr
17099 #define INIT_READER_LOW_OTAB thr->_object_tab
17100 #define INIT_READER_LOW() init_reader_low(current_thread())
17101 #else
17102 #define INIT_READER_LOW_ARGS void
17103 #define INIT_READER_LOW_OTAB object_tab
17104 #define INIT_READER_LOW() init_reader_low()
17105 #endif
17106 extern maygc void init_reader_low (INIT_READER_LOW_ARGS);
17107 /* is used by SPVW */
17108
17109 /* UP:
17110 (setf (strm-pphelp-strings *stream_)
17111 (list* (make-Semi-Simple-String 50)
17112 (cons nl_type *PRIN-INDENTATION*)
17113 (strm-pphelp-strings *stream_))) */
17114 extern object cons_ssstring (const gcv_object_t* stream_, object nl_type);
17115 /* used by io.d and stream.d */
17116
17117 /* UP: Reads an object.
17118 stream_read(&stream,recursive-p,whitespace-p)
17119 > recursive-p: tells whether there's a recursive call of READ,
17120 with error at EOF
17121 > whitespace-p: tells, whether whitespace is to be consumed afterwards
17122 > stream: Stream
17123 < stream: Stream
17124 < result: read object (eof_value at EOF, dot_value for single dot)
17125 can trigger GC */
17126 extern maygc object stream_read (const gcv_object_t* stream_, object recursive_p, object whitespace_p);
17127 /* is used by SPVW, DEBUG */
17128
17129 /* UP: Write a Simple-String to a Stream element by element.
17130 write_sstring(&stream,string);
17131 > string: Simple-String
17132 > stream: Stream
17133 < stream: Stream
17134 can trigger GC */
17135 extern maygc void write_sstring (const gcv_object_t* stream_, object string);
17136 /* is used by EVAL, DEBUG, ERROR, PACKAGE, SPVW */
17137
17138 /* UP: Writes a String to a Stream element by element.
17139 write_string(&stream,string);
17140 > string: String
17141 > stream: Stream
17142 < stream: Stream
17143 can trigger GC */
17144 extern maygc void write_string (const gcv_object_t* stream_, object string);
17145 /* is used by PACKAGE, DEBUG */
17146
17147 /* UP: Writes an object to a Stream.
17148 prin1(&stream,obj);
17149 > obj: Objekt
17150 > stream: Stream
17151 < stream: Stream
17152 can trigger GC */
17153 extern maygc void prin1 (const gcv_object_t* stream_, object obj);
17154 /* is used by EVAL, DEBUG, PACKAGE, ERROR, SPVW */
17155
17156 /* UP: Writes a Newline to a Stream.
17157 terpri(&stream);
17158 > stream: Stream
17159 < stream: Stream
17160 can trigger GC
17161 extern maygc void terpri (const gcv_object_t* stream_); */
17162 #define terpri(stream_) write_ascii_char(stream_,NL)
17163 /* is used by IO, DEBUG, PACKAGE, ERROR, SPVW */
17164
17165 /* ####################### Functional arguments for FUNARG.D ################ #
17166 used by LIST, WEAK, SEQUENCE */
17167
17168 /* UP: Checks the :KEY argument
17169 check_key_arg()
17170 > *pkey_arg: optional argument
17171 < *pkey_arg: correct KEY function */
17172 global void check_key_arg (gcv_object_t *pkey_arg);
17173 /* used by LIST, SEQUENCE, WEAK */
17174
17175 /* Applies a :KEY argument.
17176 funcall_key(key,item);
17177 > key: value of the :KEY argument
17178 > item: object being considered
17179 < value1: (FUNCALL key item) */
17180 #define funcall_key(key,item) do { \
17181 var object _key = (key); \
17182 var object _item = (item); \
17183 GCTRIGGER2(_key,_item); \
17184 /* shortcut for :KEY #'IDENTITY, very common */ \
17185 if (!eq(_key,L(identity))) { \
17186 pushSTACK(_item); funcall(_key,1); \
17187 } else { \
17188 value1 = _item; \
17189 } \
17190 } while(0)
17191
17192 /* Subroutine to compute the test :TEST & :TEST-NOT
17193 call_test(fun,item,x)
17194 > *fun: the test function
17195 > item: the item to compare with
17196 > x: the argument
17197 < result: true if the test is okay, otherwise false.
17198 can trigger GC */
17199 typedef maygc bool funarg_t (const gcv_object_t* fun, object item, object x);
17200 funarg_t call_if, call_if_not;
17201
17202 /* UP: Check the :TEST, :TEST-NOT - arguments
17203 check_test_args()
17204 > stackptr: Pointer to the STACK
17205 > *(stackptr+1): :TEST argument
17206 > *(stackptr+0): :TEST-NOT argument
17207 < *(stackptr+1): computed :TEST argument
17208 < *(stackptr+0): computed :TEST-NOT argument
17209 < call_test: Adress of a test function */
17210 extern funarg_t* check_test_args (gcv_object_t* stackptr);
17211
17212 /* ####################### LISTBIBL for LIST.D ############################# */
17213
17214 /* UP: Copies a list
17215 copy_list(list)
17216 > list: list
17217 < result: copy of the list
17218 can trigger GC */
17219 extern maygc object copy_list (object list);
17220 /* is used by PACKAGE */
17221 %% exportF(object,copy_list,(object old_list));
17222
17223 /* UP: Reverses a list constructively.
17224 reverse(list)
17225 > list: list (x1 ... xm)
17226 < result: reversed list (xm ... x1)
17227 can trigger GC */
17228 extern maygc object reverse (object list);
17229 /* is used by SEQUENCE, PACKAGE, PATHNAME */
17230
17231 /* UP: get the length of a list and the last atom
17232 llength1(obj,last)
17233 > obj: object
17234 < uintL result: length of obj, interpreted as list
17235 < last: the last atom
17236 Does not test for circular lists. */
17237 extern uintL llength1 (object obj, object* last);
17238 /* used in SEQUENCE */
17239 #define llength(obj) llength1(obj,NULL)
17240 /* used by CONTROL, EVAL, RECORD, IO, PACKAGE, HASHTABL, STREAM */
17241 %% exportF(uintL,llength1,(object obj, object* last));
17242
17243 /* UP: Makes a list with exactly len elements
17244 make_list(len)
17245 > STACK_0: Initial value for the elements
17246 > uintL len: desired list length
17247 < result: list with len elements
17248 can trigger GC */
17249 extern maygc object make_list (uintL len);
17250 /* is used by */
17251 %% #if notused
17252 %% exportF(object,make_list,(uintL len));
17253 %% #endif
17254
17255 /* UP: reverses a list destructively.
17256 nreverse(list)
17257 > list: list (x1 ... xm)
17258 < result: list (xm ... x1), EQ to the old one */
17259 extern object nreverse (object list);
17260 /* is used by SEQUENCE, EVAL, CONTROL, IO, PATHNAME, ERROR, DEBUG, PACKAGE */
17261 %% exportF(object,nreverse,(object list));
17262
17263 /* UP: A0 := (nreconc A0 A1)
17264 nreconc(list,obj)
17265 > list: list
17266 > obj: object
17267 < result: (nreconc A0 A1) */
17268 extern object nreconc (object list, object obj);
17269 /* is used by SEQUENCE, IO, PATHNAME, CONTROL, DEBUG */
17270
17271 /* UP: Build (delete obj (the list list) :test #'EQ)
17272 deleteq(list,obj)
17273 Remove all elements that are EQ to obj from the list.
17274 > obj: element to be removed
17275 > list: list
17276 < result: modified list */
17277 extern object deleteq (object list, object obj);
17278 /* is used by PACKAGE, STREAM */
17279 %% exportF(object,deleteq,(object list, object obj));
17280
17281 /* UP: check whether OBJ ends a proper list
17282 endp(obj)
17283 > obj: object
17284 < result: true if obj is the list end NIL,
17285 false if obj is a Cons.
17286 error otherwise */
17287 extern bool endp (object obj);
17288 /* used by CONTROL */
17289 %% exportF(bool,endp,(object obj));
17290
17291 /* Finds the length of a possibly circular or dotted list.
17292 list_length(list,&dotted)
17293 > list: an object
17294 < result: the length (integer >= 0, or NIL for circular lists)
17295 < dotted: if non-circular, the last atom, i.e., the indicator whether the list
17296 is dotted
17297 can trigger GC */
17298 extern maygc object list_length (object list, object *dottedp);
17299 /* used by SEQUENCE */
17300
17301 /* proper_list_p(obj)
17302 returns true if obj is a proper list, i.e. a list which is neither dotted
17303 nor circular, i.e. a list which ends in NIL. */
17304 extern bool proper_list_p (object obj);
17305 /* used by PREDTYPE */
17306
17307 /* UP: Creates a list with given elements.
17308 listof(len)
17309 > uintC len: desired list length
17310 > auf STACK: len objects, first one on top
17311 < result: list of those objects
17312 Increases STACK
17313 modifies STACK, can trigger GC */
17314 extern maygc object listof (uintC len);
17315 /* used by STREAM, PATHNAME, PACKAGE, ARRAY, EVAL, PREDTYPE, ERROR, SPVW */
17316 %% exportF(object,listof,(uintC len));
17317
17318 /* UP: find OBJ in LIS: (MEMBER OBJ LIS :TEST #'EQ) */
17319 extern object memq (const object obj, const object lis);
17320 /* used by RECORD */
17321 %% exportF(object,memq,(const object obj, const object lis));
17322
17323 /* ####################### MISCBIBL for MISC.D ############################# */
17324
17325 /* for modules */
17326 typedef struct { long c_const; gcv_object_t *l_const; } c_lisp_pair_t;
17327 typedef struct {
17328 const c_lisp_pair_t *table; /* C <--> Lisp */
17329 const unsigned int size; /* table length */
17330 const long default_value; /* what to use when Lisp value is missing */
17331 const bool have_default_value_p; /* use default_value? */
17332 const char *name; /* map name for error messages */
17333 } c_lisp_map_t;
17334 extern maygc long map_lisp_to_c (object obj, const c_lisp_map_t *map);
17335 extern maygc object map_c_to_lisp (long val, const c_lisp_map_t *map);
17336 extern maygc object map_c_to_list (long val, const c_lisp_map_t *map);
17337 global maygc long map_list_to_c (object obj, const c_lisp_map_t *map);
17338 %% emit_typedef("struct { long c_const; gcv_object_t *l_const; }","c_lisp_pair_t");
17339 %% emit_typedef("struct { const c_lisp_pair_t *table; const unsigned int size; const long default_value; const bool have_default_value_p; const char *name; }","c_lisp_map_t");
17340 %% exportF(long,map_lisp_to_c,(object obj, const c_lisp_map_t *map));
17341 %% exportF(object,map_c_to_lisp,(long val, const c_lisp_map_t *map));
17342 %% exportF(object,map_c_to_list,(long val, const c_lisp_map_t *map));
17343 %% exportF(long,map_list_to_c,(object obj, const c_lisp_map_t *map));
17344 global maygc void push_string_array (char **arr);
17345 %% exportF(void,push_string_array,(char **arr));
17346 global maygc object safe_to_string (const char *asciz);
17347 %% exportF(object,safe_to_string,(const char *asciz));
17348
17349 /* ####################### ERRBIBL for ERROR.D ############################# */
17350
17351 /* Classification of the known condition-types:
17352 (More precisely, all these are the SIMPLE-... types.) */
17353 typedef enum {
17354 condition, /* all kinds of conditions */
17355 serious_condition, /* conditions that require interactive intervention */
17356 error_condition, /* serious conditions that occur deterministically */
17357 program_error, /* mostly statically detectable errors of a program */
17358 source_program_error, /* statically detectable errors of a program, */
17359 /* source available */
17360 control_error, /* not statically detectable errors in program control */
17361 arithmetic_error, /* errors that occur while doing arithmetic operations */
17362 division_by_zero, /* eval a mathematical function at a singularity */
17363 floating_point_overflow, /* trying to get too close to infinity and... */
17364 floating_point_underflow, /* trying to get too close to zero */
17365 /* in the floating point domain */
17366 cell_error, /* trying to access a location which contains #<UNBOUND> */
17367 unbound_variable, /* trying to get the value of an unbound variable */
17368 undefined_function, /* trying to get the global function definition */
17369 /* of an undefined function */
17370 unbound_slot, /* trying to get the value of an unbound slot */
17371 type_error, /* some datum does not belong to the expected type */
17372 keyword_error, /* a keyword is not one of the allowed keywords */
17373 charset_type_error, /* a character does not belong to a character set */
17374 argument_list_dotted, /* an argument list in APPLY is dotted */
17375 package_error, /* errors during operation on packages */
17376 print_not_readable, /* attempted violation of *PRINT-READABLY* */
17377 parse_error, /* errors related to parsing */
17378 stream_error, /* errors while doing stream I/O */
17379 end_of_file, /* unexpected end of stream */
17380 reader_error, /* parsing/tokenization error during READ */
17381 file_error, /* errors with pathnames, OS level errors with streams */
17382 storage_condition, /* "Virtual memory exhausted" */
17383 interrupt_condition, /* "User break" */
17384 warning, /* conditions for which user notification is appropriate */
17385 number_of_conditions_defined_in_c
17386 } condition_t;
17387 %% printf("typedef enum { condition=%d, serious_condition=%d, error_condition=%d, program_error=%d, source_program_error=%d, control_error=%d, arithmetic_error=%d, division_by_zero=%d, floating_point_overflow=%d, floating_point_underflow=%d, cell_error=%d, unbound_variable=%d, undefined_function=%d, unbound_slot=%d, type_error=%d, keyword_error=%d, charset_type_error=%d, package_error=%d, print_not_readable=%d, parse_error=%d, stream_error=%d, end_of_file=%d, reader_error=%d, file_error=%d, storage_condition=%d, interrupt_condition=%d, warning=%d } condition_t;\n",condition, serious_condition, error_condition, program_error, source_program_error, control_error, arithmetic_error, division_by_zero, floating_point_overflow, floating_point_underflow, cell_error, unbound_variable, undefined_function, unbound_slot, type_error, keyword_error, charset_type_error, package_error, print_not_readable, parse_error, stream_error, end_of_file, reader_error, file_error, storage_condition, interrupt_condition, warning);
17388
17389 /* Error with error-string. Does not return.
17390 error(errortype,errorstring);
17391 > errortype: condition-type
17392 > errorstring: constant ASCIZ-String, in UTF-8 Encoding.
17393 At every tilde-S, a LISP-object is taken from the STACK and printed
17394 instead of the tilde-S.
17395 > on the STACK: initial values for the Condition, depending on error-type */
17396 extern _Noreturn void error (condition_t errortype, const char * errorstring);
17397 /* used by all modules */
17398 %% exportE(error,(condition_t errortype, const char * errorstring));
17399
17400 /* Report an error and try to recover by asking the user to supply a value.
17401 check_value(errortype,errorstring);
17402 > errortype: condition-type
17403 > errorstring: constant ASCIZ-String, in UTF-8 Encoding.
17404 At every tilde-S, a LISP-object is taken from the STACK and printed
17405 instead of the tilde-S.
17406 > on the STACK: PLACE (form to be shown to the user) or NIL, then
17407 the initial values for the Condition, depending on error-type
17408 < value1, value2: return values from CHECK-VALUE:
17409 value1 = value supplied by the user,
17410 value2 = indicates whether PLACE should be filled
17411 < STACK: cleaned up
17412 can trigger GC */
17413 extern maygc void check_value (condition_t errortype, const char * errorstring);
17414 /* used by all modules */
17415 %% exportF(void,check_value,(condition_t errortype, const char * errorstring));
17416
17417 /* Report an error and try to recover by asking the user to choose among some
17418 alternatives.
17419 correctable_error(errortype,errorstring);
17420 > errortype: condition-type
17421 > errorstring: constant ASCIZ-String, in UTF-8 Encoding.
17422 At every tilde-S, a LISP-object is taken from the STACK and printed
17423 instead of the tilde-S.
17424 > on the STACK: list of alternatives
17425 ((restart-name restart-help-string . value-returned-by-the-restart)*),
17426 then the initial values for the Condition, depending on error-type
17427 < value1: return value from CORRECTABLE-ERROR, one of the CDDRs of the
17428 alternatives
17429 < STACK: cleaned up
17430 can trigger GC */
17431 extern maygc void correctable_error (condition_t errortype, const char* errorstring);
17432 /* use by PACKAGE, new-clx */
17433
17434 /* Just like OS_error, but signal an error of type ETYPE.
17435 OS_file_error(pathname);
17436 > etype: symbolic name of the error type
17437 > arg: error argument
17438 > end_system_call() already called */
17439 extern _Noreturn void OS_error_arg (object etype, object arg);
17440 #if defined(DEBUG_OS_ERROR)
17441 /* Show the file and line number of the caller of OS_file_error().
17442 For debugging. */
17443 #define OS_error_arg(etype,arg) \
17444 (fprintf(stderr,"\n[%s:%d] ",__FILE__,__LINE__), (OS_error_arg)(etype,arg))
17445 #endif
17446 #define OS_file_error(path) OS_error_arg(S(os_file_error),path)
17447 %% exportE(OS_error_arg,(object etype, object arg));
17448 %% puts("#define OS_file_error(path) OS_error_arg(S(os_file_error),path)");
17449
17450 /* Just like OS_error, but takes a channel stream and signals a FILE-ERROR.
17451 OS_filestream_error(stream);
17452 > stream: a channel stream
17453 > end_system_call() already called */
17454 extern _Noreturn void OS_filestream_error (object stream);
17455 #if defined(DEBUG_OS_ERROR)
17456 /* Show the file and line number of the caller of OS_filestream_error(). For debugging. */
17457 #define OS_filestream_error(stream) \
17458 (fprintf(stderr,"\n[%s:%d] ",__FILE__,__LINE__), (OS_filestream_error)(stream))
17459 #endif
17460 %% exportE(OS_filestream_error,(object stream));
17461
17462 /* Prints error directly via the OS: errno_out_low(errorcode,FILE,LINE);
17463 > errorcode: error code
17464 > FILE: Filename (with quotation marks) as constant ASCIZ-String
17465 > LINE: line number */
17466 #if defined(UNIX)
17467 extern void errno_out_low (int errorcode, const char* file, uintL line);
17468 #endif
17469 #if defined(WIN32_NATIVE)
17470 extern void errno_out_low (DWORD errorcode, const char* file, uintL line);
17471 #endif
17472 /* Show the file and line number of the caller of errno_out(). */
17473 #define errno_out(e) errno_out_low(e,__FILE__,__LINE__)
17474
17475 /* UP: Executes break-loop because of a keyboard-interrupt.
17476 > -(STACK) : calling funtion
17477 modifies STACK, can trigger GC */
17478 extern maygc void tast_break (void);
17479 /* is used by EVAL, IO, SPVW, STREAM */
17480
17481 /* check_classname(obj,type)
17482 > obj: an object
17483 > classname: a symbol expected to name a class with "proper name" classname
17484 < result: an object of the given type, either the same as obj or a replacement
17485 can trigger GC */
17486 extern maygc object check_classname (object obj, object type);
17487 %% exportF(object,check_classname,(object obj, object classname));
17488
17489 #ifdef FOREIGN
17490 /* check_fpointer(obj,restart_p)
17491 > obj: an object
17492 > restart_p: flag whether to allow entering a replacement
17493 < result: a valid foreign pointer, either the same as obj or a replacement
17494 can trigger GC */
17495 extern maygc object check_fpointer_replacement (object obj, bool restart_p);
17496 #ifndef COMPILE_STANDALONE
check_fpointer(object obj,bool restart_p)17497 static inline maygc object check_fpointer (object obj, bool restart_p) {
17498 if (!(fpointerp(obj) && fp_validp(TheFpointer(obj))))
17499 obj = check_fpointer_replacement(obj,restart_p);
17500 return obj;
17501 }
17502 #endif
17503 /* used by FOREIGN and REGEXP (amd maybe other non-FFI modules) */
17504 #endif
17505 %% #ifdef FOREIGN
17506 %% exportF(object,check_fpointer_replacement,(object obj, bool restart_p));
17507 %% puts("#ifndef COMPILE_STANDALONE");
17508 %% puts("static inline object check_fpointer (object obj, bool restart_p) {"
17509 %% " if (!(fpointerp(obj) && fp_validp(TheFpointer(obj))))"
17510 %% " obj = check_fpointer_replacement(obj,restart_p);"
17511 %% " return obj;"
17512 %% " }");
17513 %% puts("#endif");
17514 %% #endif
17515
17516 /* Error message, if an object isn't a list.
17517 error_list(obj);
17518 > obj: non-list */
17519 extern _Noreturn void error_list (object obj);
17520 /* used by LIST, EVAL, STREAM */
17521 %% #if notused
17522 %% exportE(error_list,(object obj));
17523 %% #endif
17524
17525 /* check_list(obj)
17526 > obj: an object
17527 < result: a list, either the same as obj or a replacement
17528 can trigger GC */
17529 extern maygc object check_list_replacement (object obj);
17530
17531 /* create check function for name */
17532 #define MAKE_CHECK_LOW(name,test) \
17533 static inline maygc object check_##name (object obj) { \
17534 if (!test) \
17535 obj = check_##name##_replacement(obj); \
17536 return obj; \
17537 }
17538 #define MAKE_CHECK(name) MAKE_CHECK_LOW(name,name##p(obj))
17539 #define MAKE_CHECK_(name) MAKE_CHECK_LOW(name,name##_p(obj))
17540
17541 #ifndef COMPILE_STANDALONE
17542 MAKE_CHECK(list)
17543 #endif
17544 /* used by PATHNAME */
17545 %% exportF(object,check_list_replacement,(object obj));
17546 %% puts("#ifndef COMPILE_STANDALONE");
17547 %% export_literal(MAKE_CHECK(list));
17548 %% puts("#endif");
17549
17550 /* Error message, if an object isn't a proper list because it is dotted.
17551 error_proper_list_dotted(caller,obj);
17552 > caller: caller (a symbol)
17553 > obj: End of list, non-list */
17554 extern _Noreturn void error_proper_list_dotted (object caller, object obj);
17555 /* is used by LIST */
17556 %% exportE(error_proper_list_dotted,(object caller, object obj));
17557
17558 /* Error message, if an object isn't a proper list because it is circular.
17559 error_proper_list_circular(caller,obj);
17560 > caller: caller (a symbol)
17561 > obj: circular list */
17562 extern _Noreturn void error_proper_list_circular (object caller, object obj);
17563 /* is used by LIST */
17564
17565 /* check_symbol(obj)
17566 > obj: an object
17567 < result: a symbol, either the same as obj or a replacement
17568 can trigger GC */
17569 extern maygc object check_symbol_replacement (object obj);
17570 #ifndef COMPILE_STANDALONE
check_symbol(object obj)17571 static inline maygc object check_symbol (object obj) {
17572 if (!symbolp(obj))
17573 obj = check_symbol_replacement(obj);
17574 return obj;
17575 }
17576 #endif
17577 /* used by CONTROL, EVAL, I18N, PACKAGE, PREDTYPE, RECORD, STREAM, SYMBOL */
17578
17579 /* check_symbol_non_constant(obj,caller)
17580 > obj: an object
17581 > caller: a symbol
17582 < result: a non-constant symbol, either the same as obj or a replacement
17583 can trigger GC */
17584 extern maygc object check_symbol_non_constant_replacement (object obj, object caller);
17585 #ifndef COMPILE_STANDALONE
check_symbol_non_constant(object obj,object caller)17586 static inline maygc object check_symbol_non_constant (object obj, object caller) {
17587 if (!(symbolp(obj) && !constant_var_p(TheSymbol(obj))))
17588 obj = check_symbol_non_constant_replacement(obj,caller);
17589 return obj;
17590 }
17591 #endif
17592 /* used by EVAL, CONTROL */
17593
17594 /* UP: signal an error if a non-symbol was declared (e.g. SPECIAL)
17595 returns the symbol
17596 can trigger GC */
17597 extern maygc object check_symbol_in_declaration (object obj, object decl_identifier, object caller);
17598 /* used by EVAL, CONTROL */
17599
17600 /* UP: make sure that the symbol does not name a global symbol-macro
17601 return the symbol
17602 can trigger GC */
17603 global maygc object check_symbol_not_symbol_macro (object symbol);
17604 /* use by CONTROL, PACKAGE, SYMBOL */
17605
17606 /* UP: make sure that the symbol does not name a global special variable
17607 return the symbol
17608 can trigger GC */
17609 global maygc object check_symbol_not_global_special (object symbol);
17610 /* used by SYMBOL */
17611
17612 /* Error message, if an object isn't a Simple-Vector.
17613 error_no_svector(caller,obj);
17614 > caller: caller (a Symbol)
17615 > obj: non-Svector */
17616 extern _Noreturn void error_no_svector (object caller, object obj);
17617 /* is used by ARRAY, EVAL */
17618 %% #if notused
17619 %% exportE(error_no_svector,(object caller, object obj));
17620 %% #endif
17621
17622 /* Error message, if an object isn't a vector.
17623 error_vector(obj);
17624 > obj: non-vector */
17625 extern _Noreturn void error_vector (object obj);
17626 /* is used by ARRAY */
17627 %% #if notused
17628 %% exportE(error_vector,(object obj));
17629 %% #endif
17630
17631 /* check_array(obj)
17632 > obj: an object
17633 < result: an array, either the same as obj or a replacement
17634 can trigger GC */
17635 extern maygc object check_array_replacement (object obj);
17636 #ifndef COMPILE_STANDALONE
17637 MAKE_CHECK(array)
17638 #endif
17639 /* used by ARRAY, modules */
17640 %% exportF(object,check_array_replacement,(object obj));
17641 %% puts("#ifndef COMPILE_STANDALONE");
17642 %% export_literal(MAKE_CHECK(array));
17643 %% puts("#endif");
17644
17645 /* check_vector(obj)
17646 > obj: an object
17647 < result: an vector, either the same as obj or a replacement
17648 can trigger GC */
17649 extern maygc object check_vector_replacement (object obj);
17650 #ifndef COMPILE_STANDALONE
17651 MAKE_CHECK(vector)
17652 #endif
17653 /* used by ARRAY, ENCODING, modules */
17654 %% exportF(object,check_vector_replacement,(object obj));
17655 %% puts("#ifndef COMPILE_STANDALONE");
17656 %% export_literal(MAKE_CHECK(vector));
17657 %% puts("#endif");
17658
17659 /* check_byte_vector_replacement(obj)
17660 > obj: not an (ARRAY (UNSIGNED-BYTE 8) (*))
17661 < result: an (ARRAY (UNSIGNED-BYTE 8) (*)), a replacement
17662 can trigger GC */
17663 extern maygc object check_byte_vector_replacement (object obj);
17664 #ifndef COMPILE_STANDALONE
17665 MAKE_CHECK_LOW(byte_vector,bit_vector_p(Atype_8Bit,obj))
17666 #endif
17667 /* used by STREAM, modules */
17668 %% exportF(object,check_byte_vector_replacement,(object obj));
17669 %% puts("#ifndef COMPILE_STANDALONE");
17670 %% export_literal(MAKE_CHECK_LOW(byte_vector,bit_vector_p(Atype_8Bit,obj)));
17671 %% puts("#endif");
17672
17673
17674 /* error-message, if an object is not an environment.
17675 error_environment(obj);
17676 > obj: non-vector */
17677 extern _Noreturn void error_environment (object obj);
17678 /* used by EVAL, CONTROL */
17679
17680 /* Error message, if an argument isn't a Fixnum >=0:
17681 > obj: the faulty argument */
17682 extern _Noreturn void error_posfixnum (object obj);
17683 /* used by DEBUG, ENCODING, FOREIGN, IO, STREAM, TIME */
17684
17685 /* check_posfixnum(obj)
17686 > obj: an object
17687 < result: a fixnum >= 0, either the same as obj or a replacement
17688 can trigger GC */
17689 extern maygc object check_posfixnum_replacement (object obj);
17690 #ifndef COMPILE_STANDALONE
17691 MAKE_CHECK(posfixnum)
17692 #endif
17693 /* used by STREAM, LISPARIT */
17694 %% exportF(object,check_posfixnum_replacement,(object obj));
17695 %% puts("#ifndef COMPILE_STANDALONE");
17696 %% export_literal(MAKE_CHECK(posfixnum));
17697 %% puts("#endif");
17698
17699 /* check_integer(obj)
17700 > obj: an object
17701 < result: an integer, either the same as obj or a replacement
17702 can trigger GC */
17703 extern maygc object check_integer_replacement (object obj);
17704 #ifndef COMPILE_STANDALONE
17705 MAKE_CHECK(integer)
17706 #endif
17707 /* used by LISPARIT */
17708
17709 /* check_pos_integer(obj)
17710 > obj: an object
17711 < result: an integer >= 0, either the same as obj or a replacement
17712 can trigger GC */
17713 extern maygc object check_pos_integer_replacement (object obj);
17714 #ifndef COMPILE_STANDALONE
17715 MAKE_CHECK_LOW(pos_integer,(integerp(obj)&&!R_minusp(obj)))
17716 #endif
17717 /* used by LISPARIT, LIST */
17718 %% exportF(object,check_pos_integer_replacement,(object obj));
17719 %% puts("#ifndef COMPILE_STANDALONE");
17720 %% export_literal(MAKE_CHECK_LOW(pos_integer,(integerp(obj)&&!R_minusp(obj))));
17721 %% puts("#endif");
17722
17723 /* Error when the argument is not a non-negative integer
17724 > kw: keyword naming the argument
17725 > object: bad index */
17726 extern _Noreturn void error_pos_integer (object kw, object obj);
17727 /* used by CHARSTRG, SEQUENCE */
17728
17729 /* Error message, if an argument isn't a Character:
17730 error_char(obj);
17731 > obj: the faulty argument */
17732 extern _Noreturn void error_char (object obj);
17733 /* used by IO, STREAM */
17734
17735 /* check_char(obj)
17736 > obj: an object
17737 < result: a character, either the same as obj or a replacement
17738 can trigger GC */
17739 extern maygc object check_char_replacement (object obj);
17740 #ifndef COMPILE_STANDALONE
17741 MAKE_CHECK(char)
17742 #endif
17743 /* used by CHARSTRG, ENCODING, IO */
17744 %% #if notused
17745 %% exportF(object,check_char_replacement,(object obj));
17746 %% puts("#ifndef COMPILE_STANDALONE");
17747 %% export_literal(MAKE_CHECK(char));
17748 %% puts("#endif");
17749 %% #endif
17750
17751 /* check_string(obj)
17752 > obj: an object
17753 < result: a string, either the same as obj or a replacement
17754 can trigger GC */
17755 extern maygc object check_string_replacement (object obj);
17756 #ifndef COMPILE_STANDALONE
17757 MAKE_CHECK(string)
17758 #endif
17759 /* used by CHARSTRG, FOREIGN, MISC, PACKAGE, PATHNAME, STREAM, SOCKET, I18N */
17760 %% exportF(object,check_string_replacement,(object obj));
17761 %% puts("#ifndef COMPILE_STANDALONE");
17762 %% export_literal(MAKE_CHECK(string));
17763 %% puts("#endif");
17764
17765 /* Error message, if an argument isn't a Simple-String:
17766 error_sstring(obj);
17767 > obj: the faulty argument */
17768 extern _Noreturn void error_sstring (object obj);
17769 /* is used by CHARSTRG */
17770 %% #if notused
17771 %% exportE(error_sstring,(object obj));
17772 %% #endif
17773
17774 /* Checks a simple-string for being mutable.
17775 check_sstring_mutable(string); */
17776 #define check_sstring_mutable(obj) \
17777 if (sstring_immutable(TheSstring(obj))) \
17778 error_sstring_immutable(obj);
17779 /* Error message, if a Simple-String is immutable:
17780 error_sstring_immutable(obj);
17781 > obj: the String */
17782 extern _Noreturn void error_sstring_immutable (object obj);
17783 /* is used by Macro check_sstring_mutable */
17784
17785 /* Error message, if an argument is not of type (OR STRING INTEGER).
17786 error_string_integer(obj); */
17787 extern _Noreturn void error_string_integer (object obj);
17788 %% exportE(error_string_integer,(object obj));
17789
17790 /* Error message, if a string size is too big.
17791 error_stringsize(size);
17792 > size: the desired string length */
17793 extern _Noreturn void error_stringsize (uintV size);
17794
17795 /* Check a string size, reporting an error when it's too big. */
17796 #define check_stringsize(size) \
17797 if ((size) > stringsize_limit_1) \
17798 error_stringsize(size)/*;*/
17799
17800 /* error message if an argument is not a class.
17801 error_class(caller,obj);
17802 > obj: the erroneous argument */
17803 extern _Noreturn void error_class (object obj);
17804
17805 /* Report an error when the argument is not an encoding:
17806 check_encoding(obj,&default,keyword_p)
17807 > obj: the (possibly) bad argument
17808 > default: what to return for :DEFAULT
17809 > keyword_p: true if the object comes from the :EXTERNAL-FORMAT argument
17810 < result: an encoding
17811 can trigger GC */
17812 extern maygc object check_encoding (object obj, const gcv_object_t* e_default,
17813 bool keyword_p);
17814 /* used by ENCODING, FOREIGN */
17815
17816 /* Signal an Error on illegal argument
17817 > arg: bad object
17818 > typ: expected type (may be nullobj to signal a regular error
17819 instead of a type-error)
17820 > key: the argument name (usually a keyword) */
17821 global _Noreturn void error_illegal_arg (object arg, object typ, object key);
17822 /* used by ENCODING, PATHNAME, STREAM */
17823
17824 /* Error when the property list has odd length
17825 error_plist_odd(caller,plist);
17826 > plist: bad plist */
17827 extern _Noreturn void error_plist_odd (object plist);
17828 %% exportE(error_plist_odd,(object plist));
17829
17830 /* error-message for non-paired keyword-arguments
17831 error_key_odd(argcount,caller);
17832 > argcount: the number of arguments on the STACK
17833 > caller: function */
17834 extern _Noreturn void error_key_odd (uintC argcount, object caller);
17835 %% exportE(error_key_odd,(uintC argcount, object caller));
17836
17837 /* error-message for flawed keyword
17838 error_key_notkw(kw);
17839 > key: Non-Symbol
17840 > caller: function */
17841 extern _Noreturn void error_key_notkw (object key, object caller);
17842
17843 /* error-message for flawed keyword
17844 error_key_badkw(fun,kw,kwlist);
17845 > fun: function
17846 > key: illegal keyword
17847 > val: its value
17848 > kwlist: list of legal keywords */
17849 extern _Noreturn void error_key_badkw (object fun, object key, object val, object kwlist);
17850 %% exportE(error_key_badkw,(object fun, object key, object val, object kwlist));
17851
17852 /* check_function(obj)
17853 > obj: an object
17854 < result: a function, either the same as obj or a replacement
17855 can trigger GC */
17856 extern maygc object check_function_replacement (object obj);
17857 #ifndef COMPILE_STANDALONE
17858 MAKE_CHECK(function)
17859 #endif
17860 /* used by RECORD, EVAL, SEQUENCE, SYMBOL, FOREIGN */
17861
17862 /* error if funname does not have a function definition
17863 check_fdefinition(funname,caller)
17864 > funname: symbol or (setf symbol)
17865 > caller: symbol
17866 < a function object, possibly also installed as (FDEFINITION funname)
17867 can trigger GC */
17868 extern maygc object check_fdefinition (object funname, object caller);
17869 /* used by EVAL, CONTROL */
17870
17871 /* check_funname(obj)
17872 > errtype: type of condition to signal if obj is not a function name,
17873 either type_error or source_program_error
17874 > caller: a symbol
17875 > obj: an object
17876 < result: a function name, either the same as obj or a replacement
17877 can trigger GC */
17878 extern maygc object check_funname_replacement (condition_t errtype, object caller, object obj);
17879 #ifndef COMPILE_STANDALONE
check_funname(condition_t errtype,object caller,object obj)17880 static inline maygc object check_funname (condition_t errtype, object caller, object obj) {
17881 if (!funnamep(obj))
17882 obj = check_funname_replacement(errtype,caller,obj);
17883 return obj;
17884 }
17885 #endif
17886 /* used by EVAL, CONTROL */
17887
17888 /* Error message, if an argument is a lambda-expression instead of a function:
17889 error_lambda_expression(caller,obj);
17890 caller: caller (a symbol)
17891 obj: the faulty argument */
17892 extern _Noreturn void error_lambda_expression (object caller, object obj);
17893 /* is used by EVAL, SYMBOL */
17894
17895 /* too many/few arguments in a function call
17896 > caller : the function that is reporting the error (unbound == EVAL/APPLY)
17897 > func : the function being incorrectly called
17898 > ngiven : the number of arguments given
17899 < nmax : the maximum number of arguments accepted
17900 < nmin : the minimum number of arguments required */
17901 extern _Noreturn void error_too_many_args (object caller, object func, uintL ngiven, uintL nmax);
17902 extern _Noreturn void error_too_few_args (object caller, object func, uintL ngiven, uintL nmin);
17903
17904 /* used by EVAL, FOREIGN */
17905
17906 /* error-message, if a symbol has no value.
17907 > symbol_: unbound symbol
17908 > restart_p: false if nonreturning
17909 < value1: bound value
17910 < value2: T if STORE-VALUE was selected, NIL otherwise
17911 can trigger GC */
17912 extern maygc void check_variable_value_replacement (gcv_object_t *symbol_,
17913 bool restart_p);
17914 /* used by EVAL, CONTROL */
17915
17916 /* Error message, if an argument isn't of a given elementary C type.
17917 error_<ctype>(obj);
17918 > obj: the faulty argument */
17919 global _Noreturn void error_c_integer (object obj, int tcode, bool signedp);
17920 %% exportE(error_c_integer,(object obj, int tcode, bool signedp));
17921 #define error_uint8(obj) error_c_integer(obj,0,true)
17922 #define error_sint8(obj) error_c_integer(obj,0,true)
17923 #define error_uint16(obj) error_c_integer(obj,1,false)
17924 #define error_sint16(obj) error_c_integer(obj,1,true)
17925 #define error_uint32(obj) error_c_integer(obj,2,false)
17926 #define error_sint32(obj) error_c_integer(obj,2,true)
17927 #define error_uint64(obj) error_c_integer(obj,3,false)
17928 #define error_sint64(obj) error_c_integer(obj,3,true)
17929 /* extern _Noreturn void error_uint (object obj);
17930 extern _Noreturn void error_sint (object obj); */
17931 #if (int_bitsize==16)
17932 #define error_uint error_uint16
17933 #define error_sint error_sint16
17934 #else /* (int_bitsize==32) */
17935 #define error_uint error_uint32
17936 #define error_sint error_sint32
17937 #endif
17938 /* extern _Noreturn void error_ulong (object obj);
17939 extern _Noreturn void error_slong (object obj); */
17940 #if (long_bitsize==32)
17941 #define error_ulong error_uint32
17942 #define error_slong error_sint32
17943 #else /* (long_bitsize==64) */
17944 #define error_ulong error_uint64
17945 #define error_slong error_sint64
17946 #endif
17947 /* used by STREAM, ENCODING, modules */
17948 %% export_def(error_uint8(obj));
17949 %% export_def(error_sint8(obj));
17950 %% export_def(error_uint16(obj));
17951 %% export_def(error_sint16(obj));
17952 %% export_def(error_uint32(obj));
17953 %% export_def(error_sint32(obj));
17954 %% export_def(error_uint64(obj));
17955 %% export_def(error_sint64(obj));
17956 %% #if (int_bitsize==16)
17957 %% emit_define("error_uint","error_uint16");
17958 %% emit_define("error_sint","error_sint16");
17959 %% #else
17960 %% emit_define("error_uint","error_uint32");
17961 %% emit_define("error_sint","error_sint32");
17962 %% #endif
17963 %% #if (long_bitsize==32)
17964 %% emit_define("error_ulong","error_uint32");
17965 %% emit_define("error_slong","error_sint32");
17966 %% #else
17967 %% emit_define("error_ulong","error_uint64");
17968 %% emit_define("error_slong","error_sint64");
17969 %% #endif
17970
17971 /* Check whether an object can be converted to an elementary C type.
17972 check_<ctype>(obj)
17973 > obj: an object
17974 < result: an object that can be converted to the C type, either the same
17975 as obj or a replacement
17976 can trigger GC */
17977 extern maygc object check_c_integer_replacement (object obj, int tcode, bool signedp);
17978 #define check_uint8_replacement(obj) check_c_integer_replacement(obj,0,false)
17979 #ifndef COMPILE_STANDALONE
17980 MAKE_CHECK_(uint8)
17981 #endif
17982 #define check_sint8_replacement(obj) check_c_integer_replacement(obj,0,true)
17983 #ifndef COMPILE_STANDALONE
17984 MAKE_CHECK_(sint8)
17985 #endif
17986 #define check_uint16_replacement(obj) check_c_integer_replacement(obj,1,false)
17987 #ifndef COMPILE_STANDALONE
17988 MAKE_CHECK_(uint16)
17989 #endif
17990 #define check_sint16_replacement(obj) check_c_integer_replacement(obj,1,true)
17991 #ifndef COMPILE_STANDALONE
17992 MAKE_CHECK_(sint16)
17993 #endif
17994 #define check_uint32_replacement(obj) check_c_integer_replacement(obj,2,false)
17995 #ifndef COMPILE_STANDALONE
17996 MAKE_CHECK_(uint32)
17997 #endif
17998 #define check_sint32_replacement(obj) check_c_integer_replacement(obj,2,true)
17999 #ifndef COMPILE_STANDALONE
18000 MAKE_CHECK_(sint32)
18001 #endif
18002 #define check_uint64_replacement(obj) check_c_integer_replacement(obj,3,false)
18003 #ifndef COMPILE_STANDALONE
18004 MAKE_CHECK_(uint64)
18005 #endif
18006 #define check_sint64_replacement(obj) check_c_integer_replacement(obj,3,true)
18007 #ifndef COMPILE_STANDALONE
18008 MAKE_CHECK_(sint64)
18009 #endif
18010 extern maygc object check_uint_replacement (object obj);
18011 #ifndef COMPILE_STANDALONE
18012 MAKE_CHECK_(uint)
18013 #endif
18014 extern maygc object check_sint_replacement (object obj);
18015 #ifndef COMPILE_STANDALONE
18016 MAKE_CHECK_(sint)
18017 #endif
18018 extern maygc object check_ulong_replacement (object obj);
18019 #ifndef COMPILE_STANDALONE
18020 MAKE_CHECK_(ulong)
18021 #endif
18022 extern maygc object check_slong_replacement (object obj);
18023 #ifndef COMPILE_STANDALONE
18024 MAKE_CHECK_(slong)
18025 #endif
18026 extern maygc object check_ffloat_replacement (object obj);
18027 #ifndef COMPILE_STANDALONE
18028 MAKE_CHECK_LOW(ffloat,single_float_p(obj))
18029 #endif
18030 extern maygc object check_dfloat_replacement (object obj);
18031 #ifndef COMPILE_STANDALONE
18032 MAKE_CHECK_LOW(dfloat,double_float_p(obj))
18033 #endif
18034 /* is used by STREAM, FFI */
18035 %% exportF(object,check_c_integer_replacement,(object obj, int tcode, bool signedp));
18036 %% export_def(check_uint8_replacement(obj));
18037 %% puts("#ifndef COMPILE_STANDALONE");
18038 %% export_literal(MAKE_CHECK_(uint8));
18039 %% puts("#endif");
18040 %% export_def(check_sint8_replacement(obj));
18041 %% puts("#ifndef COMPILE_STANDALONE");
18042 %% export_literal(MAKE_CHECK_(sint8));
18043 %% puts("#endif");
18044 %% export_def(check_uint16_replacement(obj));
18045 %% puts("#ifndef COMPILE_STANDALONE");
18046 %% export_literal(MAKE_CHECK_(uint16));
18047 %% puts("#endif");
18048 %% export_def(check_sint16_replacement(obj));
18049 %% puts("#ifndef COMPILE_STANDALONE");
18050 %% export_literal(MAKE_CHECK_(sint16));
18051 %% puts("#endif");
18052 %% export_def(check_uint32_replacement(obj));
18053 %% puts("#ifndef COMPILE_STANDALONE");
18054 %% export_literal(MAKE_CHECK_(uint32));
18055 %% puts("#endif");
18056 %% export_def(check_sint32_replacement(obj));
18057 %% puts("#ifndef COMPILE_STANDALONE");
18058 %% export_literal(MAKE_CHECK_(sint32));
18059 %% puts("#endif");
18060 %% export_def(check_uint64_replacement(obj));
18061 %% puts("#ifndef COMPILE_STANDALONE");
18062 %% export_literal(MAKE_CHECK_(uint64));
18063 %% puts("#endif");
18064 %% export_def(check_sint64_replacement(obj));
18065 %% puts("#ifndef COMPILE_STANDALONE");
18066 %% export_literal(MAKE_CHECK_(sint64));
18067 %% puts("#endif");
18068 %% exportF(object,check_uint_replacement,(object obj));
18069 %% puts("#ifndef COMPILE_STANDALONE");
18070 %% export_literal(MAKE_CHECK_(uint));
18071 %% puts("#endif");
18072 %% exportF(object,check_sint_replacement,(object obj));
18073 %% puts("#ifndef COMPILE_STANDALONE");
18074 %% export_literal(MAKE_CHECK_(sint));
18075 %% puts("#endif");
18076 %% exportF(object,check_ulong_replacement,(object obj));
18077 %% puts("#ifndef COMPILE_STANDALONE");
18078 %% export_literal(MAKE_CHECK_(ulong));
18079 %% puts("#endif");
18080 %% exportF(object,check_slong_replacement,(object obj));
18081 %% puts("#ifndef COMPILE_STANDALONE");
18082 %% export_literal(MAKE_CHECK_(slong));
18083 %% puts("#endif");
18084 %% exportF(object,check_ffloat_replacement,(object obj));
18085 %% puts("#ifndef COMPILE_STANDALONE");
18086 %% export_literal(MAKE_CHECK_LOW(ffloat,single_float_p(obj)));
18087 %% puts("#endif");
18088 %% exportF(object,check_dfloat_replacement,(object obj));
18089 %% puts("#ifndef COMPILE_STANDALONE");
18090 %% export_literal(MAKE_CHECK_LOW(dfloat,double_float_p(obj)));
18091 %% puts("#endif");
18092
18093 /* ##################### PACKBIBL for PACKAGE.D ############################ */
18094
18095 /* UP: tests whether a symbol is accessible in a package and isn't hidden
18096 by a another symbol with the same name.
18097 accessiblep(sym,pack)
18098 > sym: Symbol
18099 > pack: Package
18100 < result: true if sym is accessible in pack and nod hidden,
18101 else false */
18102 extern bool accessiblep (object sym, object pack);
18103 /* is used by IO */
18104
18105 /* UP: tests whether a symbol is accessible as external symbol in a package
18106 externalp(sym,pack)
18107 > sym: Symbol
18108 > pack: Package
18109 < result: true if sym is accessible as external symbol in pack ,
18110 else false */
18111 extern bool externalp (object sym, object pack);
18112 /* is used by IO */
18113
18114 /* UP: locates an external symbol with a given printname in a package.
18115 find_external_symbol(string,invert,pack,&sym)
18116 > string: string
18117 > invert: whether to implicitly case-invert the string
18118 > pack: package
18119 < result: true, if an external symbol with that printname has been found in pack.
18120 < sym: this symbol, if found. */
18121 extern bool find_external_symbol (object string, bool invert, object pack, object* sym_);
18122 /* is used by IO */
18123
18124 /* UP: locates a package with a given name or nickname
18125 find_package(string)
18126 > string: String
18127 < result: Package with that name or NIL
18128 can trigger GC in threads builds */
18129 extern maygc object find_package (object string);
18130 /* is used by IO, EVAL */
18131 %% exportF(object,find_package,(object string));
18132
18133 /* UP: Interns a symbol with a given printname in a package.
18134 intern(string,invert,pack,&sym)
18135 > string: String
18136 > invert: whether to implicitly case-invert the string
18137 > pack: Package
18138 < sym: Symbol
18139 < result: 0, if not found but newly created
18140 1, if found as external symbol
18141 2, if inherited through use-list
18142 3, if exists as internal symbol
18143 can trigger GC */
18144 extern maygc uintBWL intern (object string, bool invert, object pack, object* sym_);
18145 /* is used by IO, SPVW */
18146 %% exportF(uintBWL,intern,(object string, object pack, object* sym_));
18147
18148 /* UP: Interns a symbol with a given printname in the Keyword-Package.
18149 intern_keyword(string)
18150 > string: String
18151 < result: Symbol, a keyword
18152 can trigger GC */
18153 extern maygc object intern_keyword (object string);
18154 /* is used by IO, EVAL, GRAPH */
18155 %% exportF(object,intern_keyword,(object string));
18156
18157 /* UP: Imports a symbol into a package
18158 import(&sym,&pack);
18159 > sym: Symbol (on STACK)
18160 > pack: Package (on STACK)
18161 < sym: Symbol, EQ with the old
18162 < pack: Package, EQ with the old
18163 can trigger GC */
18164 extern maygc void import (const gcv_object_t* sym_, const gcv_object_t* pack_);
18165 /* is used by SPVW */
18166
18167 /* UP: Exports a symbol from a package
18168 export(&sym,&pack);
18169 > sym: Symbol (on STACK)
18170 > pack: Package (on STACK)
18171 < sym: Symbol, EQ with the old
18172 < pack: Package, EQ with the old
18173 can trigger GC */
18174 extern maygc void export (const gcv_object_t* sym_, const gcv_object_t* pack_);
18175 /* is used by SPVW */
18176
18177 /* UP: gets the current package
18178 get_current_package()
18179 < result: current Package
18180 can trigger GC */
18181 extern maygc object get_current_package (void);
18182 /* is used by IO */
18183
18184 /* check whether package lock prevents assignment to symbol
18185 can trigger GC */
18186 extern maygc void symbol_value_check_lock (object caller, object symbol);
18187 /* used by EVAL */
18188
18189 /* UP: Initializes the package-management
18190 init_packages();
18191 can trigger GC */
18192 extern void init_packages (void);
18193 /* is used by SPVW */
18194
18195 /* ##################### PATHBIBL for PATHNAME.D ########################### */
18196
18197 /* return the file stream truename
18198 > s: file stream (open or closed) - no type check is done!
18199 < truename of the file associated with the stream
18200 can trigger GC
18201 for syscall module */
18202 extern maygc object file_stream_truename (object s);
18203 %% exportF(object,file_stream_truename,(object s));
18204
18205 /* Check that the namestring for path will be parsed into a similar object
18206 used by pr_orecord() in io.d
18207 can trigger GC */
18208 extern maygc bool namestring_correctly_parseable_p (gcv_object_t *path_);
18209
18210 /* Check whether the file exists
18211 > namestring : path
18212 > STACK_0 = FILE-ERROR slot PATHNAME
18213 < resolved : truename (if return is success, i.e., FILE or DIR)
18214 < fwd: file write date (if return is success and address is supplied)
18215 < fsize: file size (if return is success and address is supplied)
18216 < return : */
18217 typedef enum {
18218 FILE_KIND_FILE, /* regular file */
18219 FILE_KIND_DIR, /* directory */
18220 FILE_KIND_BAD, /* exists but cannot figure out what it is, check errno */
18221 FILE_KIND_NONE /* namestring does not name an existing file or directory */
18222 } file_kind_t;
18223 extern /*maygc*/ file_kind_t classify_namestring (const char* namestring, char *resolved, gcv_object_t *fwd, gcv_object_t* fsize);
18224 /* used by spvw_language:init_language */
18225
18226 /* Converts an object into an absolute physical pathname and returns its
18227 namestring.
18228 physical_namestring(thing)
18229 > thing: an object
18230 < result: the namestring of the pathname denoted by thing
18231 can trigger GC */
18232 extern maygc object physical_namestring (object thing);
18233 %% exportF(object,physical_namestring,(object obj));
18234
18235 /* Converts a directory pathname to an OS directory specification.
18236 > pathname: an object
18237 > use_default: whether to use the current default directory
18238 < result: a simple-bit-vector containing an ASCIZ string in OS format
18239 can trigger GC */
18240 extern maygc object pathname_to_OSdir (object pathname, bool use_default);
18241 /* used by modules (I18N) */
18242 %% exportF(object,pathname_to_OSdir,(object pathname, bool use_default));
18243
18244 /* Converts an OS directory specification to a directory pathname.
18245 > path: a pathname referring to a directory
18246 < result: a pathname without name and type
18247 can trigger GC */
18248 extern maygc object OSdir_to_pathname (const char* path);
18249 /* used by modules (I18N) */
18250 %% exportF(object,OSdir_to_pathname,(const char* path));
18251
18252 /* UP: Initializes the pathname-system.
18253 init_pathnames();
18254 can trigger GC */
18255 extern maygc void init_pathnames (void);
18256 /* is used by SPVW */
18257
18258 /* Duplicate an open file handle.
18259 handle_dup(oldfd)
18260 Similar to dup(oldfd), with error checking.
18261 To be called only inside begin/end_system_call(). */
18262 extern Handle handle_dup (Handle old_handle);
18263 %% exportF(Handle,handle_dup,(Handle old_handle));
18264
18265 /* Duplicate an open file handle.
18266 handle_dup2(oldfd,newfd)
18267 Similar to dup2(oldfd,newfd), with error checking. The result may or may not
18268 be equal to newfd.
18269 To be called only inside begin/end_system_call(). */
18270 extern Handle handle_dup2 (Handle old_handle, Handle new_handle);
18271 %% exportF(Handle,handle_dup2,(Handle old_handle, Handle new_handle));
18272
18273 /* Locates the executable program immediately after the program start.
18274 find_executable(argv[0]) */
18275 extern int find_executable (const char * program_name);
18276 /* is used by SPVW */
18277
18278 /* check the :DIRECTION argument
18279 return one of the following: */
18280 typedef enum {
18281 /* see READ_P, RO_P and WRITE_P in <stream.d> regarding the choice of values */
18282 DIRECTION_PROBE = 0,
18283 DIRECTION_INPUT = 1,
18284 DIRECTION_INPUT_IMMUTABLE = 3,
18285 DIRECTION_OUTPUT = 4,
18286 DIRECTION_IO = 5,
18287 /* Work around a g++-3.4.0 bug, see
18288 http://gcc.gnu.org/bugzilla/show_bug.cgi?id=15069 */
18289 DIRECTION_DUMMY_TO_AVOID_GXX_BUG = 100
18290 } direction_t;
18291 extern direction_t check_direction (object dir);
18292 %% printf("typedef enum { DIRECTION_PROBE=%d, DIRECTION_INPUT=%d, DIRECTION_INPUT_IMMUTABLE=%d, DIRECTION_OUTPUT=%d, DIRECTION_IO=%d} direction_t;\n",
18293 %% DIRECTION_PROBE, DIRECTION_INPUT, DIRECTION_INPUT_IMMUTABLE,
18294 %% DIRECTION_OUTPUT, DIRECTION_IO);
18295 %% exportF(direction_t,check_direction,(object dir));
18296
18297 /* check the :IF-DOES-NOT-EXIST argument
18298 check_if_does_not_exist(argument)
18299 return one of the following: */
18300 typedef enum {
18301 IF_DOES_NOT_EXIST_UNBOUND,
18302 IF_DOES_NOT_EXIST_ERROR,
18303 IF_DOES_NOT_EXIST_NIL,
18304 IF_DOES_NOT_EXIST_CREATE
18305 } if_does_not_exist_t;
18306 extern if_does_not_exist_t check_if_does_not_exist (object if_not_exist);
18307 %% emit_typedef("enum { IF_DOES_NOT_EXIST_UNBOUND, IF_DOES_NOT_EXIST_ERROR, IF_DOES_NOT_EXIST_NIL, IF_DOES_NOT_EXIST_CREATE }","if_does_not_exist_t");
18308 %% exportF(if_does_not_exist_t,check_if_does_not_exist,(object if_not_exist));
18309
18310 /* Converts a :IF-DOES-NOT-EXIST enum item to a symbol.
18311 if_does_not_exist_symbol(item) */
18312 extern object if_does_not_exist_symbol (if_does_not_exist_t if_not_exist);
18313 %% exportF(object,if_does_not_exist_symbol,(if_does_not_exist_t if_not_exist));
18314
18315 /* check the :IF-EXISTS argument
18316 check_if_exists(argument)
18317 return one of the following: */
18318 typedef enum {
18319 IF_EXISTS_UNBOUND,
18320 IF_EXISTS_ERROR,
18321 IF_EXISTS_NIL,
18322 IF_EXISTS_RENAME,
18323 IF_EXISTS_RENAME_AND_DELETE,
18324 IF_EXISTS_SUPERSEDE,
18325 IF_EXISTS_APPEND,
18326 IF_EXISTS_OVERWRITE
18327 } if_exists_t;
18328 extern if_exists_t check_if_exists (object if_exists);
18329 %% emit_typedef("enum { IF_EXISTS_UNBOUND, IF_EXISTS_ERROR, IF_EXISTS_NIL, IF_EXISTS_RENAME, IF_EXISTS_RENAME_AND_DELETE, IF_EXISTS_SUPERSEDE, IF_EXISTS_APPEND, IF_EXISTS_OVERWRITE }","if_exists_t");
18330 %% exportF(if_exists_t,check_if_exists,(object if_exists));
18331
18332 /* Converts a :IF-EXISTS enum item to a symbol.
18333 if_exists_symbol(item) */
18334 extern object if_exists_symbol (if_exists_t if_exists);
18335 %% exportF(object,if_exists_symbol,(if_exists_t if_exists));
18336
18337 #if defined(WIN32_NATIVE)
18338 /* ------------------- Functions defined in w32shell.c ------------------- */
18339
18340 /* shell_quote() - surround dangerous strings with double quotes.
18341 escape quotes and backslashes.
18342 dest should be twice as large as source
18343 + 2 (for quotes) + 1 for zero byte + 1 for possible endslash */
18344 extern int shell_quote (char * dest, const char * source);
18345 /* used by PATHNAME and the driver clisp.exe */
18346
18347 /* real_path() - the ultimate shortcut megaresolver
18348 style inspired by directory_search_scandir
18349 > namein: filename pointing to file or directory
18350 wildcards (only asterisk) may appear only as filename
18351 < nameout: filename with directory and file shortcuts resolved
18352 on failure holds filename resolved so far
18353 < result: true if resolving succeeded */
18354 extern BOOL real_path (LPCSTR namein, LPSTR nameout);
18355 /* used by PATHNAME, SPVW [for loadmem()] and the driver clisp.exe */
18356
18357 #endif
18358
18359 /* ##################### PREDBIBL for PREDTYPE.D ########################### */
18360
18361 /* UP: test for atomic equality EQL
18362 eql(obj1,obj2)
18363 > obj1,obj2: Lisp-objects
18364 < result: true, if objects are equal */
18365 extern bool eql (object obj1, object obj2);
18366 /* is used by CONTROL, EVAL, HASHTABL, LISPARIT */
18367 %% #if notused
18368 %% exportF(bool,eql,(object obj1, object obj2));
18369 %% #endif
18370
18371 /* UP: tests for equality EQUAL
18372 equal(obj1,obj2)
18373 > obj1,obj2: Lisp-objects
18374 < result: true, if objects are equal */
18375 extern bool equal (object obj1, object obj2);
18376 /* is used by EVAL, PATHNAME, HASHTABL, MISC */
18377 %% #if notused
18378 %% exportF(bool,equal,(object obj1, object obj2));
18379 %% #endif
18380
18381 /* UP: tests for a more lax equality EQUALP
18382 equalp(obj1,obj2)
18383 > obj1,obj2: Lisp-objects
18384 < result: true, if objects are equal */
18385 extern bool equalp (object obj1, object obj2);
18386 /* is used by PATHNAME, HASHTABL */
18387 %% #if notused
18388 %% exportF(bool,equalp,(object obj1, object obj2));
18389 %% #endif
18390
18391 /* typep_class(obj,clas)
18392 > obj: an object
18393 > clas: a class object
18394 < true if the object is an instance of the class, false otherwise
18395 clobbers value1, mv_count */
18396 extern bool typep_class (object obj, object clas);
18397 %% exportF(bool,typep_class,(object obj, object clazz));
18398
18399 /* typep_classname(obj,classname)
18400 > obj: an object
18401 > classname: a symbol expected to name a class with "proper name" classname
18402 < true if the object is an instance of the class, false otherwise
18403 clobbers value1, mv_count */
18404 extern bool typep_classname (object obj, object classname);
18405 %% exportF(bool,typep_classname,(object obj, object classname));
18406
18407 /* UP: expand all DEFTYPE definitions in the type spec
18408 (recursively, unless once_p is true)
18409 > type_spec: Lisp object
18410 < result: the expansion (when not a deftyped type, returns the argument)
18411 can trigger GC */
18412 extern maygc object expand_deftype (object type_spec, bool once_p);
18413 /* used by predtype.d, sequence.d */
18414
18415 /* UP: Makes a statistic about the action of a GC.
18416 with_gc_statistics(fun);
18417 > fun: Function that does a GC */
18418 typedef void gc_function_t (void);
18419 extern void with_gc_statistics (gc_function_t* fun);
18420 /* is used by SPVW */
18421
18422 /* ####################### RECBIBL for RECORD.D ############################ */
18423
18424 /* check_structure(obj)
18425 > obj: an object
18426 < result: a structure object, either the same as obj or a replacement
18427 can trigger GC */
18428 extern maygc object check_structure_replacement (object obj);
18429 #ifndef COMPILE_STANDALONE
check_structure(object obj)18430 static inline maygc object check_structure (object obj) {
18431 if (!structurep(obj))
18432 obj = check_structure_replacement(obj);
18433 return obj;
18434 }
18435 #endif
18436 /* used by IO */
18437
18438 /* instance_un_realloc(obj);
18439 walks over forward pointers left by instance reallocation (CHANGE-CLASS
18440 and/or redefined classes).
18441 > obj: a CLOS instance, possibly a forward pointer
18442 < obj: the same CLOS instance, not a forward pointer
18443 Note that the forwarded instance must not be leaked to "userland", because
18444 the forward pointer and the forwarded instance are not EQ. */
18445 #define instance_un_realloc(obj) \
18446 if (record_flags(TheInstance(obj)) & instflags_forwarded_B) { \
18447 (obj) = TheInstance(obj)->inst_class_version; \
18448 /* We know that there is at most one indirection. */ \
18449 ASSERT(!(record_flags(TheInstance(obj)) & instflags_forwarded_B)); \
18450 }
18451
18452 /* update_instance(user_obj,obj)
18453 updates a CLOS instance after its class or one of its superclasses has been
18454 redefined.
18455 > user_obj: a CLOS instance, possibly a forward pointer
18456 > obj: the same CLOS instance, not a forward pointer
18457 < result: the same CLOS instance, not a forward pointer
18458 can trigger GC */
18459 extern maygc object update_instance (object user_obj, object obj);
18460
18461 /* instance_valid_p(obj)
18462 Tests whether a CLOS instance can be used without first updating it.
18463 > obj: a CLOS instance, not a forward pointer
18464 < result: false if its class was redefined since the instance was last used */
18465 #define instance_valid_p(obj) \
18466 nullp(TheClassVersion(TheInstance(obj)->inst_class_version)->cv_next)
18467
18468 /* instance_update(user_obj,obj);
18469 performs necessary CLOS instance updates on obj.
18470 > user_obj: a CLOS instance, possibly a forward pointer
18471 > obj: the same CLOS instance, not a forward pointer
18472 < obj: the same CLOS instance, not a forward pointer
18473 can trigger GC */
18474 #define instance_update(user_obj,obj) \
18475 if (!instance_valid_p(obj)) \
18476 (obj) = update_instance(user_obj,obj); \
18477 GCTRIGGER1(obj)/*;*/
18478
18479 /* Test for CLOS instance of a given class
18480 > obj: a Lisp object
18481 > clas: a class that doesn't have obsolete instances */
18482 #ifndef COMPILE_STANDALONE
instanceof(object obj,object clas)18483 static inline bool instanceof (object obj, object clas) {
18484 if (!instancep(obj)) return false;
18485 var object obj_forwarded = obj;
18486 instance_un_realloc(obj_forwarded);
18487 /*instance_update(obj,obj_forwarded); - not needed since we don't access a slot */
18488 var object cv = TheInstance(obj_forwarded)->inst_class_version;
18489 var object objclas = TheClassVersion(cv)->cv_newest_class;
18490 return !eq(gethash(clas,TheClass(objclas)->all_superclasses,false),nullobj);
18491 }
18492 #endif
18493
18494 /* ###################### SEQBIBL for SEQUENCE.D ########################### */
18495
18496 /* UP: Converts an object into a sequence of a given type.
18497 coerce_sequence(obj, result_type, error_p)
18498 > obj: Object, should be a sequence
18499 > result_type: identifier (symbol) of the sequence-type
18500 > error_p: when result_type does not name a sequence:
18501 when true, signal an error; when false, return nullobj
18502 < value: Sequence of type result_type
18503 can trigger GC */
18504 extern maygc Values coerce_sequence (object sequence, object result_type,
18505 bool error_p);
18506 /* is used by PREDTYPE, EVAL */
18507
18508 /* UP: Traverses a sequence and calls a function for every element.
18509 map_sequence(obj,fun,arg);
18510 > obj: Object, should be a sequence
18511 > fun: Function, fun(arg,element) may trigger GC
18512 > arg: arbitrary given argument
18513 can trigger GC */
18514 typedef maygc void map_sequence_function_t (void* arg, object element);
18515 extern maygc void map_sequence (object obj, map_sequence_function_t* fun, void* arg);
18516 /* used by ARRAY, modules */
18517 /* do not use emit_typedef_f because g++ complains:
18518 error: invalid application of `sizeof' to a function type */
18519 %% puts("typedef void map_sequence_function_t (void* arg, object element);");
18520 %% exportF(void,map_sequence,(object obj, map_sequence_function_t* fun, void* arg));
18521
18522 /* ###################### STRMBIBL for STREAM.D ############################ */
18523
18524 /* Error message, if an argument isn't a stream:
18525 check_stream_replacement(obj);
18526 > obj: not a stream
18527 < obj: a stream
18528 can trigger GC */
18529 extern maygc object check_stream_replacement (object obj);
18530 #ifndef COMPILE_STANDALONE
check_stream(object obj)18531 static inline maygc object check_stream (object obj) {
18532 if (!streamp(obj))
18533 obj = check_stream_replacement(obj);
18534 return obj;
18535 }
18536 #endif
18537 /* is used by IO, STREAM, DEBUG */
18538
18539 /* parse timeout argument
18540 sec = posfixnum or (SEC . USEC) or (SEC USEC) or float or ratio or nil/unbound
18541 usec = posfixnum or nil/unbound
18542 can trigger GC */
18543 extern maygc struct timeval * sec_usec (object sec, object usec, struct timeval *tv);
18544 %% exportF(struct timeval *,sec_usec,(object sec, object usec, struct timeval *tv));
18545
18546 /* Convert C sec/usec (struct timeval et al) pair into Lisp number (of seconds)
18547 if abs_p is true, add UNIX_LISP_TIME_DIFF
18548 can trigger GC */
18549 #if defined(SIZEOF_STRUCT_TIMEVAL) && SIZEOF_STRUCT_TIMEVAL == 16
18550 global maygc object sec_usec_number (uint64 sec, uint64 usec, bool abs_p);
18551 #else
18552 global maygc object sec_usec_number (uint32 sec, uint32 usec, bool abs_p);
18553 #endif
18554 %% #if defined(SIZEOF_STRUCT_TIMEVAL) && SIZEOF_STRUCT_TIMEVAL == 16
18555 %% exportF(object,sec_usec_number,(uint64 sec, uint64 usec, bool abs_p));
18556 %% #else
18557 %% exportF(object,sec_usec_number,(uint32 sec, uint32 usec, bool abs_p));
18558 %% #endif
18559
18560 /* UP: Initializes the OS dependencies for streams.
18561 init_stream_osdeps(); */
18562 extern void init_stream_osdeps (void);
18563
18564 /* UP: Initializes the stream variables.
18565 init_streamvars(batch_p);
18566 > batch_p: Flag, whether *standard-input*, *standard-output*, *error-output*
18567 should be initialized to the C stdio handle-streams
18568 (deviates from the standard)
18569 can trigger GC */
18570 extern maygc void init_streamvars (bool batch_p);
18571 /* used by SPVW */
18572
18573 /* Error-message, if a stream-operation is not permitted on a stream.
18574 error_illegal_streamop(caller,stream);
18575 > caller: Caller (a symbol)
18576 > stream: Stream */
18577 extern _Noreturn void error_illegal_streamop (object caller, object stream);
18578 /* is used by IO */
18579
18580 /* Reads a byte from a stream.
18581 read_byte(stream)
18582 > stream: Stream
18583 < result: read Integer (eof_value at EOF)
18584 can trigger GC */
18585 extern maygc object read_byte (object stream);
18586 /* is used by SEQUENCE */
18587
18588 /* Writes a byte onto a stream.
18589 write_byte(stream,byte);
18590 > stream: Stream
18591 > byte: Integer to be written
18592 can trigger GC */
18593 extern maygc void write_byte(object stream, object byte);
18594 /* is used by SEQUENCE */
18595
18596 /* Reads a character from a stream.
18597 read_char(&stream)
18598 > stream: Stream
18599 < stream: Stream
18600 < result: read character (eof_value at EOF)
18601 can trigger GC */
18602 extern maygc object read_char (const gcv_object_t* stream_);
18603 /* is used by IO, DEBUG, SEQUENCE */
18604
18605 /* Pushes the last read character back onto a stream.
18606 unread_char(&stream,ch);
18607 > ch: last read character
18608 > stream: Stream
18609 < stream: Stream
18610 can trigger GC */
18611 extern maygc void unread_char (const gcv_object_t* stream_, object ch);
18612 /* is used by IO, DEBUG */
18613
18614 /* Reads a character from a stream without using it.
18615 peek_char(&stream)
18616 > stream: Stream
18617 < stream: Stream
18618 < result: read character (eof_value at EOF)
18619 can trigger GC */
18620 extern maygc object peek_char (const gcv_object_t* stream_);
18621 /* is used by IO */
18622
18623 /* Reads a line of characters from a stream.
18624 read_line(&stream,&buffer)
18625 > stream: stream
18626 > buffer: a semi-simple string
18627 < stream: stream
18628 < buffer: contains the read characters, excluding the terminating #\Newline
18629 < result: true is EOF was seen before newline, else false
18630 can trigger GC */
18631 extern maygc bool read_line (const gcv_object_t* stream_, const gcv_object_t* buffer_);
18632 /* used by IO */
18633
18634 /* Write a character onto a stream.
18635 write_char(&stream,ch);
18636 > ch: Character to be written
18637 > stream: Stream
18638 < stream: Stream
18639 can trigger GC */
18640 extern maygc void write_char (const gcv_object_t* stream_, object ch);
18641 /* is used by LISPARIT, IO, ERROR, SEQUENCE */
18642
18643 /* Writes a character onto a stream.
18644 write_code_char(&stream,ch);
18645 > ch: a character
18646 > stream: Stream
18647 < stream: Stream
18648 can trigger GC
18649 extern maygc void write_code_char (const gcv_object_t* stream_, chart ch); */
18650 #define write_code_char(stream_,ch) write_char(stream_,code_char(ch))
18651 /* is used by LISPARIT, IO */
18652
18653 /* Writes a fixed standard-char onto a stream.
18654 write_ascii_char(&stream,ch);
18655 > ch: a standard char, in ASCII encoding
18656 > stream: Stream
18657 < stream: Stream
18658 can trigger GC
18659 extern maygc void write_ascii_char (const gcv_object_t* stream_, uintB ch); */
18660 #define write_ascii_char(stream_,ch) write_char(stream_,code_char(as_chart(ch)))
18661 /* is used by LISPARIT, IO, DEBUG, Macro TERPRI */
18662
18663 #ifdef ENABLE_UNICODE
18664 /* Changes a terminal stream's external format.
18665 > stream: a stream
18666 > encoding: an encoding
18667 can trigger GC */
18668 extern maygc void set_terminalstream_external_format (object stream, object encoding);
18669 /* used by ENCODING */
18670 #endif
18671
18672 /* UP: Determines whether a stream is "interactive",
18673 ie. whether the input from the stream
18674 depends from a promt that has propably just been printed.
18675 interactive_stream_p(stream)
18676 > stream: Stream */
18677 extern bool interactive_stream_p (object stream);
18678 /* is used by DEBUG */
18679
18680 /* UP: Closes a stream.
18681 builtin_stream_close(&stream,abort);
18682 > stream: Builtin-Stream
18683 > abort: flag: non-0 => ignore errors
18684 < stream: Builtin-Stream
18685 can trigger GC */
18686 extern maygc void builtin_stream_close (const gcv_object_t* stream_, uintB abort);
18687 /* is used by PATHNAME, SPVW, DEBUG, MISC */
18688 %% exportF(void,builtin_stream_close,(const gcv_object_t* stream_, uintB abort));
18689
18690 /* UP: Closes a list of open files.
18691 close_some_files(list);
18692 > list: List of open builtin-streams
18693 can trigger GC */
18694 extern maygc void close_some_files (object list);
18695 /* is used by SPVW */
18696
18697 /* UP: Closes all open files.
18698 close_all_files();
18699 can trigger GC */
18700 extern maygc void close_all_files (void);
18701 /* is used by SPVW */
18702
18703 /* UP: declares all open file-streams closed.
18704 closed_all_files(); */
18705 extern void closed_all_files (void);
18706 /* is used by SPVW */
18707
18708 typedef enum {
18709 LISTEN_AVAIL, /* a character is available */
18710 LISTEN_EOF, /* EOF is reached */
18711 LISTEN_WAIT, /* no character is available, but not because of EOF */
18712 LISTEN_ERROR /* stream is broken, e.g., ECONNRESET */
18713 } listen_t;
18714
18715 /* UP: determines whether a char is available in the Stream stream
18716 listen_char(stream)
18717 > stream: Stream
18718 < result: input availability
18719 can trigger GC */
18720 extern maygc listen_t listen_char (object stream);
18721 /* is used by IO, DEBUG */
18722
18723 /* UP: clears an already entered interactive input from a Stream stream.
18724 clear_input(stream)
18725 > stream: Stream
18726 < result: true if input has been deleted
18727 can trigger GC */
18728 extern maygc bool clear_input (object stream);
18729 /* is used by IO, DEBUG */
18730
18731 /* UP: Determines whether a stream has a byte immediately available.
18732 listen_byte(stream)
18733 > stream: a stream with element-type ([UN]SIGNED-BYTE 8)
18734 < result: input availability
18735 can trigger GC */
18736 extern maygc listen_t listen_byte (object stream);
18737 /* is used by */
18738
18739 /* UP: Finishes waiting output of a Stream stream
18740 finish_output(stream);
18741 > stream: Stream
18742 can trigger GC */
18743 extern maygc void finish_output (object stream);
18744 /* is used by IO */
18745
18746 /* UP: Forces waiting output of a Stream stream
18747 force_output(stream);
18748 > stream: Stream
18749 can trigger GC */
18750 extern maygc void force_output (object stream);
18751 /* is used by IO, DEBUG */
18752
18753 /* UP: clear the waiting output of a stream.
18754 clear_output(stream);
18755 > stream: Stream
18756 can trigger GC */
18757 extern maygc void clear_output (object stream);
18758 /* is used by IO */
18759
18760 /* UP: Gives the line position of a stream:
18761 get_line_position(stream)
18762 > stream: Stream
18763 < result: Line-Position (Fixnum >=0 or NIL)
18764 can trigger GC */
18765 extern maygc object get_line_position (object stream);
18766 /* is used by IO, DEBUG */
18767
18768 /* Writes a newline on a stream, if it is not already positioned at column 0.
18769 fresh_line(&stream);
18770 > stream: Stream
18771 < stream: Stream
18772 < result: true if did output a newline
18773 can trigger GC */
18774 extern maygc bool fresh_line (const gcv_object_t* stream_);
18775 /* is used by IO */
18776
18777 /* Writes a newline on a stream, delayed and nullified if the next character
18778 written would be a newline anyway.
18779 elastic_newline(&stream);
18780 > stream: Stream
18781 < stream: Stream
18782 can trigger GC */
18783 extern maygc void elastic_newline (const gcv_object_t* stream_);
18784 /* is used by IO */
18785
18786 /* UP: give away corresponding underlying handle
18787 making sure buffers were flushed. One can then use the
18788 handle outside of stream object as far as the latter
18789 is not used and not GCed.
18790 stream_lend_handle(stream, inputp, handletype)
18791 > stream_: stream for handle to extract
18792 > inputp: whether its input or output side is requested.
18793 < stream_: corrected stream (if the original argument was not a handle stream)
18794 < int * handletype 0:reserved, 1:file, 2:socket
18795 < Handle result - extracted handle
18796 can trigger GC */
18797 extern maygc Handle stream_lend_handle (gcv_object_t *stream_, bool inputp, int * handletype);
18798 /* used by STREAM */
18799 %% exportF(Handle,stream_lend_handle,(gcv_object_t *stream_, bool inputp, int * handletype));
18800
18801 /* extract the OS file handle from the file stream
18802 > stream: open Lisp file stream
18803 < fd: OS file handle
18804 > permissive_p: return nullobj instead of signaling an error
18805 < result: either stream, or a corrected stream in case stream was invalid
18806 or nullobj if permissive_p was true and the stream was invalid
18807 for syscall module
18808 can trigger GC */
18809 extern maygc object open_file_stream_handle (object stream, Handle *fd, bool permissive_p);
18810 %% exportF(object,open_file_stream_handle,(object stream, Handle *fd, bool permissive_p));
18811
18812 /* return the OS's idea of the stream length for the file stream
18813 > stream: for error reporting
18814 > fd: OS file handle
18815 < result: the length of the stream
18816 should be wrapped in begin_system_call()/end_system_call()
18817 for gdbm module */
18818 extern maygc off_t handle_length (gcv_object_t *stream_, Handle fd);
18819 %% exportF(off_t,handle_length,(gcv_object_t *stream_, Handle fd));
18820
18821 /* Function: Reads several bytes from a stream.
18822 read_byte_array(&stream,&bytearray,start,len,persev)
18823 > stream: stream (on the STACK)
18824 > object bytearray: simple-8bit-vector (on the STACK)
18825 > uintL start: start index of byte sequence to be filled
18826 > uintL len: length of byte sequence to be filled
18827 > perseverance_t persev: how to react on incomplete I/O
18828 < uintL result: number of bytes that have been filled
18829 can trigger GC */
18830 extern maygc uintL read_byte_array (const gcv_object_t* stream_, const gcv_object_t* bytearray_, uintL start, uintL len, perseverance_t persev);
18831 /* used by SEQUENCE, PATHNAME */
18832 %% exportF(uintL,read_byte_array,(const gcv_object_t* stream_, const gcv_object_t* bytearray_, uintL start, uintL len, perseverance_t persev));
18833
18834 /* Function: Writes several bytes to a stream.
18835 write_byte_array(&stream,&bytearray,start,len,no_hang)
18836 > stream: Stream (on the STACK)
18837 > object bytearray: simple-8bit-vector (on the STACK)
18838 > uintL start: start index of byte sequence to be written
18839 > uintL len: length of byte sequence to be written
18840 > perseverance_t persev: how to react on incomplete I/O
18841 < uintL result: number of bytes that have been written
18842 can trigger GC */
18843 extern maygc uintL write_byte_array (const gcv_object_t* stream_, const gcv_object_t* bytearray_, uintL start, uintL len, perseverance_t persev);
18844 /* is used by SEQUENCE */
18845 %% exportF(uintL,write_byte_array,(const gcv_object_t* stream_, const gcv_object_t* bytearray_, uintL start, uintL len, perseverance_t persev));
18846
18847 /* Function: Reads several characters from a stream.
18848 read_char_array(&stream,&chararray,start,len)
18849 > stream: stream (on the STACK)
18850 > object chararray: a mutable string that is or was simple (on the STACK)
18851 > uintL start: start index of character sequence to be filled
18852 > uintL len: length of character sequence to be filled
18853 < uintL result: number of characters that have been filled
18854 can trigger GC */
18855 extern maygc uintL read_char_array (const gcv_object_t* stream_, const gcv_object_t* chararray_, uintL start, uintL len);
18856 /* is used by SEQUENCE */
18857
18858 /* Function: Writes several characters to a stream.
18859 write_char_array(&stream,&chararray,start,len)
18860 > stream: stream (on the STACK)
18861 > object chararray: not-reallocated simple-string (on the STACK)
18862 > uintL start: start index of character sequence to be written
18863 > uintL len: length of character sequence to be written
18864 can trigger GC */
18865 extern maygc void write_char_array (const gcv_object_t* stream_, const gcv_object_t* chararray_, uintL start, uintL len);
18866 /* is used by SEQUENCE */
18867
18868 /* UP: Gives the stream that is the value of a variable
18869 var_stream(sym,streamflags)
18870 > sym: Variable (symbol)
18871 > streamflags: Set of operations that should work on the stream
18872 < result: Stream */
18873 extern object var_stream (object sym, uintB streamflags);
18874 /* is used by IO, PACKAGE, ERROR, DEBUG, SPVW */
18875
18876 /* UP: makes a file-stream
18877 make_file_stream(direction,append_flag,handle_fresh)
18878 > STACK_5: Filename, a Pathname or NIL
18879 > STACK_4: Truename, a Pathname or NIL
18880 > STACK_3: :BUFFERED argument
18881 > STACK_2: :EXTERNAL-FORMAT argument
18882 > STACK_1: :ELEMENT-TYPE argument
18883 > STACK_0: Handle of the open file
18884 > direction: Mode (0 = :PROBE, 1 = :INPUT, 4 = :OUTPUT, 5 = :IO,
18885 3 = :INPUT-IMMUTABLE)
18886 > append_flag: true if the stream should immediately be positioned at the end
18887 ,else false
18888 > handle_fresh: whether the handle is freshly created.
18889 This means 1. that it is currently positioned at position 0,
18890 2. if (direction & bit(2)), it is opened for read/write, not
18891 only for write.
18892 If the handle refers to a regular file, this together means
18893 that it supports file_lseek, reading/repositioning/writing
18894 and close/reopen.
18895 If direction==5, handle_fresh must be true.
18896 < result: File-Stream (or evtl. File-Handle-Stream)
18897 < STACK: cleaned
18898 can trigger GC */
18899 extern maygc object make_file_stream (direction_t direction, bool append_flag, bool handle_at_pos_0);
18900 /* is used by PATHNAME */
18901 %% exportF(object,make_file_stream,(direction_t direction, bool append_flag,bool handle_fresh)/*+6 arguments on the STACK!*/);
18902
18903 /* check whether the object is a handle stream or a socket-server
18904 and return its socket-like handle(s) */
18905 extern void stream_handles (object obj, bool check_open, bool* char_p, SOCKET* in_sock, SOCKET* out_sock);
18906 %% exportF(void,stream_handles,(object obj, bool check_open, bool* char_p, SOCKET* in_sock, SOCKET* out_sock));
18907
18908 #ifdef PIPES
18909 /* mk_pipe_from_handle(pipe,process_id,dir)
18910 Make a PIPE-OUTPUT-STREAM from pipe handle and a process-id
18911 > STACK_0: buffered
18912 > STACK_1: element-type
18913 > STACK_2: encoding
18914 > pipe: input or output pipe, depending on direction
18915 > process_id: PID of the underlying process
18916 > direction: pipe stream direction
18917 < result - a PIPE-OUTPUT-STREAM
18918 Used in LAUNCH
18919 can trigger GC */
18920 extern maygc object mk_pipe_from_handle (Handle opipe, int process_id, direction_t direction);
18921 /* is used by PATHNAME */
18922 #endif
18923
18924 /* Makes a Broadcast-Stream using a Stream stream.
18925 make_broadcast1_stream(stream)
18926 can trigger GC */
18927 extern maygc object make_broadcast1_stream (object stream);
18928 /* is used by IO */
18929
18930 /* Makes a Two-Way-stream using an Input-Stream and an Output-Stream.
18931 make_twoway_stream(input_stream,output_stream)
18932 > input_stream : Input-Stream
18933 > output_stream : Output-Stream
18934 < result : Two-Way-Stream
18935 can trigger GC */
18936 extern maygc object make_twoway_stream (object input_stream, object output_stream);
18937 /* is used by SPVW */
18938
18939 /* Makes a string-output-stream.
18940 make_string_output_stream()
18941 can trigger GC */
18942 extern maygc object make_string_output_stream (void);
18943 /* is used by IO, EVAL, DEBUG, ERROR */
18944
18945 /* UP: Returns the collected contents of a String-Output-Stream.
18946 get_output_stream_string(&stream)
18947 > stream: String-Output-Stream
18948 < stream: emptied Stream
18949 < result: the aggregation, a Simple-String
18950 can trigger GC */
18951 extern maygc object get_output_stream_string (const gcv_object_t* stream_);
18952 /* is used by IO, EVAL, DEBUG, ERROR */
18953
18954 /* UP: Makes a pretty-printer help stream
18955 make_pphelp_stream()
18956 can trigger GC */
18957 extern maygc object make_pphelp_stream (void);
18958 /* is used by IO */
18959
18960 /* UP: Tells whether a stream is buffered.
18961 stream_isbuffered(stream)
18962 > stream: a channel or socket stream
18963 < result: bit(1) set if input side is buffered,
18964 bit(0) set if output side is buffered */
18965 extern uintB stream_isbuffered (object stream);
18966 /* is used by IO */
18967
18968 /* UP: Returns the current line number of a stream.
18969 stream_line_number(stream)
18970 > stream: a stream
18971 < result: an integer or NIL
18972 can trigger GC */
18973 extern maygc object stream_line_number (object stream);
18974 /* is used by IO */
18975
18976 /* Function: Returns the last character read (and not yet unread) from a stream.
18977 stream_get_lastchar(stream)
18978 > stream: a stream
18979 < result: the last character read, or NIL
18980 can trigger GC */
18981 extern maygc object stream_get_lastchar (object stream);
18982 /* is used by DEBUG */
18983
18984 /* Function: Returns true if a stream is a FAS stream.
18985 stream_get_fasl(stream)
18986 > stream: a stream
18987 < result: true if the stream is a FAS stream, else false */
18988 extern maygc bool stream_get_fasl (object stream);
18989 /* used by IO */
18990
18991 /* Function: Changes the FAS state of a stream.
18992 stream_set_fasl(stream,value);
18993 > stream: a stream
18994 > value: true if the stream should be a FAS stream, else false */
18995 extern maygc void stream_set_fasl (object stream, bool value);
18996 /* used by */
18997
18998 #if defined(UNIX)
18999 /* UP: return terminal to normal mode
19000 terminal_sane(); */
19001 extern void terminal_sane (void);
19002 /* is used by SPVW */
19003 #endif
19004
19005 #if defined(SCREEN)
19006 /* UP: reset terminal size on SIGWINCH */
19007 extern void resize_screen (int rows, int columns);
19008 #endif
19009
19010 /* Function: test whether a stream is a terminal stream. */
19011 extern bool terminal_stream_p(object stream);
19012
19013 /* check whether the charset is valid
19014 signal an error when code is invalid and charset is not nullobj
19015 return false otherwise */
19016 extern bool check_charset (const char * code, object charset);
19017 /* used in encoding.d */
19018
19019 /* ###################### SOCKBIBL for SOCKET.D ############################ */
19020
19021 #if defined(UNIX) || defined(WIN32_NATIVE)
19022 /* Convert the IP address from C format to Lisp
19023 > af: address family (AF_INET..)
19024 > addr: whatever the address is for this address family
19025 < lisp string representing the address in a human-readable format
19026 for syscalls & rawsock modules
19027 can trigger GC */
19028 extern maygc object addr_to_string (int af, const void *addr);
19029 #endif
19030 %% #if defined(UNIX) || defined(WIN32_NATIVE)
19031 %% exportF(object,addr_to_string,(int af, const void *addr));
19032 %% #endif
19033
19034 #if (defined(UNIX) || defined(WIN32_NATIVE)) && defined(HAVE_GETHOSTBYNAME)
19035 /* A wrapper around the connect() function.
19036 To be used inside begin/end_system_call() only. */
19037 extern int nonintr_connect (SOCKET fd, const struct sockaddr * name, int namelen);
19038 #endif
19039
19040 #if (defined(UNIX) || defined(WIN32_NATIVE)) && defined(HAVE_GETHOSTBYNAME) && defined(TCPCONN)
19041 /* Convert the IP address from C format to Lisp
19042 > name: FQDN or dotted quad or IPv6 address
19043 < lisp string for FQDN or byte vector for IPv[46] numerics
19044 for syscalls & rawsock modules
19045 can trigger GC */
19046 extern maygc object string_to_addr (const char* name);
19047 #endif
19048 %% #if (defined(UNIX) || defined(WIN32_NATIVE)) && defined(HAVE_GETHOSTBYNAME) && defined(TCPCONN)
19049 %% exportF(object,string_to_addr,(const char *name));
19050 %% #endif
19051
19052 #if (defined(UNIX) || defined(WIN32_NATIVE)) && defined(HAVE_GETHOSTBYNAME) && defined(TCPCONN)
19053 /* Return the hostent specified by the host designator
19054 > arg: host name designator:
19055 :DEFAULT - current host
19056 string/symbol: FQDN is resolved (gethostbyname)
19057 uint32: raw IPv4 address (gethostbyaddr)
19058 uint128: raw IPv6 address (gethostbyaddr)
19059 bit vector: raw IPv4[46] address (gethostbyaddr)
19060 < static hostent descriptor from LIBC
19061 for syscalls & rawsock modules */
19062 extern struct hostent* resolve_host (object arg);
19063 #endif
19064 %% #if (defined(UNIX) || defined(WIN32_NATIVE)) && defined(HAVE_GETHOSTBYNAME) && defined(TCPCONN)
19065 %% exportF(struct hostent*,resolve_host,(object arg));
19066 %% #endif
19067
19068 #if (defined(UNIX) || defined(WIN32_NATIVE)) && defined(HAVE_GETHOSTBYNAME)
19069 /* connect_to_x_server(host,display)
19070 Attempts to connect to server, given host name and display number.
19071 Returns file descriptor (network socket). Returns -1 and sets errno
19072 if connection fails.
19073 An empty hostname is interpreted as the most efficient local connection to
19074 a server on the same machine (usually a UNIX domain socket).
19075 hostname="unix" is interpreted as a UNIX domain connection.
19076 To be used inside begin/end_system_call() only. */
19077 extern SOCKET connect_to_x_server (const char* host, int display);
19078 #endif
19079
19080 #if (defined(UNIX) || defined(WIN32_NATIVE)) && defined(HAVE_GETHOSTBYNAME) && defined(SOCKET_STREAMS)
19081 /* socket_getlocalname(socket_handle,hd)
19082 Returns the IP name of the localhost for the given socket,
19083 or NULL in case of error.
19084 Fills all of *hd.
19085 To be used inside begin/end_system_call() only. */
19086 extern host_data_t * socket_getlocalname (SOCKET socket_handle, host_data_t * hd, bool resolve_p);
19087 #endif
19088
19089 #if (defined(UNIX) || defined(WIN32_NATIVE)) && defined(HAVE_GETHOSTBYNAME) && defined(SOCKET_STREAMS)
19090 /* socket_getpeername(socket_handle,hd)
19091 Returns the name of the host to which IP socket fd is connected,
19092 or NULL in case of error.
19093 Fills all of *hd.
19094 To be used inside begin/end_system_call() only. */
19095 extern host_data_t * socket_getpeername (SOCKET socket_handle, host_data_t * hd, bool resolve_p);
19096 #endif
19097
19098 #if (defined(UNIX) || defined(WIN32_NATIVE)) && defined(HAVE_GETHOSTBYNAME) && defined(SOCKET_STREAMS)
19099 /* Creates a socket to which other processes can connect. */
19100 extern SOCKET create_server_socket_by_socket (host_data_t *hd, SOCKET sock,
19101 unsigned int port, int backlog);
19102
19103 extern SOCKET create_server_socket_by_string (host_data_t *hd,
19104 const char *ip_interface,
19105 unsigned int port, int backlog);
19106 #endif
19107
19108 #if (defined(UNIX) || defined(WIN32_NATIVE)) && defined(HAVE_GETHOSTBYNAME) && defined(SOCKET_STREAMS)
19109 /* Waits for a connection from another process. */
19110 extern SOCKET accept_connection (SOCKET socket_handle);
19111 #endif
19112
19113 #if (defined(UNIX) || defined(WIN32_NATIVE)) && defined(HAVE_GETHOSTBYNAME) && defined(SOCKET_STREAMS)
19114 /* Creates a connection to a server (which must be waiting
19115 on the specified host and port).
19116 timeout may be NULL or a 'struct timeval *'. In the latter case,
19117 its value may be modified upon return, to indicate the time not slept. */
19118 extern SOCKET create_client_socket (const char* hostname, unsigned int port, struct timeval* timeout);
19119 #endif
19120
19121 /* ####################### SYMBIBL for SYMBOL.D ############################ */
19122
19123 /* UP: Returns the gobal definition of a symbol's function,
19124 and tests, whether the symbol is a global function.
19125 Symbol_function_checked(symbol)
19126 > symbol: symbol
19127 < result: the global definition of the function */
19128 extern object Symbol_function_checked (object symbol);
19129 /* is used by */
19130
19131 /* UP: gets a property from a symbol's property list.
19132 get(symbol,key)
19133 > symbol: a symbold
19134 > key: a key that is comparable with EQ
19135 < value: corresponding value from the property list of 'symbol', or unbound. */
19136 extern object get (object symbol, object key);
19137 /* is used by IO, CONTROL, EVAL, PREDTYPE, SEQUENCE */
19138 %% #if notused
19139 %% exportF(object,get,(object symbol, object key));
19140 %% #endif
19141
19142 /* ##################### ARITBIBL for LISTARIT.D ########################### */
19143
19144 /* check_real(obj)
19145 > obj: an object
19146 < result: a real number, either the same as obj or a replacement
19147 can trigger GC */
19148 extern maygc object check_real_replacement (object obj);
19149 #ifndef COMPILE_STANDALONE
check_real(object obj)19150 static inline maygc object check_real (object obj) {
19151 if_realp(obj, ; , { obj = check_real_replacement(obj); });
19152 return obj;
19153 }
19154 #endif
19155 /* used by IO */
19156
19157 /* UP: Initializes the arithmetics.
19158 init_arith();
19159 can trigger GC */
19160 extern maygc void init_arith (void);
19161 /* is used by SPVW */
19162
19163 /* Converts a longword into an Integer.
19164 L_to_I(val)
19165 > val: value of the Integer, a signed 32-Bit-Integer.
19166 < result: Integer with that value.
19167 can trigger GC */
19168 extern maygc object L_to_I (sint32 val);
19169 /* used by TIME */
19170 %% exportF(object,L_to_I,(sint32 val));
19171
19172 /* Converts an unsigned longword into an Integer >=0.
19173 UL_to_I(val)
19174 > val: value of the Integer, an unsigned 32-bit-Integer.
19175 < result: Integer with that value.
19176 can trigger GC */
19177 #if (intLsize<=oint_data_len)
19178 #ifdef DEBUG_GCSAFETY
UL_to_I(uintL val)19179 static inline maygc object UL_to_I (uintL val) { return fixnum(val); }
19180 #else
19181 #define UL_to_I(val) fixnum((uintL)(val))
19182 #endif
19183 #else
19184 extern maygc object UL_to_I (uintL val);
19185 #endif
19186 /* is used by MISC, TIME, STREAM, PATHNAME, HASHTABL, SPVW, ARRAY */
19187 %% #if (intLsize<=oint_data_len)
19188 %% #ifdef DEBUG_GCSAFETY
19189 %% puts("static inline object UL_to_I (uintL val) { return fixnum(val); }");
19190 %% #else
19191 %% export_def(UL_to_I(val));
19192 %% #endif
19193 %% #else
19194 %% exportF(object,UL_to_I,(uintL val));
19195 %% #endif
19196
19197 /* converts a double-longword into an Integer.
19198 L2_to_I(val_hi,val_lo)
19199 > val_hi|val_lo: value of the Integer, an signed 64-bit-Integer.
19200 < result: Integer with that value.
19201 can trigger GC */
19202 #if (intVsize>32)
19203 #define L2_to_I(val_hi,val_lo) \
19204 Q_to_I(((sint64)(sint32)(val_hi)<<32)|(sint64)(uint32)(val_lo))
19205 #else
19206 extern maygc object L2_to_I (sint32 val_hi, uint32 val_lo);
19207 #endif
19208 /* is used by TIME, FOREIGN */
19209 %% #if (intVsize>32)
19210 %% export_def(L2_to_I(val_hi,val_lo));
19211 %% #else
19212 %% exportF(object,L2_to_I,(sint32 val_hi, uint32 val_lo));
19213 %% #endif
19214
19215 /* Converts an unsigned double-longword into an Integer.
19216 UL2_to_I(val_hi,val_lo)
19217 > val_hi|val_lo: value of the Integer, an unsigned 64-bit-Integer.
19218 < result: Integer with that value.
19219 can trigger GC */
19220 #if (intVsize>32)
19221 #define UL2_to_I(val_hi,val_lo) \
19222 UQ_to_I(((uint64)(uint32)(val_hi)<<32)|(uint64)(uint32)(val_lo))
19223 #else
19224 extern maygc object UL2_to_I (uint32 val_hi, uint32 val_lo);
19225 #endif
19226 /* is used by TIME, FOREIGN, and by the FFI */
19227 %% #if (intVsize>32)
19228 %% export_def(UL2_to_I(val_hi,val_lo));
19229 %% #else
19230 %% exportF(object,UL2_to_I,(uint32 val_hi, uint32 val_lo));
19231 %% #endif
19232
19233 #if defined(intQsize) || (intVsize>32)
19234 /* Converts a quadword into an Integer.
19235 Q_to_I(val)
19236 > val: value of the Integer, a signed 64-bit-Integer.
19237 < result: Integer with that value
19238 can trigger GC */
19239 extern maygc object Q_to_I (sint64 val);
19240 /* is used by the FFI */
19241 #endif
19242 %% #if defined(intQsize) || (intVsize>32)
19243 %% exportF(object,Q_to_I,(sint64 val));
19244 %% #endif
19245
19246 #if defined(intQsize) || (intVsize>32) || defined(WIDE_HARD) || (SIZEOF_OFF_T > 4) || (SIZEOF_INO_T > 4)
19247 /* Converts an unsigned quadword into an Integer >=0.
19248 UQ_to_I(val)
19249 > val: value of the Integer, an unsigned 64-bit-Integer.
19250 < result: Integer with that value
19251 can trigger GC */
19252 extern maygc object UQ_to_I (uint64 val);
19253 /* is used by MISC, TIME, FFI */
19254 #endif
19255 %% #if defined(intQsize) || (intVsize>32)
19256 %% exportF(object,UQ_to_I,(uint64 val));
19257 %% #endif
19258
19259 /* Converts a sintV into an Integer.
19260 V_to_I(val)
19261 > val: value of the Integer, a signed intVsize-bit-Integer.
19262 < result: Integer with that value
19263 can trigger GC
19264 extern maygc object V_to_I (uintV val); */
19265 #if (intVsize<=32)
19266 #define V_to_I(val) L_to_I(val)
19267 #else
19268 #define V_to_I(val) Q_to_I(val)
19269 #endif
19270 /* is used by LISPARIT */
19271 %% #if notused
19272 %% #if (intVsize<=32)
19273 %% emit_define("V_to_I(val)","L_to_I(val)");
19274 %% #else
19275 %% emit_define("V_to_I(val)","Q_to_I(val)");
19276 %% #endif
19277 %% #endif
19278
19279 /* Converts an uintV into an Integer >=0.
19280 UV_to_I(val)
19281 > val: value of the Integer, an unsigned intVsize-bit-Integer.
19282 < result: Integer with that value
19283 can trigger GC
19284 extern maygc object UV_to_I (uintV val); */
19285 #if (intVsize<=32)
19286 #define UV_to_I(val) UL_to_I(val)
19287 #else
19288 #define UV_to_I(val) UQ_to_I(val)
19289 #endif
19290 /* is used by LISPARIT */
19291 %% #if notused
19292 %% #if (intVsize<=32)
19293 %% emit_define("UV_to_I(val)","UL_to_I(val)");
19294 %% #else
19295 %% emit_define("UV_to_I(val)","UQ_to_I(val)");
19296 %% #endif
19297 %% #endif
19298
19299 /* Converts a C-Integer of a given type into an Integer
19300 val should be a variable */
19301 #define uint8_to_I(val) fixnum((uint8)(val))
19302 #define sint8_to_I(val) L_to_I((sint32)(sint8)(val))
19303 #define uint16_to_I(val) fixnum((uint16)(val))
19304 #define sint16_to_I(val) L_to_I((sint32)(sint16)(val))
19305 #define uint32_to_I(val) UL_to_I((uint32)(val))
19306 #define sint32_to_I(val) L_to_I((sint32)(val))
19307 #if defined(intQsize) || (intVsize>32)
19308 #define uint64_to_I(val) UQ_to_I((uint64)(val))
19309 #define sint64_to_I(val) Q_to_I((sint64)(val))
19310 #else
19311 #define uint64_to_I(val) UL2_to_I((uint32)((val)>>32),(uint32)(val))
19312 #define sint64_to_I(val) L2_to_I((sint32)((val)>>32),(uint32)(val))
19313 #endif
19314 #if (int_bitsize==16)
19315 #define uint_to_I(val) uint16_to_I(val)
19316 #define sint_to_I(val) sint16_to_I(val)
19317 #else /* (int_bitsize==32) */
19318 #define uint_to_I(val) uint32_to_I(val)
19319 #define sint_to_I(val) sint32_to_I(val)
19320 #endif
19321 #if (long_bitsize==32)
19322 #define ulong_to_I(val) uint32_to_I(val)
19323 #define slong_to_I(val) sint32_to_I(val)
19324 #else /* (long_bitsize==64) */
19325 #define ulong_to_I(val) uint64_to_I(val)
19326 #define slong_to_I(val) sint64_to_I(val)
19327 #endif
19328 /* is used by MISC, for FFI */
19329 %% export_def(uint8_to_I(val));
19330 %% export_def(sint8_to_I(val));
19331 %% export_def(uint16_to_I(val));
19332 %% export_def(sint16_to_I(val));
19333 %% export_def(uint32_to_I(val));
19334 %% export_def(sint32_to_I(val));
19335 %% export_def(uint64_to_I(val));
19336 %% export_def(sint64_to_I(val));
19337 %% export_def(uint_to_I(val));
19338 %% export_def(sint_to_I(val));
19339 %% export_def(ulong_to_I(val));
19340 %% export_def(slong_to_I(val));
19341
19342 /* Converts a uintM integer into an Integer. */
19343 #if intMsize <= intLsize
19344 #define uintM_to_I(val) UL_to_I(val)
19345 #else
19346 #define uintM_to_I(val) UQ_to_I(val)
19347 #endif
19348
19349 /* Converts a sintM integer into an Integer. */
19350 #if intMsize <= intLsize
19351 #define sintM_to_I(val) L_to_I(val)
19352 #else
19353 #define sintM_to_I(val) Q_to_I(val)
19354 #endif
19355
19356 /* converts off_t to an Integer */
19357 #if defined(WIN32_NATIVE)
19358 #define off_to_I(val) L2_to_I((sint32)((val)>>32),(uint32)(val))
19359 #elif SIZEOF_OFF_T > 4
19360 #define off_to_I sint64_to_I
19361 #else
19362 #define off_to_I sint32_to_I
19363 #endif
19364
19365 /* Converts an Integer >=0 into an unsigned longword.
19366 I_to_UL(obj)
19367 > obj: an object, should be an Integer >=0, <2^32
19368 < result: the Integer's value as unsigned longword */
19369 extern uintL I_to_UL (object obj);
19370 /* is used by TIME, ARRAY */
19371 %% exportF(uintL,I_to_UL,(object obj));
19372
19373 /* Converts an Integer into a signed longword
19374 I_to_L(obj)
19375 > obj: an object, should be an Integer >=-2^31, <2^31
19376 < result: the Integer's value as signed longword */
19377 extern sintL I_to_L (object obj);
19378 /* is used by */
19379 %% exportF(sintL,I_to_L,(object obj));
19380
19381 #if defined(HAVE_LONG_LONG_INT)
19382 /* Converts an Integer >=0 into an unsigned quadword.
19383 I_to_UQ(obj)
19384 > obj: an object, should be an Integer >=0, <2^64
19385 < result: the Integer's vaulue as unsigned quadword */
19386 extern uint64 I_to_UQ (object obj);
19387 /* used by FOREIGN, for FFI, and by modules */
19388 #endif
19389 %% #ifdef HAVE_LONG_LONG_INT
19390 %% exportF(uint64,I_to_UQ,(object obj));
19391 %% #endif
19392
19393 #if defined(HAVE_LONG_LONG_INT)
19394 /* Converts an Integer into a signed quadword.
19395 I_to_Q(obj)
19396 > obj: an object, should be an Integer >=-2^63, <2^63
19397 < result: the Integer's value as quadword. */
19398 extern sint64 I_to_Q (object obj);
19399 /* used by FOREIGN, for FFI, and by modules */
19400 #endif
19401 %% #ifdef HAVE_LONG_LONG_INT
19402 %% exportF(sint64,I_to_Q,(object obj));
19403 %% #endif
19404
19405 /* Converts an Integer into a C-Integer of a given type.
19406 I_to_xintyy(obj) assumes that xintyy_p(obj) has already been checked. */
19407 #define I_to_uint8(obj) (uint8)(as_oint(obj) >> oint_data_shift)
19408 #define I_to_sint8(obj) (sint8)(as_oint(obj) >> oint_data_shift)
19409 #define I_to_uint16(obj) (uint16)(as_oint(obj) >> oint_data_shift)
19410 #define I_to_sint16(obj) (sint16)(as_oint(obj) >> oint_data_shift)
19411 #if (oint_data_len>=32)
19412 #define I_to_uint32(obj) (uint32)(as_oint(obj) >> oint_data_shift)
19413 #else
19414 #define I_to_uint32(obj) I_to_UL(obj)
19415 #endif
19416 #if (oint_data_len>=31)
19417 #define I_to_sint32(obj) (sint32)(as_oint(obj) >> oint_data_shift)
19418 #else
19419 #define I_to_sint32(obj) I_to_L(obj)
19420 #endif
19421 #ifdef HAVE_LONG_LONG_INT
19422 #define I_to_uint64(obj) I_to_UQ(obj)
19423 #define I_to_sint64(obj) I_to_Q(obj)
19424 #endif
19425 #if (int_bitsize==16)
19426 #define I_to_uint I_to_uint16
19427 #define I_to_sint I_to_sint16
19428 #else /* (int_bitsize==32) */
19429 #define I_to_uint I_to_uint32
19430 #define I_to_sint I_to_sint32
19431 #endif
19432 /* always: long_bitsize > oint_data_len ==> I_to_Xlong checks its argument */
19433 #if (long_bitsize==32)
19434 #define I_to_ulong I_to_uint32
19435 #define I_to_slong I_to_sint32
19436 #else /* (long_bitsize==64) */
19437 #define I_to_ulong I_to_uint64
19438 #define I_to_slong I_to_sint64
19439 #endif
19440 /* used by FFI, STREAM, modules */
19441 %% export_def(I_to_uint8(obj));
19442 %% export_def(I_to_sint8(obj));
19443 %% export_def(I_to_uint16(obj));
19444 %% export_def(I_to_sint16(obj));
19445 %% export_def(I_to_uint32(obj));
19446 %% export_def(I_to_sint32(obj));
19447 %% export_def(I_to_uint64(obj));
19448 %% export_def(I_to_sint64(obj));
19449 %% export_def(I_to_uint);
19450 %% export_def(I_to_sint);
19451 %% export_def(I_to_ulong);
19452 %% export_def(I_to_slong);
19453
19454 /* Unsigned Digit Sequence to Integer
19455 UDS_to_I(MSDptr,len)
19456 convert UDS MSDptr/len/.. into Integer >=0 .
19457 MSDptr[0] is the most significant digit, MSDptr[len-1] the least significant.
19458 there must be room for 1 digit below of MSDptr.
19459 can trigger GC */
19460 extern maygc object UDS_to_I (uintD* MSDptr, uintC len);
19461 /* is used by modules */
19462 %% exportF(object,UDS_to_I,(uintD* MSDptr, uintC len));
19463
19464 /* Digit Sequence to Integer
19465 DS_to_I(MSDptr,len)
19466 convert DS MSDptr/len/.. into Integer.
19467 MSDptr[0] is the most significant digit, MSDptr[len-1] the least significant.
19468 can trigger GC */
19469 extern maygc object DS_to_I (const uintD* MSDptr, uintC len);
19470 /* is used by modules */
19471 %% exportF(object,DS_to_I,(const uintD* MSDptr, uintC len));
19472
19473 /* I_I_comp(x,y) compares two Integers x and y.
19474 Result: 0 if x=y, +1 if x>y, -1 if x<y. */
19475 extern signean I_I_comp (object x, object y);
19476 /* is used by SEQUENCE */
19477
19478 /* (1+ x), where x is an Integer. Result Integer.
19479 I_1_plus_I(x)
19480 can trigger GC */
19481 extern maygc object I_1_plus_I (object x);
19482 /* is used by SEQUENCE, SPVW, SYMBOL */
19483 %% #if notused
19484 %% exportF(object,I_1_plus_I,(object x));
19485 %% #endif
19486
19487 /* (1- x), where x is an Integer. Result Integer.
19488 I_minus1_plus_I(x)
19489 can trigger GC */
19490 extern maygc object I_minus1_plus_I (object x);
19491 /* is used by SEQUENCE */
19492 %% #if notused
19493 %% exportF(object,I_minus1_plus_I,(object x));
19494 %% #endif
19495
19496 /* (+ x y), where x and y are Integers. Result Integer.
19497 I_I_plus_I(x,y)
19498 can trigger GC */
19499 extern maygc object I_I_plus_I (object x, object y);
19500 /* is used by SEQUENCE */
19501 %% #if notused
19502 %% exportF(object,I_I_plus_I,(object x, object y));
19503 %% #endif
19504
19505 /* (- x y), where x and y are Integers. Result Integer.
19506 I_I_minus_I(x,y)
19507 can trigger GC */
19508 extern maygc object I_I_minus_I (object x, object y);
19509 /* is used by SEQUENCE */
19510 %% #if notused
19511 %% exportF(object,I_I_minus_I,(object x, object y));
19512 %% #endif
19513
19514 /* (ASH x y), where x and y are Integers. Result Integer.
19515 I_I_ash_I(x,y)
19516 can trigger GC */
19517 extern maygc object I_I_ash_I (object x, object y);
19518 /* is used by SEQUENCE */
19519
19520 /* (INTEGER-LENGTH x), where x is an Integer. Result uintL.
19521 I_integer_length(x) */
19522 extern uintL I_integer_length (object x);
19523 /* is used by ARRAY */
19524 %% exportF(uintL,I_integer_length,(object x));
19525
19526 /* Converts a little-endian byte sequence to an unsigned integer.
19527 > bytesize: number of given 8-bit bytes of the integer,
19528 < intDsize/8*uintWC_max
19529 > bufferptr: address of bytesize bytes in GC-invariant memory
19530 < result: an integer >= 0 with I_integer_length(result) <= 8*bytesize
19531 can trigger GC */
19532 extern maygc object LEbytes_to_UI (uintL bytesize, const uintB* bufferptr);
19533 %% exportF(object,LEbytes_to_UI,(uintL bytesize, const uintB* bufferptr));
19534
19535 /* Converts a little-endian byte sequence to an unsigned integer.
19536 > bytesize: number of given 8-bit bytes of the integer,
19537 < intDsize/8*uintWC_max
19538 > *buffer_: address of a simple-8bit-vector (or of a fake)
19539 containing bytesize bytes of memory
19540 < result: an integer >= 0 with I_integer_length(result) <= 8*bytesize
19541 can trigger GC */
19542 extern maygc object LESbvector_to_UI (uintL bytesize, const gcv_object_t* buffer_);
19543 /* is used by STREAM */
19544
19545 /* Converts a little-endian byte sequence to an integer.
19546 > bytesize: number of given 8-bit bytes of the integer, > 0,
19547 < intDsize/8*uintWC_max
19548 > bufferptr: address of bytesize bytes in GC-invariant memory
19549 < result: an integer with I_integer_length(result) < 8*bytesize
19550 can trigger GC */
19551 extern maygc object LEbytes_to_I (uintL bytesize, const uintB* bufferptr);
19552 %% exportF(object,LEbytes_to_I,(uintL bytesize, const uintB* bufferptr));
19553
19554 /* Converts a little-endian byte sequence to an integer.
19555 > bytesize: number of given 8-bit bytes of the integer, > 0,
19556 < intDsize/8*uintWC_max
19557 > *buffer_: address of a simple-8bit-vector (or of a fake)
19558 containing bytesize bytes of memory
19559 < result: an integer with I_integer_length(result) < 8*bytesize
19560 can trigger GC */
19561 extern maygc object LESbvector_to_I (uintL bytesize, const gcv_object_t* buffer_);
19562 /* is used by STREAM */
19563
19564 /* Converts an unsigned integer to a little-endian byte sequence.
19565 > obj: an integer
19566 > bitsize: maximum number of bits of the integer
19567 > bufferptr: pointer to bytesize = ceiling(bitsize,8) bytes of memory
19568 < false and bufferptr[0..bytesize-1] filled, if obj >= 0 and
19569 I_integer_length(obj) <= bitsize;
19570 true, if obj is out of range */
19571 extern bool UI_to_LEbytes (object obj, uintL bitsize, uintB* bufferptr);
19572 /* is used by STREAM */
19573 %% exportF(bool,UI_to_LEbytes,(object obj, uintL bitsize, uintB* bufferptr));
19574
19575 /* Converts an integer to a little-endian byte sequence.
19576 > obj: an integer
19577 > bitsize: maximum number of bits of the integer, including the sign bit
19578 > bufferptr: pointer to bytesize = ceiling(bitsize,8) bytes of memory
19579 < false and bufferptr[0..bytesize-1] filled, if I_integer_length(obj) < bitsize;
19580 true, if obj is out of range */
19581 extern bool I_to_LEbytes (object obj, uintL bitsize, uintB* bufferptr);
19582 /* is used by STREAM */
19583 %% exportF(bool,I_to_LEbytes,(object obj, uintL bitsize, uintB* bufferptr));
19584
19585 /* c_float_to_FF(&val) converts an IEEE-single-float val into an single-float.
19586 can trigger GC */
19587 extern maygc object c_float_to_FF (const ffloatjanus* val_);
19588 %% exportF(object,c_float_to_FF,(const ffloatjanus* val_));
19589
19590 /* FF_to_c_float(obj,&val);
19591 converts single-float obj into an IEEE-single-float val. */
19592 extern void FF_to_c_float (object obj, ffloatjanus* val_);
19593 %% exportF(void,FF_to_c_float,(object obj, ffloatjanus* val_));
19594
19595 /* c_double_to_DF(&val) converts an IEEE-double-float val into a double-float.
19596 can trigger GC */
19597 extern maygc object c_double_to_DF (const dfloatjanus* val_);
19598 %% exportF(object,c_double_to_DF,(const dfloatjanus* val_));
19599
19600 /* DF_to_c_double(obj,&val);
19601 converts a double-float obj into an IEEE-double-float val. */
19602 extern void DF_to_c_double (object obj, dfloatjanus* val_);
19603 %% exportF(void,DF_to_c_double,(object obj, dfloatjanus* val_));
19604
19605 /* hash-code of a Long-Float: mixture of exponent, length, first 32 bits */
19606 extern uint32 hashcode_lfloat (object obj);
19607
19608 /* (complex x (float 0 x)) */
19609 extern object F_complex_C (object x);
19610
19611 /* UP: turns a string with Integer syntax into an Integer number
19612 Points will be ignored
19613 read_integer(base,sign,string,index1,index2)
19614 > base: read base(>=2, <=36)
19615 > sign: sign (/=0 if negative)
19616 > string: simple-string (contains digits with values
19617 <base and eventually a point)
19618 > index1: Index of the first digit
19619 > index2: Index after the last digit
19620 (thus index2-index1 digits, incl. a decimal point that can be at the end)
19621 < result: Integer
19622 can trigger GC */
19623 extern maygc object read_integer (uintWL base, signean sign, object string, uintL index1, uintL index2);
19624 /* is used by IO */
19625
19626 /* UP: turns a string with rational syntax into a rational number
19627 read_rational(base,sign,string,index1,index3,index2)
19628 > base: read base (>=2, <=36)
19629 > sign: sign (/=0 if negative)
19630 > string: Normal-Simple-String (contains digits with values
19631 <base and fraction bar)
19632 > index1: Index of the first digit
19633 > index3: Index of '/'
19634 > index2: Index after the last digit
19635 (thus index3-index1 digits of the numerator,
19636 index2-index3-1 digits of the denominator)
19637 < result: rational number
19638 can trigger GC */
19639 extern maygc object read_rational (uintWL base, signean sign, object string, uintL index1, uintL index3, uintL index2);
19640 /* is used by IO */
19641
19642 /* UP: turns a string with float-syntax into a float
19643 read_float(base,sign,string,index1,index4,index2,index3)
19644 > base: read base (=10)
19645 > sign: Sign (/=0 if negative)
19646 > string: normal-simple-string (contains digits and eventually
19647 point and exponent marker)
19648 > index1: Index of the beginning of the mantissa (without sign)
19649 > index4: Index after the end of the mantissa
19650 > index2: Index at the end of the character
19651 > index3: Index after the decimal point (=index4 if there is none)
19652 (thus mantissa with index4-index1 characters: digits and max. 1 '.')
19653 (thus index4-index3 digits after the decimal point)
19654 (thus at index4<index2: index4 = index of the exponent marker,
19655 index4+1 = index of the exponent's sign or the first digit
19656 of the exponent)
19657 < result: Float
19658 can trigger GC */
19659 extern maygc object read_float (uintWL base, signean sign, object string, uintL index1, uintL index4, uintL index2, uintL index3);
19660 /* is used by IO */
19661
19662 /* UP: prints an Integer
19663 print_integer(z,base,&stream);
19664 > z: Integer
19665 > base: base (>=2, <=36)
19666 > stream: Stream
19667 < stream: Stream
19668 can trigger GC */
19669 extern maygc void print_integer (object z, uintWL base, const gcv_object_t* stream_);
19670 /* is used by IO */
19671
19672 /* UP: prints a float
19673 print_float(z,&stream);
19674 > z: Float
19675 > stream: Stream
19676 < stream: Stream
19677 can trigger GC */
19678 extern maygc void print_float (object z, const gcv_object_t* stream_);
19679 /* is used by IO */
19680
19681 /* UP: Multiply an Integer by 10 and add another digit
19682 mult_10_plus_x(y,x)
19683 > y: Integer Y (>=0)
19684 > x: digit value X (>=0,<10)
19685 < result: Integer Y*10+X (>=0)
19686 can trigger GC */
19687 extern maygc object mult_10_plus_x (object y, uintB x);
19688 /* is used by IO */
19689
19690 /* UP: decides whether two numbers are equal
19691 number_equal(x,y)
19692 > x,y: two numbers
19693 < result: true, if (= x y) holds */
19694 extern bool number_equal (object x, object y);
19695 /* is used by PREDTYPE */
19696
19697 /* UP: Converts an object into a float of a given type
19698 coerce_float(obj,type)
19699 > obj: Object
19700 > type: one of the symbols
19701 FLOAT, SHORT-FLOAT, SINGLE-FLOAT, DOUBLE-FLOAT, LONG-FLOAT
19702 < result: (coerce obj type)
19703 can trigger GC */
19704 extern maygc object coerce_float (object obj, object type);
19705 /* is used by PREDTYPE, FOREIGN */
19706
19707 /* Converts a function's argument to a C 'double'.
19708 to_double(obj)
19709 > obj: an object, usually a real number
19710 < result: its value as a C 'double'
19711 can trigger GC */
19712 extern maygc double to_double (object x);
19713 %% exportF(double,to_double,(object obj));
19714
19715 /* Converts a function's argument to a C 'int'.
19716 to_int(obj)
19717 > obj: an object, usually an integer
19718 < result: its value as a C 'int'
19719 can trigger GC */
19720 extern maygc int to_int (object x);
19721 %% exportF(int,to_int,(object obj));
19722
19723 /* UP: Returns the decimal string representation of an integer >= 0.
19724 decimal_string(x)
19725 > object x: an integer >= 0
19726 < object result: a normal-simple-string containing the digits
19727 can trigger GC */
19728 extern maygc object decimal_string (object x);
19729 /* is used by PATHNAME */
19730
19731 /* ###################### FOREIGNBIBL for FOREIGN.D ######################### */
19732
19733 #ifdef DYNAMIC_FFI
19734 %% #ifdef DYNAMIC_FFI
19735 %% puts("#define HAVE_FFI");
19736
19737 /* Return the pointer encoded by a Foreign-Pointer. */
19738 #define Fpointer_value(obj) TheFpointer(obj)->fp_pointer
19739
19740 /* Return the pointer encoded by a Foreign-Address. obj a variable */
19741 #define Faddress_value(obj) \
19742 ((void*)((uintP)Fpointer_value(TheFaddress(obj)->fa_base) + TheFaddress(obj)->fa_offset))
19743
19744 /* Allocate a foreign address.
19745 make_faddress(base,offset)
19746 > base: base address
19747 > offset: offset relative to the base address
19748 < result: Lisp object
19749 can trigger GC */
19750 extern maygc object make_faddress (object base, uintP offset);
19751 /* used by FOREIGN & modules (see foreign1.lisp:convert-from-foreign) */
19752 %% exportF(object,make_faddress,(object base, uintP offset));
19753
19754 /* ensure that the Faddress is valid
19755 < fa: foreign address (not checked!)
19756 can trigger GC */
19757 extern maygc object check_faddress_valid (object fa);
19758 /* usd by FOREIGN, MISC */
19759
19760 /* Registers a foreign variable.
19761 register_foreign_variable(address,name,flags,size);
19762 > address: address of a variable in memory
19763 > name: its name
19764 > flags: fv_readonly for read-only variables
19765 > size: its size in bytes
19766 can trigger GC */
19767 extern maygc void register_foreign_variable (void* address, const char * name, uintBWL flags, uintL size);
19768 /* Specifies that the variable will not be written to. */
19769 #define fv_readonly bit(0)
19770 /* Specifies that when the value is replaced and the variable contains pointers,
19771 the old storage will be free()d and new storage will be allocated via malloc(). */
19772 #define fv_malloc bit(1)
19773 %% exportF(void,register_foreign_variable,(void* address, const char * name, uintBWL flags, uintL size));
19774
19775 /* Registers a foreign function.
19776 register_foreign_function(address,name,flags);
19777 > address: address of the function in memory
19778 > name: its name
19779 > flags: its language and parameter passing convention
19780 can trigger GC */
19781 extern maygc void register_foreign_function (void* address, const char * name, uintWL flags);
19782 /* Flags for language: */
19783 #define ff_lang_asm bit(8) /* no argument passing conventions */
19784 #define ff_lang_c bit(9) /* K&R C, with argument type promotions */
19785 #define ff_lang_ansi_c bit(10) /* ANSI C, without argument type promotions */
19786 /* define ff_lang_pascal bit(11) # not yet supported */
19787 #define ff_lang_stdcall bit(15) /* `stdcall' calling convention */
19788 /* Varargs functions are not supported.
19789 Set this if pointers within the arg should point to alloca()ed data, i.e.
19790 have dynamic extent: are valid for this call only. */
19791 #define ff_alloca bit(0)
19792 /* Set this if pointers within the arg should point to malloc()ed data. The
19793 function takes over responsibility for that storage. For return values,
19794 set this if free() shall be called for pointers within the resulting value. */
19795 #define ff_malloc bit(1)
19796 /* Set this if the arg should point to a place where a return value can be
19797 stored. */
19798 #define ff_out bit(4)
19799 /* Set this if the arg is also treated as a return value. */
19800 #define ff_inout bit(5)
19801 %% exportF(void,register_foreign_function,(void* address, const char * name, uintWL flags));
19802
19803 /* Registers a foreign int type.
19804 register_foreign_inttype (const char * name_asciz, uintL size, bool signed_p)
19805 > name_asciz: C type name
19806 > size : sizeof(name_asciz)
19807 > signed_p : signed?
19808 can trigger GC */
19809 extern maygc void register_foreign_inttype (const char * name_asciz, uintL size, bool signed_p);
19810 %% exportF(void,register_foreign_inttype,(const char * name_asciz, uintL size, bool signed_p));
19811
19812 /* Convert foreign data to Lisp data.
19813 can trigger GC */
19814 extern maygc object convert_from_foreign (object fvd, const void* data);
19815 %% exportF(object,convert_from_foreign,(object fvd, const void* data));
19816
19817 /* Convert Lisp data to foreign data. */
19818 typedef void* converter_malloc_t (void* old_data, uintL size, uintL alignment, void** state);
19819 global converter_malloc_t mallocing, nomalloc;
19820 %% puts("typedef void* converter_malloc_t (void* old_data, uintL size, uintL alignment, void** state);");
19821 %% exportV(converter_malloc_t,nomalloc);
19822 %% exportV(converter_malloc_t,mallocing);
19823 /* Convert Lisp data to foreign data.
19824 Storage is allocated through converter_malloc().
19825 Only the toplevel storage must already exist; its address is given.
19826 can trigger GC */
19827 extern void convert_to_foreign (object fvd, object obj, void* data, converter_malloc_t *converter_malloc, void** state);
19828 %% exportF(void,convert_to_foreign,(object fvd, object obj, void* data, converter_malloc_t *converter_malloc, void** state));
19829
19830 /* Initialize the FFI. */
19831 extern maygc void init_ffi (void);
19832 /* used by SPVW */
19833
19834 /* De-Initialize the FFI. */
19835 extern void exit_ffi (void);
19836 /* used by SPVW */
19837
19838 #endif
19839 %% #endif
19840
19841 /* ######################## THREADBIBL for THREAD.D ######################## */
19842
19843 #ifdef MULTITHREAD
19844 %% #ifdef MULTITHREAD
19845
19846 /* thread-local object table */
19847 struct object_tab_tl_ {
19848 #define LISPOBJ_TL(name,initstring) gcv_object_t name;
19849 #include "constobj_tl.c"
19850 #undef LISPOBJ_TL
19851 };
19852
19853 /* every thread keeps chain of pinned objects.
19854 usually there will be just a single one (if any), but it is
19855 possible with signal handlers to have real chain.*/
19856 typedef struct pinned_chain_t {
19857 gcv_object_t pc_varobject; /* GC invariant - GC will mark it */
19858 gcv_object_t *pc_unwind_stack_ptr; /* pointer above the STACK when object
19859 was pinned */
19860 struct pinned_chain_t *pc_next;
19861 } pinned_chain_t;
19862
19863 /* Structure containing all the per-thread global variables.*/
19864 typedef struct clisp_thread_t {
19865 /* Most often used (also used by modules - so should be exported) : */
19866 gcv_object_t* _STACK;
19867 uintC _mv_count;
19868 p_backtrace_t _back_trace;
19869 struct object_tab_tl_ _object_tab;
19870 #ifdef DEBUG_GCSAFETY
19871 uintL _alloccount; /* alloccount for this thread */
19872 #endif
19873 #if defined(DEBUG_SPVW) && (defined(CAN_ALLOCATE_8BIT_VECTORS_ON_C_STACK) || defined(CAN_ALLOCATE_STRINGS_ON_C_STACK))
19874 /* in debug builds that allocate lisp objects on C stack we want to assert
19875 from GC if there is something wrong. So before going in suspend
19876 state for GC - the thread will save here the current stack pointer.*/
19877 void *_SP_before_suspend;
19878 #endif
19879 /* GC suspend/resume machinery */
19880 spinlock_t _gc_suspend_request; /*always signalled unless there is a suspend request. */
19881 spinlock_t _gc_suspend_ack; /* always signalled unless it can be assumed the thread is suspended */
19882 xmutex_raw_t _gc_suspend_lock; /* the mutex on which the thread waits. */
19883 uintC _suspend_count; /* how many times this thread has been suspended ? */
19884 /* The values of per-thread symbols: */
19885 gcv_object_t *_ptr_symvalues; /* allocated separately */
19886 #if (int_bitsize < long_bitsize)
19887 long _jmpl_value;
19888 #endif
19889 #if defined(HAVE_SIGNALS) && defined(SIGPIPE)
19890 /* Set ONLY during IO calls to pipes directed to subprocesses. */
19891 bool _writing_to_subprocess;
19892 #endif
19893 /* is the thread waiting to be resumed (on _gc_suspend_lock) */
19894 xmutex_raw_t *_raw_wait_mutex;
19895 /* count of pending interrupts */
19896 volatile uintC _pending_interrupts;
19897 /* chain of pinned objects for this thread */
19898 pinned_chain_t * _pinned;
19899 object _mv_space [mv_limit-1];
19900 /* everything till here is exported to modules */
19901 /* The lexical environment: */
19902 gcv_environment_t _aktenv;
19903 /* Used for exception handling only: */
19904 handler_args_t _handler_args;
19905 stack_range_t* _inactive_handlers;
19906 unwind_protect_caller_t _unwind_protect_to_save;
19907 #ifndef NO_SP_CHECK
19908 void* _SP_bound;
19909 #endif
19910 void* _SP_anchor;
19911 gcv_object_t* _STACK_bound;
19912 gcv_object_t* _STACK_start;
19913 bool _running_handle_directory_encoding_error; /* used in pathname.d */
19914 bool _running_handle_close_errors; /* used in stream.d */
19915 /* do not rely on SA_NODEFER for signal nesting */
19916 spinlock_t _signal_reenter_ok;
19917 /* Following are related to thread interruption */
19918 /* condvar on which thread waits currently (in GC_SAFE way) */
19919 xcondition_t *_wait_condition;
19920 /* mutex on which thread waits currently (in GC_SAFE way) */
19921 xmutex_t *_wait_mutex;
19922 bool _own_stack; /* who owns our lisp stack. should it be freed? */
19923 /* true when thread is in final cleanup and should not be interrupted */
19924 bool _thread_is_dying;
19925 /* the current thread. NOT GC VISIBLE. */
19926 gcv_object_t _lthread;
19927 /* real time when the thread started */
19928 internal_time_t thr_realstart_time;
19929 /* previous and next thread. all active threads are kept in double
19930 linked list*/
19931 struct clisp_thread_t *thr_prev;
19932 struct clisp_thread_t *thr_next;
19933 } clisp_thread_t;
19934
19935 /* following macro is "called" before thread can be suspended in debug
19936 builds with possible object allocated on C stack */
19937 #if defined(DEBUG_SPVW) && (defined(CAN_ALLOCATE_8BIT_VECTORS_ON_C_STACK) || defined(CAN_ALLOCATE_STRINGS_ON_C_STACK))
19938 #define SET_SP_BEFORE_SUSPEND(thr) \
19939 do { \
19940 var int dummy; \
19941 thr->_SP_before_suspend = (void *)&dummy; \
19942 } while(0)
19943 #else
19944 #define SET_SP_BEFORE_SUSPEND(thr)
19945 #endif
19946
19947 #define GC_SAFE_SPINLOCK_ACQUIRE(s) \
19948 do { \
19949 while (!spinlock_tryacquire(s)) { \
19950 GC_SAFE_POINT_IF(GC_SAFE_ACK_SUSPEND_REQUEST_(),xthread_yield()); \
19951 } \
19952 } while(0)
19953
19954 /* helper macro for locking mutex that allows GC and thread interrupts while
19955 waiting. To be used only here and in zthread.d. In all other places
19956 WITH_OS_MUTEX_LOCK() should be used since it guarantees correct unlocking
19957 in case of non-local exit and thread interrupt
19958 > mutex: mutex to lock
19959 > locked: pointer to bool filled with true in case the lock
19960 has been acquired (before handling of pending interrupts) */
19961 #define GC_SAFE_MUTEX_LOCK(mutex,locked) \
19962 do { \
19963 xmutex_t *m=mutex; /* get pointer before we allow GC */ \
19964 current_thread()->_wait_mutex = m; \
19965 begin_blocking_system_call(); \
19966 xmutex_lock(m); \
19967 *locked = true; \
19968 current_thread()->_wait_mutex=NULL; \
19969 end_blocking_system_call(); /* nb: pending interrupt are handled here */ \
19970 } while(0)
19971
19972 /* unlocks mutex. preserves mv_space (i.e. does not allow gc or thread
19973 interruption)*/
19974 #define GC_SAFE_MUTEX_UNLOCK(m) \
19975 do { \
19976 begin_system_call(); \
19977 xmutex_unlock(m); \
19978 end_system_call(); \
19979 } while (0)
19980
19981 /* try to use the compiler support for thread local storage */
19982 #if defined(__GNUC__)
19983 #if defined(UNIX_LINUX) || defined(UNIX_FREEBSD) || (defined(UNIX_MACOSX) && (defined(__clang__) || (((__GNUC__ == 4) && (__GNUC_MINOR__ >= 5)) || (__GNUC__ > 4))))
19984 #define per_thread __thread
19985 #endif
19986 #elif defined(__WIN32__) && defined (MICROSOFT)
19987 #define per_thread __declspec(thread)
19988 #endif
19989 /* If asked for USE_CUSTOM_TLS - it overrides the compiler TLS
19990 support - if any. Warn the user. */
19991 #if defined(per_thread) && defined(USE_CUSTOM_TLS)
19992 #warning "USE_CUSTOM_TLS overrides the compiler per_thread support."
19993 #undef per_thread
19994 #endif
19995
19996 #ifdef per_thread
19997 extern per_thread clisp_thread_t* _current_thread; /* current_thread pointer */
19998 #define current_thread() _current_thread
19999 #define set_current_thread(thread) _current_thread=thread
20000 #else
20001 /* We want MT, but our compiler does not provide built in support for TLS.
20002 USE_CUSTOM_TLS={1,2,3}
20003 1 - using xthread_key_get/set - slowest one (and probably safest)
20004 2 - using slightly modified version of TLS found in Boehm GC for C/C++.
20005 3 - using full page map of address space (4 MB).
20006 Basically it is trade-off between performance/memory usage:
20007 {1} - xthread_key_get/set is 200-500% slower then native compiler TLS.
20008 {2} is about 50-100% slower than compiler TLS support and uses
20009 just 8 KB.
20010 {3} is almost as fast as single threaded and compiler TLS but uses 4 MB.
20011
20012 NB: {2} and {3} assume 32 bit address space and 4 KB page size (anything other
20013 will cause problems).
20014 */
20015
20016 /* If there is no prefered way to perform TLS - fall back to the slowest
20017 one (and probably safest).*/
20018 #if !defined(USE_CUSTOM_TLS)
20019 #define USE_CUSTOM_TLS 1
20020 #endif
20021
20022 /* custom TLS == 3 is available only on 32 bit platforms */
20023 #if USE_CUSTOM_TLS == 3 && defined(WIDE_HARD)
20024 #error "USE_CUSTOM_TLS == 3 asked on 64 bit machine."
20025 #endif
20026
20027 /* for {2} and {3} we will need access to the stack pointer */
20028 #if USE_CUSTOM_TLS >=2
20029 #define TLS_SP_SHIFT 12
20030
20031 #if defined(ASM_get_SP_register)
20032 /* means we have also GNU - so can use the extension */
20033 #define roughly_SP() \
20034 ({ var aint __SP; __asm__ ASM_get_SP_register(__SP); __SP;})
20035 #elif defined(GNU)
20036 /* may be use SP() as well ?? */
20037 #define roughly_SP() (aint)__builtin_frame_address(0)
20038 #else
20039 /* this may expand to function call !!! */
20040 /* MSVC falls here (and all other non-gcc 32 bit compilers) */
20041 #define roughly_SP() (aint)SP()
20042 #endif /* ASM_get_SP_register) / GNU */
20043 #endif /* USE_CUSTOM_TLS */
20044
20045 /* xthread_key_get/set - slowest way to do things.*/
20046 #if USE_CUSTOM_TLS == 1
20047 extern xthread_key_t current_thread_tls_key;
20048 #define set_current_thread(thread) \
20049 xthread_key_set(current_thread_tls_key,(void *)thread)
20050 #ifdef WIN32_NATIVE
20051 /* TlsGetValue() changes GetLastError() - this is quite bad and we
20052 should preserve the old value. Otherwise GC_SAFE_SYSTEM_CALL()
20053 will "return" with bad last error (which causes really weird
20054 problems). */
current_thread_impl()20055 static inline clisp_thread_t *current_thread_impl() {
20056 DWORD err=GetLastError();
20057 clisp_thread_t *thr=((clisp_thread_t *)xthread_key_get(current_thread_tls_key));
20058 SetLastError(err);
20059 return thr;
20060 }
20061 #define current_thread() current_thread_impl()
20062 #else
20063 #define current_thread() \
20064 ((clisp_thread_t *)xthread_key_get(current_thread_tls_key))
20065 #endif
20066
20067 /* modified version of the code in Boehm C/C++ GC.
20068 much faster just 16 KB mem usage.*/
20069 #elif USE_CUSTOM_TLS == 2
20070 #define TS_CACHE_SIZE 1024
20071 #define TSD_CACHE_HASH(n) (((((long)n) >> 8) ^ (long)n) & (TS_CACHE_SIZE - 1))
20072 #define TS_HASH_SIZE 1024
20073 #define TSD_HASH(n) (((((long)n) >> 8) ^ (long)n) & (TS_HASH_SIZE - 1))
20074 #define INVALID_QTID ((unsigned long)0)
20075
20076 typedef struct thread_specific_entry {
20077 volatile long qtid; /*quick thread id, only for cache - atomic store*/
20078 void *value; /* clisp_thread_t actually */
20079 struct thread_specific_entry *next;
20080 xthread_t thread;
20081 } tse;
20082 typedef struct thread_specific_data {
20083 /* A faster index to the hash table */
20084 tse * volatile cache[TS_CACHE_SIZE];
20085 tse *hash[TS_HASH_SIZE];
20086 spinlock_t lock;
20087 } tsd;
20088 /* global variable the keeps all active threads TLS values */
20089 extern tsd threads_tls;
20090 /* the slow version for accessing the TLS when the quick cache
20091 misses (when the thread stack crosses the VM page boundary). */
20092 global void* tsd_slow_getspecific(unsigned long qtid,
20093 tse * volatile *cache_ptr);
20094 /* UP: removes the TLS for current thread - should be called on
20095 thread exit. */
20096 global void tsd_remove_specific (void);
20097 /* initializes the current thread storage with supplied value.
20098 entry should be pre-allocated. May reside on the stack as
20099 well - but we have to be sure that it will be valid during
20100 the thread lifespan. */
20101 global void tsd_setspecific(tse *entry, void *value);
20102 /* quick TLS lookup. If there is cache miss - falls back to the slow
20103 version (which updates the cache as well). */
tsd_getspecific()20104 static inline void *tsd_getspecific()
20105 {
20106 long qtid = roughly_SP() >> TLS_SP_SHIFT;
20107 unsigned hash_val = TSD_CACHE_HASH(qtid);
20108 tse * volatile * entry_ptr = threads_tls.cache + hash_val;
20109 tse * entry = *entry_ptr; /* Must be loaded only once. */
20110 if (entry->qtid == qtid) {
20111 return entry->value;
20112 }
20113 return tsd_slow_getspecific(qtid, entry_ptr);
20114 }
20115 #define current_thread() \
20116 ((clisp_thread_t *)tsd_getspecific())
20117 /* NB: really nasty thing in order to have nice build.
20118 the __thread_tse_entry should be declared before using the
20119 set_current_thread macro !!!! So actually on the entry point of
20120 any LISP thread we have to declare it if needed. Fortunately there
20121 are just 3 places and no plans for more. */
20122 #define set_current_thread(thread) \
20123 tsd_setspecific(__thread_tse_entry,(void *)thread)
20124
20125 /* fastest TLS - almost matches compiler provided TLS support.
20126 maps the SP >> 12 to clisp_thread_t. */
20127 #elif USE_CUSTOM_TLS == 3
20128 #define TLS_PAGE_SIZE 4096
20129 /* the array below is indexed by SP >> 12 (TLS_SP_SHIFT)*/
20130 extern clisp_thread_t *threads_map[];
20131 #define current_thread() threads_map[roughly_SP() >> TLS_SP_SHIFT]
20132 global void set_current_thread(clisp_thread_t *thr);
20133 #else
20134 #error "USE_CUSTOM_TLS should be defined as 1,2 or 3. See comment."
20135 #endif
20136 #endif /* !defined(per_thread)*/
20137
20138 /* just the beginning of the structure is exported -
20139 what modules want to know about (in order to build) */
20140 %% puts("struct object_tab_tl_ {");
20141 %% #define LISPOBJ_TL(name,initstring) printf(" gcv_object_t %s;\n",STRING(name));
20142 %% #include "constobj_tl.c"
20143 %% #undef LISPOBJ_TL
20144 %% puts("};");
20145 %% puts("typedef struct pinned_chain_t {");
20146 %% puts(" gcv_object_t pc_varobject;");
20147 %% puts(" gcv_object_t *pc_unwind_stack_ptr;");
20148 %% puts(" struct pinned_chain_t *pc_next;");
20149 %% puts("} pinned_chain_t;");
20150 %% puts("typedef struct {");
20151 %% puts(" gcv_object_t* _STACK;");
20152 %% puts(" uintC _mv_count;");
20153 %% puts(" p_backtrace_t _back_trace;");
20154 %% puts(" struct object_tab_tl_ _object_tab;");
20155 %% #ifdef DEBUG_GCSAFETY
20156 %% puts(" uintL _alloccount;");
20157 %% #endif
20158 %% #if defined(DEBUG_SPVW) && (defined(CAN_ALLOCATE_8BIT_VECTORS_ON_C_STACK) || defined(CAN_ALLOCATE_STRINGS_ON_C_STACK))
20159 %% puts(" void *_SP_before_suspend;");
20160 %% #endif
20161 %% puts(" spinlock_t _gc_suspend_request;");
20162 %% puts(" spinlock_t _gc_suspend_ack;");
20163 %% puts(" xmutex_raw_t _gc_suspend_lock;");
20164 %% puts(" uintC _suspend_count;");
20165 %% puts(" gcv_object_t *_ptr_symvalues;");
20166 %% #if (int_bitsize < long_bitsize)
20167 %% puts(" long _jmpl_value;");
20168 %% #endif
20169 %% #if defined(HAVE_SIGNALS) && defined(SIGPIPE)
20170 %% puts(" bool _writing_to_subprocess;");
20171 %% #endif
20172 %% puts(" xmutex_raw_t *_raw_wait_mutex;");
20173 %% puts(" volatile uintC _pending_interrupts;");
20174 %% puts(" pinned_chain_t * _pinned;");
20175 %% puts(" object _mv_space [unspecified];");
20176 %% puts("} clisp_thread_t;");
20177
20178 %% #ifdef per_thread
20179 %% export_def(per_thread);
20180 %% exportV(per_thread clisp_thread_t*,_current_thread);
20181 %% #else
20182 %% #if USE_CUSTOM_TLS == 1
20183 %% exportV(xthread_key_t,current_thread_tls_key);
20184 %% #ifdef WIN32_NATIVE
20185 %% puts("static inline clisp_thread_t *current_thread_impl() {");
20186 %% puts(" DWORD err=GetLastError();");
20187 %% puts(" clisp_thread_t *thr=((clisp_thread_t *)TlsGetValue(current_thread_tls_key));");
20188 %% puts(" SetLastError(err); return thr;\n}");
20189 %% #endif
20190 %% #elif USE_CUSTOM_TLS == 2
20191 %% export_def(TS_CACHE_SIZE);
20192 %% export_def(TS_HASH_SIZE);
20193 %% export_def(TSD_CACHE_HASH(qtid));
20194 %% export_def(roughly_SP());
20195 %% export_def(TLS_SP_SHIFT);
20196 %% emit_typedef("struct thread_specific_entry { volatile long qtid; void *value; struct thread_specific_entry *next; xthread_t thread; }","tse");
20197 %% emit_typedef("struct thread_specific_data { tse * volatile cache[TS_CACHE_SIZE]; tse *hash[TS_HASH_SIZE]; spinlock_t lock; }","tsd");
20198 %% exportV(tsd,threads_tls);
20199 %% exportF(void,tsd_setspecific,(tse *entry, void *value));
20200 %% exportF(void*,tsd_slow_getspecific,(unsigned long qtid,tse * volatile *cache_ptr));
20201 %% puts("static inline void *tsd_getspecific() {");
20202 %% puts(" long qtid = roughly_SP() >> 12;");
20203 %% puts(" unsigned hash_val = TSD_CACHE_HASH(qtid);");
20204 %% puts(" tse * volatile * entry_ptr = threads_tls.cache + hash_val;");
20205 %% puts(" tse * entry = *entry_ptr;");
20206 %% puts(" if (entry->qtid == qtid) {");
20207 %% puts(" return entry->value;");
20208 %% puts(" }");
20209 %% puts(" return tsd_slow_getspecific(qtid, entry_ptr);");
20210 %% puts("}");
20211 %% #elif USE_CUSTOM_TLS == 3
20212 %% export_def(TLS_SP_SHIFT);
20213 %% exportF(clisp_thread_t*,threads_map,[]);
20214 %% #endif
20215 %% #endif
20216
20217 #define inactive_handlers current_thread()->_inactive_handlers
20218 #define handler_args current_thread()->_handler_args
20219 #define unwind_protect_to_save current_thread()->_unwind_protect_to_save
20220 #define aktenv current_thread()->_aktenv
20221 #define STACK_bound current_thread()->_STACK_bound
20222 #define STACK_start current_thread()->_STACK_start
20223 #define mv_space current_thread()->_mv_space
20224 #define STACK current_thread()->_STACK
20225 #define TLO(name) current_thread()->_object_tab.name
20226 #define mv_count current_thread()->_mv_count
20227 #define back_trace current_thread()->_back_trace
20228 #define SP_bound current_thread()->_SP_bound
20229 #define SP_anchor current_thread()->_SP_anchor
20230 #define break_sems current_thread()->_break_sems
20231 #if defined(HAVE_SIGNALS) && defined(SIGPIPE)
20232 #define writing_to_subprocess current_thread()->_writing_to_subprocess
20233 #endif
20234 #define running_handle_directory_encoding_error \
20235 current_thread()->_running_handle_directory_encoding_error
20236 #define running_handle_close_errors \
20237 current_thread()->_running_handle_close_errors
20238 #if (int_bitsize < long_bitsize)
20239 #define jmpl_value current_thread()->_jmpl_value
20240 #endif
20241
20242 /* needed for building modules */
20243 %% export_def(current_thread());
20244 %% export_def(value1);
20245 %% export_def(value2);
20246 %% export_def(value3);
20247 %% export_def(value4);
20248 %% export_def(value5);
20249 %% export_def(value6);
20250 %% export_def(value7);
20251 %% export_def(value8);
20252 %% export_def(value9);
20253 %% export_def(mv_space);
20254 %% export_def(mv_count);
20255 %% export_def(back_trace);
20256 %% #if defined(HAVE_SIGNALS) && defined(SIGPIPE)
20257 %% export_def(writing_to_subprocess);
20258 %% #endif
20259 %% export_def(SET_SP_BEFORE_SUSPEND(thr));
20260 %% #ifdef export_unwind_protect_macros
20261 %% #if (int_bitsize < long_bitsize)
20262 %% export_def(jmpl_value);
20263 %% #endif
20264 %% #endif
20265
20266 /* allocates,initializes and returns clisp_thread_t structure.
20267 Does not register it in the global thread array.
20268 When called the global thread lock should be held.*/
20269 global clisp_thread_t* create_thread(uintM lisp_stack_size);
20270 /* UP: removes the current_thread from the list (array) of threads.
20271 Also frees any allocated resource.
20272 > thread: thread to be removed */
20273 global void delete_thread(clisp_thread_t *thread);
20274 /* UP: creates initial bindings in thread context from alist
20275 > initial_bindings: alist of (symbol . form) elements */
20276 global void initialize_thread_bindings(gcv_object_t *initial_bindings);
20277 /* UP: Suspends all running threads /besides the current/ at GC safe
20278 points/regions.
20279 > lock_heap: if false - the caller already owns the heap lock
20280 At the end the heap lock is released since the GC itself may want
20281 to allocate. */
20282 global void gc_suspend_all_threads(bool lock_heap);
20283 /* UP: Resumes all suspended threads after GC (or world stop)
20284 > unlock_heap: if true - the heap lock will be released at the end
20285 should match a call to gc_suspend_all_threads()*/
20286 global void gc_resume_all_threads(bool unlock_heap);
20287 /* UP: Suspends single thread
20288 > thread: the thread to be suspended
20289 > have_locks: is the caller holding the heap and threads locks ?
20290 < returns true of the thread has been suspended. false in case it has exited
20291 meanwhile
20292 Called from signal handler thread and THREAD-INTERRUPT
20293 Upon exit we hold threads lock. It is released in resume_thread(). This prevents
20294 race condition when several threads try to THREAD-INTERRUPT another thread. */
20295 global maygc bool suspend_thread(object thread, bool have_locks);
20296 /* UP: Resumes single thread (or just decreases it's _suspend_count).
20297 > thread: the thread to be suspended
20298 > release_threads_lock: should we unlock threads lock
20299 Called from signal handler thread and from THREAD-INTERRUPT
20300 When called we should be the owner of threads lock and if specified we should
20301 release it.
20302 Should match a call to suspend_thread */
20303 global void resume_thread(object thread, bool release_threads_lock);
20304 /* UP: interrupts thread "safely"
20305 > thr: the thread
20306 The thread should be suspended (safe for GC).
20307 Caller should hold the thread _signal_reenter_ok. On failure
20308 (or when the thread will not be signalled) it will be released here*/
20309 global bool interrupt_thread(clisp_thread_t *thr);
20310 /* UP: signals that there is new timeout call (CALL-WITH-TIMEOUT)
20311 handles both POSIX and WIN32 threads */
20312 global int signal_timeout_call (void);
20313 /* UP: handles any pending interrupt (currently just one).
20314 arguments are on the STACK */
20315 global maygc void handle_pending_interrupts (void);
20316 %% exportF(void,handle_pending_interrupts,(void));
20317 /* releases the clisp_thread_t memory of the list of Thread records */
20318 global void release_threads (object list);
20319 /* releases the OS mutexes for mutex objects in the list */
20320 global void release_mutexes(object list);
20321 /* releases the OS condition variables for exemption objects in the list */
20322 global void release_exemptions(object list);
20323 /* called at thread exiting. performs cleanup/checks. */
20324 global maygc void thread_cleanup(void);
20325 /* signals an error if obj is not thread. returns the thread */
20326 global maygc object check_thread(object obj);
20327 /* add per thread special symbol value - initialized to SYMVALUE_EMPTY.
20328 symbol: the symbol
20329 returns: the new index in the _symvalues thread array */
20330 global maygc uintL add_per_thread_special_var(object symbol);
20331 /* Clears any per thread value for symbol. Also set tls_index
20332 of the symbol to invalid. */
20333 global maygc void clear_per_thread_symvalues(object symbol);
20334 /* O(open_files) needs a global locks when accessed/modified */
20335 extern xmutex_t open_files_lock;
20336 /* O(open_files) needs a global locks when accessed/modified */
20337 extern xmutex_t all_finalizers_lock;
20338 /* mutex for guarding access to O(all_mutexes) */
20339 extern xmutex_t all_mutexes_lock;
20340 /* mutex for guarding access to O(all_exemptions) */
20341 extern xmutex_t all_exemptions_lock;
20342 /* mutex for guarding access to O(all_weakpointers) */
20343 extern xmutex_t all_weakpointers_lock;
20344 /* mutex for guarding access to O(all_packages) */
20345 extern xmutex_t all_packages_lock;
20346 /* mutex protecting the O(all_threads) and list of clisp_thread_t structs
20347 NB: when it is hold - any heap allocation will cause deadlock */
20348 extern xmutex_t allthreads_lock;
20349 /* mutex serializing gensym (only when *gensym-counter* is not
20350 per thread bound) */
20351 extern xmutex_t gensym_lock;
20352 /* mutex guarding internal counter used by gentemp */
20353 extern xmutex_t gentemp_lock;
20354
20355 /* operations on a lisp stack that is not the current one (NC)
20356 - ie. belongs to other not yet started threads */
20357 #ifdef STACK_DOWN
20358 #define NC_STACK_(non_current_stack,n) (non_current_stack[(sintP)(n)])
20359 #endif
20360 #ifdef STACK_UP
20361 #define NC_STACK_(non_current_stack,n) (non_current_stack[-1-(sintP)(n)])
20362 #endif
20363 #define NC_pushSTACK(non_current_stack,obj) \
20364 (NC_STACK_(non_current_stack,-1) = (obj), non_current_stack skipSTACKop -1)
20365
20366 /* every CALL-WITH-TIMEOUT adds an item in the chain below.
20367 upon timeout the thread is interrupted with (THROW TAG) */
20368 typedef struct timeout_call {
20369 clisp_thread_t *thread; /* thread to be interrupted */
20370 gcv_object_t *throw_tag; /* pointer to thread STACK */
20371 bool failed; /* true if the thread signal has failed */
20372 struct timeval *expire; /* timeout expire time */
20373 struct timeout_call *next; /* next timeout call */
20374 } timeout_call;
20375 /* lock for the timeout_call_chain */
20376 extern spinlock_t timeout_call_chain_lock;
20377 /* chain of sorted by expire time timeout_calls */
20378 extern timeout_call *timeout_call_chain;
20379 /* returns true if p1 is before p2 */
20380 global bool timeval_less(struct timeval *p1, struct timeval *p2);
20381
20382 #define GC_STOP_WORLD(lock_heap) \
20383 gc_suspend_all_threads(lock_heap)
20384 #define GC_RESUME_WORLD(unlock_heap) \
20385 gc_resume_all_threads(unlock_heap)
20386
20387 /* all calls to GC should be via this macro.
20388 The statement is executed. If lock_heap is true the heap is locked first.
20389 (this is needed since GC may be called from allocation or explicitly - when
20390 the heap lock is not held). */
20391 #define WITH_STOPPED_WORLD(lock_heap,statement) \
20392 do { \
20393 var bool lh=lock_heap; \
20394 GC_STOP_WORLD(lh); \
20395 statement; \
20396 GC_RESUME_WORLD(lh); \
20397 } while(0)
20398
20399 #ifndef DEBUG_GCSAFETY
20400 #define PERFORM_GC(statement,lock_heap) \
20401 do { \
20402 SET_SP_BEFORE_SUSPEND(current_thread()); \
20403 WITH_STOPPED_WORLD(lock_heap,statement); \
20404 } while(0)
20405 #else /* DEBUG_GCSAFETY */
20406 /* if we trigger GC from allocate_xxxx, than we already have
20407 stopped the world and will resume it at exit.*/
20408 #define PERFORM_GC(statement,lock_heap) \
20409 do { \
20410 SET_SP_BEFORE_SUSPEND(current_thread()); \
20411 if (lock_heap) WITH_STOPPED_WORLD(true,statement); else statement; \
20412 }while(0)
20413 extern uintL* current_thread_alloccount (void);
20414 #endif
20415
20416 #if defined(GENERATIONAL_GC) && defined(SPVW_MIXED)
20417 #define unprotect_heap_range(vo,access) \
20418 handle_fault_range(access, (aint)TheVarobject(vo), \
20419 (aint)TheVarobject(vo) + varobject_bytelength(vo))
20420 #else
20421 #define unprotect_heap_range(vo,access)
20422 #endif
20423
20424 #ifdef DEBUG_SPVW
20425 /* aborts if we want to pin object while we are in GC safe region.
20426 prevents bad pin_varobject() usage. */
20427 #define ASSERT_SAFE_TO_PIN() \
20428 do { \
20429 if (current_thread()->_gc_suspend_ack == 0) abort(); \
20430 } while(0)
20431 /* aborts if we want to unpin object that is not in the front of pinned
20432 object chain. since we have proper unwind semantic - this should
20433 never happen.*/
20434 #define ASSERT_VALID_UNPIN(pc,vo) \
20435 do { \
20436 if (!eq((*pc)->pc_varobject, vo)) abort(); \
20437 } while(0)
20438 #else
20439 #define ASSERT_SAFE_TO_PIN()
20440 #define ASSERT_VALID_UNPIN(pc,vo)
20441 #endif
20442
20443 /* UP: pins varobject by using pinned_chain_t pointed by pc.
20444 > pc: pointer to C stack allocated pinned_chain_t struct
20445 > varobj: varobject to be pinned
20446 NB: pc should be C stack allocated (auto scope or alloca()).
20447 usage should be matched with unpin_varobject(). In case of non-local
20448 exit before the control reaches unpin_varobject() - cleanup is performed
20449 in enter_frame_at_STACK() (same like the backtrace).
20450 does not modify the STACK */
20451 #define pin_varobject_with_pc(pc, varobj) do { \
20452 ASSERT_SAFE_TO_PIN(); \
20453 (pc)->pc_varobject = varobj; \
20454 (pc)->pc_unwind_stack_ptr = &STACK_(-1);/* above current stack */ \
20455 (pc)->pc_next = current_thread()->_pinned; \
20456 current_thread()->_pinned = (pc); \
20457 } while(0)
20458
20459 /* UP: add object to the pinned chain.
20460 > varobj: the varobject to be pinned
20461 allocates pinned_chain_t struct on C stack and uses it */
20462 #define pin_varobject(varobj) \
20463 var pinned_chain_t GENTAG(pc); \
20464 pin_varobject_with_pc(&GENTAG(pc), varobj)
20465
20466 /* UP: unpin varobject in lisp heap. */
20467 #define unpin_varobject(varobj) do { \
20468 var pinned_chain_t **p=&(current_thread()->_pinned); \
20469 ASSERT_VALID_UNPIN(p,varobj); \
20470 *p = (*p)->pc_next; \
20471 } while(0)
20472
20473 /* Macro: pin varobj, execute code, unpin it */
20474 #define with_pinned_varobject(varobj,code) do { \
20475 var pinned_chain_t GENTAG(pc); \
20476 pin_varobject_with_pc(&GENTAG(pc), varobj); \
20477 code; \
20478 unpin_varobject(GENTAG(pc).pc_varobject); \
20479 } while(0)
20480
20481 /* UP: unpins specified number of pinned objects. will abort if there are
20482 less pinned objects than asked (SEGFAULT).
20483 > count: how many object to remove from the pinned chain */
20484 #define unpin_varobjects(count) do { \
20485 var uintC cnt; \
20486 var pinned_chain_t **p=&(current_thread()->_pinned); \
20487 dotimespC(cnt, count, { *p = (*p)->pc_next; }); \
20488 } while(0)
20489
20490 /* UP: executes body while thread interrupts are deferred. after body
20491 finishes - deferred interrupts are executed (if any) */
20492 #define WITH_DEFERRED_INTERRUPTS(body) do { \
20493 dynamic_bind(S(defer_interrupts), T); \
20494 body; \
20495 dynamic_unbind(S(defer_interrupts)); \
20496 if (nullp(Symbol_thread_value(S(defer_interrupts)))) \
20497 while (!nullp(Symbol_thread_value(S(deferred_interrupts)))) { \
20498 var object intr = Car(Symbol_thread_value(S(deferred_interrupts))); \
20499 Symbol_thread_value(S(deferred_interrupts)) = \
20500 Cdr(Symbol_thread_value(S(deferred_interrupts))); \
20501 apply(Car(intr), 0, nreverse(Cdr(intr))); \
20502 } \
20503 } while (0)
20504
20505 /* UP: helper macro for executing body in unwind_protect frame with
20506 mutex lock held. body should not call return or goto outside of
20507 itself.
20508 > stack_count: number of object to copy from the stack after the
20509 UNWIND_PROTECT frame is established. at the end the same count of
20510 objects are removed from the stack.
20511 > keep_mv_space: whether the mv_space should be preserved
20512 > mutex: the mutex object
20513 > locker_vars: local variables used by locker (for thread interrupt safety)
20514 > locker: statement to execute for locking the mutex
20515 > unlocker: statement to execute for unlocking the mutex
20516 > body: the statement(s) to be executed with lock held */
20517 #define WITH_MUTEX_LOCK_HELP_(stack_count,keep_mv_space,mutex,locker_vars,locker,unlocker,body) \
20518 do { \
20519 locker_vars; \
20520 var gcv_object_t* top_of_frame = STACK; \
20521 var sp_jmp_buf returner; \
20522 finish_entry_frame(UNWIND_PROTECT,returner,, { \
20523 var restartf_t fun = unwind_protect_to_save.fun; \
20524 var gcv_object_t* upto = unwind_protect_to_save.upto_frame; \
20525 skipSTACK(2); \
20526 unlocker(mutex,true); \
20527 fun(upto); \
20528 }); \
20529 locker(mutex); \
20530 if (stack_count > 0) { \
20531 var gcv_object_t *args=&STACK_(stack_count+1); \
20532 var uintC count; \
20533 get_space_on_STACK(stack_count); \
20534 dotimespC(count,stack_count, { pushSTACK(*args++); }); \
20535 } \
20536 body; \
20537 /* skip the args and unwind_protect frame */ \
20538 skipSTACK(stack_count+2); \
20539 unlocker(mutex,keep_mv_space); \
20540 } while (0)
20541
20542 #define OS_MUTEX_LOCK_DECLARE_LOCALS var volatile bool locked=false
20543 #define OS_MUTEX_LOCK_HELP_(mutex) GC_SAFE_MUTEX_LOCK(mutex, &locked)
20544 #define OS_MUTEX_UNLOCK_HELP_(mutex,keep_mv_space) do { \
20545 if (locked) \
20546 GC_SAFE_MUTEX_UNLOCK(mutex); \
20547 } while(0)
20548 #define WITH_OS_MUTEX_LOCK(stack_count,mutex,body) \
20549 WITH_MUTEX_LOCK_HELP_(stack_count,true,mutex,OS_MUTEX_LOCK_DECLARE_LOCALS,OS_MUTEX_LOCK_HELP_,OS_MUTEX_UNLOCK_HELP_,body)
20550
20551 #define LISP_MUTEX_LOCK_DECLARE_LOCALS \
20552 var volatile bool we_owned = false; \
20553 var volatile uintL rec_count=0
20554 #define LISP_MUTEX_LOCK_HELP_(mutex) do { \
20555 we_owned = eq(TheMutex(*(mutex))->xmu_owner, current_thread()->_lthread); \
20556 rec_count = TheMutex(*(mutex))->xmu_recurse_count; \
20557 pushSTACK(*(mutex)); funcall(L(mutex_lock),1); \
20558 } while(0)
20559 /* also preserves values */
20560 #define LISP_MUTEX_UNLOCK_HELP_(mutex,keep_mv_space) \
20561 do { \
20562 var bool we_own = eq(TheMutex(*(mutex))->xmu_owner, current_thread()->_lthread); \
20563 var uintL rc = TheMutex(*(mutex))->xmu_recurse_count; \
20564 if (we_own && (!we_owned || rc > rec_count)) { \
20565 var uintC cnt=mv_count; \
20566 if (keep_mv_space) mv_to_STACK(); \
20567 WITH_DEFERRED_INTERRUPTS({ \
20568 pushSTACK(*(mutex)); \
20569 funcall(L(mutex_unlock),1); \
20570 }); \
20571 if (keep_mv_space) STACK_to_mv(cnt); \
20572 } \
20573 } while(0)
20574
20575 /* mutex should be pointer to GC safe location. */
20576 #define WITH_LISP_MUTEX_LOCK(stack_count,keep_mv_space,pmutex,body) \
20577 WITH_MUTEX_LOCK_HELP_(stack_count,keep_mv_space,pmutex,LISP_MUTEX_LOCK_DECLARE_LOCALS,LISP_MUTEX_LOCK_HELP_,LISP_MUTEX_UNLOCK_HELP_,body)
20578
20579 #else /* ! MULTITHREAD */
20580 %% #else
20581 #define pin_varobject_with_pc(pc,vo)
20582 #define pin_varobject(vo)
20583 #define unprotect_heap_range(vo,access)
20584 #define unpin_varobject(vo)
20585 #define with_pinned_varobject(vo,code) code
20586 #define unpin_varobjects(count)
20587 #define GC_STOP_WORLD(lock_heap)
20588 #define GC_RESUME_WORLD(unlock_heap)
20589 #define PERFORM_GC(statement,lock_heap) statement
20590 #define WITH_MUTEX_LOCK_HELP_(body) \
20591 do { \
20592 body; \
20593 } while(0);
20594 #define WITH_OS_MUTEX_LOCK(stack_count,mutex,body) \
20595 WITH_MUTEX_LOCK_HELP_(body)
20596 #define WITH_LISP_MUTEX_LOCK(stack_count,keep_mv_space,pmutex,body) \
20597 WITH_MUTEX_LOCK_HELP_(body)
20598 #endif
20599 %% #endif
20600
20601 #define pin_unprotect_varobject(vo,access) \
20602 pin_varobject(vo); unprotect_heap_range(vo,access)
20603
20604 %% export_def(unprotect_heap_range(vo,access));
20605 %% export_def(pin_varobject_with_pc(pc,vo));
20606 %% export_def(pin_varobject(vo));
20607 %% export_def(unpin_varobject(vo));
20608 %% export_def(with_pinned_varobject(vo,code));
20609 %% export_def(unpin_varobjects(count));
20610 %% export_def(WITH_OS_MUTEX_LOCK(stack_count,mutex,body));
20611 %% export_def(WITH_LISP_MUTEX_LOCK(stack_count,keep_mv_space,pmutex,body));
20612
20613 #if defined(HAVE_SIGNALS) && defined(SIGPIPE)
20614 #define START_WRITING_TO_SUBPROCESS writing_to_subprocess=true
20615 #define STOP_WRITING_TO_SUBPROCESS writing_to_subprocess=false
20616 #else
20617 #define START_WRITING_TO_SUBPROCESS /*noop*/
20618 #define STOP_WRITING_TO_SUBPROCESS /*noop*/
20619 #endif
20620 %% export_def(START_WRITING_TO_SUBPROCESS);
20621 %% export_def(STOP_WRITING_TO_SUBPROCESS);
20622
20623 #ifdef DEBUG_GCSAFETY
20624 /* Add support for the 'mv_space' expression to the GCTRIGGER1/2/... macros.*/
inc_allocstamp(object (& mvsp)[mv_limit-1])20625 inline void inc_allocstamp (object (&mvsp)[mv_limit-1]) {
20626 inc_allocstamp(value1);
20627 var uintC count = mv_count;
20628 if (count > 1) {
20629 var object* mvp = &mv_space[1];
20630 dotimespC(count,count-1, { inc_allocstamp(*mvp++); });
20631 }
20632 }
20633 #endif
20634
20635
20636 /* ######################## BUILTBIBL for BUILT.D ######################## */
20637
20638 /* Returns a multiline string containing some info about the flags with which
20639 the executable was built. */
20640 extern object built_flags (void);
20641
20642 /* ####################### FOR DEBUGGING UNDER GDB ####################### */
20643
20644 #ifdef GENERATIONAL_GC
20645 /* Put a breakpoint here if you want to catch CLISP just before it dies. */
20646 extern void sigsegv_handler_failed (void* address);
20647 #endif
20648
20649 /* For debugging: From within gdb, type: call ext_show_stack().
20650 Equivalent to (ext:show-stack) from the Lisp prompt. */
20651 extern void gdb_show_stack (void);
20652
20653 /* Fore debugging: From within gdb, type: call gdb_disassemble_closure(obj).
20654 Equivalent to (sys::disassemble-closures (list obj) *standard-output*). */
20655 extern void gdb_disassemble_closure (object obj);
20656
20657 /*************************************************************************/
20658