PageRenderTime 203ms CodeModel.GetById 32ms RepoModel.GetById 19ms app.codeStats 3ms

/src/lispbibl.d

https://github.com/ynd/clisp-branch--ynd-devel
D | 12025 lines | 7981 code | 741 blank | 3303 comment | 1075 complexity | c404e42f858ad768575a5be350bf7543 MD5 | raw file
Possible License(s): LGPL-2.0, GPL-2.0, BSD-3-Clause 
    

  1. /*
    2. 

  2.  * Main include-file for CLISP
    3. 

  3.  * Bruno Haible 1990-2008
    4. 

  4.  * Marcus Daniels 11.11.1994
    5. 

  5.  * Sam Steingold 1998-2008
    6. 

  6.  * German comments translated into English: Stefan Kain 2001-09-24
    7. 

    8. 

  8.  Flags intended to be set through CFLAGS:
    9. 

  9.    Readline library:
    10. 

  10.      NO_READLINE
    11. 

  11.    Termcap/ncurses library:
    12. 

  12.      NO_TERMCAP_NCURSES
    13. 

  13.    Internationalization:
    14. 

  14.      NO_GETTEXT, UNICODE
    15. 

  15.    Fault handling:
    16. 

  16.      NO_SIGSEGV
    17. 

  17.    Foreign function interface:
    18. 

  18.      DYNAMIC_FFI
    19. 

  19.    Dynamic loading of modules:
    20. 

  20.      DYNAMIC_MODULES
    21. 

  21.    Safety level:
    22. 

  22.      SAFETY={0,1,2,3}
    23. 

  23.    Exploit GCC global register variables:
    24. 

  24.      USE_GCC_REGISTER_VARIABLES
    25. 

  25.    Debugging (turned on by --with-debug configure option):
    26. 

  26.      DEBUG_GCSAFETY (requires G++)
    27. 

  27.      DEBUG_OS_ERROR
    28. 

  28.      DEBUG_SPVW
    29. 

  29.      DEBUG_BYTECODE
    30. 

  30.      DEBUG_BACKTRACE
    31. 

  31.      DEBUG_COMPILER
    32. 

  32.  Flags that may be set through CFLAGS, in order to override the defaults:
    33. 

  33.    Object representation (on 32-bit platforms only):
    34. 

  34.      TYPECODES, HEAPCODES, STANDARD_HEAPCODES, LINUX_NOEXEC_HEAPCODES, WIDE
    35. 

  35.    Advanced memory management:
    36. 

  36.      NO_SINGLEMAP, NO_TRIVIALMAP, NO_MULTIMAP_FILE, NO_MULTIMAP_SHM,
    37. 

  37.      NO_VIRTUAL_MEMORY, CONS_HEAP_GROWS_DOWN, CONS_HEAP_GROWS_UP,
    38. 

  38.      NO_MORRIS_GC, NO_GENERATIONAL_GC
    39. 

  39.    String representation:
    40. 

  40.      NO_SMALL_SSTRING
    41. 

    42. 

    43. 

  43.  Implementation is prepared for the following computers,
    44. 

  44.  operating systems and c-compilers
    45. 

  45.  (Only a rough listing, check the file PLATFORMS for further details.)
    46. 

  46.  Machine      Producer           Operating system              C-Compiler    recognized through
    47. 

  47.  AMIGA        Commodore          AMIGA-OS (AMIGADOS)           GNU           amiga or AMIGA, __GNUC__, maybe MC68000 or AMIGA3000
    48. 

  48.  any          any                UNIX                          GNU           unix, __GNUC__, ...
    49. 

  49.  any          any                UNIX                          CC            unix, ...
    50. 

  50.  Amiga 3000   Commodore          Amiga UNIX 2.1 SVR4.0         GNU           unix, __unix__, AMIX, __AMIX__, __svr4__, m68k, __m68k__, __motorola__, __GNUC__
    51. 

  51.  SUN-3        Sun                SUN-OS3 (UNIX BSD 4.2)        GNU           sun, unix, mc68020, __GNUC__
    52. 

  52.  SUN-3        Sun                SUN-OS4 (UNIX SUNOS 4.1)      GNU           sun, unix, mc68020, __GNUC__
    53. 

  53.  SUN-386      Sun                SUN-OS4 (UNIX SUNOS 4.0)      GNU           sun, unix, sun386, i386, __GNUC__
    54. 

  54.  SUN-386      Sun                SUN-OS4 (UNIX SUNOS 4.0)      CC            sun, unix, sun386, i386
    55. 

  55.  SUN-4        Sun                SUN-OS4 (UNIX SUNOS 4.1)      GNU           sun, unix, sparc, __GNUC__
    56. 

  56.  SUN-4        Sun                SUN-OS4 (UNIX SUNOS 4.1)      CC            sun, unix, sparc
    57. 

  57.  SUN-4        Sun                SUN-OS5 (UNIX Solaris)        GCC           sun, unix, sparc, __GNUC__
    58. 

  58.  UltraSparc   Sun                Solaris 7 (UNIX SUNOS 5.7)    CC            sun, unix, __sparc, __sparcv9
    59. 

  59.  UltraSparc   Sun                Solaris 7 (UNIX SUNOS 5.7)    GCC           sun, unix, __sparc, __arch64__, __GNUC__
    60. 

  60.  IBM-PC/386   any                SUN-OS5 (UNIX Solaris)        GCC           sun, unix, __svr4__, i386, __GNUC__
    61. 

  61.  HP9000-300   Hewlett-Packard    NetBSD 0.9 (UNIX BSD 4.3)     GNU           unix, __NetBSD__, mc68000, __GNUC__
    62. 

  62.  HP9000-300   Hewlett-Packard    HP-UX 8.0 (UNIX SYS V)        GNU           [__]hpux, [__]unix, [__]hp9000s300, mc68000, __GNUC__
    63. 

  63.  HP9000-800   Hewlett-Packard    HP-UX 8.0 (UNIX SYS V)        GNU           [__]hpux, [__]unix, [__]hp9000s800
    64. 

  64.  IRIS         Silicon Graphics   IRIX (UNIX SYS V 3.2)         GNU           unix, SVR3, mips, sgi, __GNUC__
    65. 

  65.  IRIS         Silicon Graphics   IRIX (UNIX SYS V)             cc -ansi      [__]unix, [__]SVR3, [__]mips, [__]sgi
    66. 

  66.  IRIS         Silicon Graphics   IRIX 5 (UNIX SYS V 4)         GNU           [__]unix, [__]SYSTYPE_SVR4, [__]mips, [__]host_mips, [__]MIPSEB, [__]sgi, __DSO__, [__]_MODERN_C, __GNUC__
    67. 

  67.  DECstation 5000                 RISC/OS (Ultrix V4.2A)        GNU           unix, [__]mips, [__]ultrix
    68. 

  68.  DG-UX 88k    Data General       DG/UX                         GNU           unix, m88000, DGUX
    69. 

  69.  DEC Alpha    DEC                OSF/1 1.3                     cc            [unix,] __unix__, __osf__, __alpha
    70. 

  70.  DEC Alpha    DEC                OSF/1 1.3                     GNU           unix, __unix__, __osf__, __alpha, __alpha__, _LONGLONG
    71. 

  71.  Apple MacII  Apple              A/UX (UNIX SYS V 2)           GNU           [__]unix, [__]AUX, [__]macII, [__]m68k, mc68020, mc68881, __GNUC__
    72. 

  72.  NeXT         NeXT               NeXTstep 3.1 (UNIX)           cc            NeXT, m68k
    73. 

  73.  PowerPC      Apple              Mach 3.0 + MkLinux            GNU           unix, __powerpc__, __PPC__, _ARCH_PPC, _CALL_SYSV, __ELF__, __linux__
    74. 

  74.  PowerPC      Apple              Mach + Rhapsody               cc            __MACH__, __APPLE__, __ppc[__], __GNUC__, __APPLE_CC__
    75. 

  75.  PowerPC      Apple              Mach + MacOS X                cc            __MACH__, __APPLE__, __ppc__, __GNUC__, __APPLE_CC__
    76. 

  76.  Sequent      Sequent            PTX 3.2.0 V2.1.0 i386 (SYS V) GNU           unix, i386, _SEQUENT_, __GNUC__
    77. 

  77.  Sequent      Sequent            PTX V4.1.3                    GNU           unix, i386, _SEQUENT_, __svr4__, __GNUC__
    78. 

  78.  Convex C2    Convex             ConvexOS 10.1                 GNU           __convex__, __GNUC__
    79. 

  79.  IBM RS/6000  IBM                AIX 3.2                       GNU           _AIX, _AIX32, _IBMR2, __CHAR_UNSIGNED__, __GNUC__
    80. 

  80.  IBM-PC/386   any                LINUX (free UNIX)             GNU           unix, linux, i386, __GNUC__
    81. 

  81.  IBM-PC/386   any                LINUX (free UNIX)             Intel 5.0     __unix__, __linux__, __INTEL_COMPILER, __ICC, __USLC__
    82. 

  82.  IBM-PC/386   any                386BSD 0.1 (UNIX BSD 4.2)     GNU           unix, __386BSD__, i386, __GNUC__
    83. 

  83.  IBM-PC/386   any                NetBSD 0.9 (UNIX BSD 4.3)     GNU           unix, __NetBSD__, i386, __GNUC__
    84. 

  84.  IBM-PC/386   any                FreeBSD 4.0 (UNIX BSD 4.4)    GNU           unix, __FreeBSD__, i386, __GNUC__
    85. 

  85.  IBM-PC/386   any                EMX 0.9c (UNIXlike on OS/2)   GNU           [unix,] i386, __GNUC__, __EMX__
    86. 

  86.  IBM-PC/386   any                Cygwin32 on WinNT/Win95       GNU           _WIN32, __WINNT__, __CYGWIN32__, __POSIX__, _X86_, i386, __GNUC__
    87. 

  87.  IBM-PC/386   any                Mingw32 on WinNT/Win95        GNU           _WIN32, __WINNT__, __MINGW32__, _X86_, i386, __GNUC__
    88. 

  88.  IBM-PC/386   any                WinNT/Win95                   MSVC          _WIN32, _M_IX86, _MSC_VER
    89. 

  89.  IBM-PC/386   any                WinNT/Win95                   Borland 5.0   __WIN32__, _M_IX86, __TURBOC__, __BORLANDC__
    90. 

  90.  IBM-PC/386   any                WinNT/Win95 and Cygwin32      GNU           _WIN32, __WINNT__, __CYGWIN32__, __POSIX__, __i386__, _X86_, __GNUC__
    91. 

  91.  IBM-PC/586   any                BeOS 5                        GNU           __BEOS__, __INTEL__, __i386__, _X86_, __GNUC__
    92. 

  92.  IBM-PC/586   any                HP NUE/ski, Linux             GNU           unix, linux, __ia64[__], __GNUC__, __LP64__
    93. 

  93.  RM400        Siemens-Nixdorf    SINIX-N 5.42                  c89           unix, mips, MIPSEB, host_mips, sinix, SNI, _XPG_IV
    94. 

  94.  Acorn        Risc PC            RISC OS 3.x                   GNU           [__]arm, [__]riscos, __GNUC__
    95. 

  95.  Acorn        Risc PC            RISC OS 3.x                   Norcroft      [__]arm, [__]riscos
    96. 

  96.  APPLE IIGS   Apple              ??                            ??
    97. 

  97.  For ANSI-C-Compiler: use pre-processors comment5, varbrace
    98. 

  98.    (and maybe gcc-cpp, ccpaux).
    99. 

    100. 

  100.  this machine: WIN32 or GENERIC_UNIX */
    101. 

  101. #if (defined(__unix) || defined(__unix__) || defined(_AIX) || defined(sinix) || defined(__MACH__) || defined(__POSIX__) || defined(__NetBSD__) || defined(__OpenBSD__) || defined(__BEOS__)) && !defined(unix)
    102. 

  102.   #define unix
    103. 

  103. #endif
    104. 

  104. #if (defined(_WIN32) && (defined(_MSC_VER) || defined(__MINGW32__))) || (defined(__WIN32__) && defined(__BORLANDC__))
    105. 

  105.   #undef WIN32                  /* because of __MINGW32__ */
    106. 

  106.   #define WIN32
    107. 

  107. #endif
    108. 

  108. #if !defined(WIN32)
    109. 

  109.   #if defined(unix)
    110. 

  110.     #define GENERIC_UNIX
    111. 

  111.   #else
    112. 

  112.     #error "Unknown machine type -- set machine again!"
    113. 

  113.   #endif
    114. 

  114. #endif
    115. 

  115. /* additional specification of the machine: */
    116. 

  116. #if defined(WIN32)
    117. 

  117.   /* declare availability of typical PC facilities,
    118. 

  118.    like a console with a graphics mode that differs from the text mode,
    119. 

  119.    or a keyboard with function keys F1..F12. */
    120. 

  120.   #define PC386 /* IBMPC-compatible with 80386/80486-processor */
    121. 

  121. #endif
    122. 

  122. #ifdef GENERIC_UNIX
    123. 

  123.   #if (defined(sun) && defined(unix) && defined(sun386))
    124. 

  124.     #define SUN386
    125. 

  125.   #endif
    126. 

  126.   #if (defined(unix) && (defined(linux) || defined(__CYGWIN32__) || defined(__FreeBSD__) || defined(__NetBSD__) || defined(__OpenBSD__) || defined(__DragonFly__)) && (defined(i386) || defined(__i386__) || defined(__x86_64__) || defined(__amd64__)))
    127. 

  127.     #define PC386
    128. 

  128.   #endif
    129. 

  129.   #if (defined(sun) && defined(unix) && defined(mc68020))
    130. 

  130.     #define SUN3
    131. 

  131.   #endif
    132. 

  132.   #if (defined(sun) && defined(unix) && defined(sparc))
    133. 

  133.     #define SUN4
    134. 

  134.   #endif
    135. 

  135.   #if defined(sparc) || defined(__sparc__)
    136. 

  136.     /* maybe SUN4_29 if only addresses <2^29 are supported */
    137. 

  137.   #endif
    138. 

  138.   #if defined(hp9000s800) || defined(__hp9000s800)
    139. 

  139.     #define HP8XX
    140. 

  140.   #endif
    141. 

  141. #endif
    142. 

  142. 

  143. /* Determine the processor:
    144. 

  144.  MC680X0 == all processors of the Motorola 68000 series
    145. 

  145.  MC680Y0 == all processors of the Motorola 68000 series, starting at MC68020
    146. 

  146.  SPARC == the Sun SPARC processor
    147. 

  147.  HPPA == all processors of the HP Precision Architecture
    148. 

  148.  MIPS == all processors of the MIPS series
    149. 

  149.  M88000 == all processors of the Motorola 88000 series
    150. 

  150.  POWERPC == the IBM RS/6000 and PowerPC processor family
    151. 

  151.  I80386 == all processors of the Intel 8086 series, starting at 80386,
    152. 

  152.            nowadays called IA32
    153. 

  153.  VAX == the VAX processor
    154. 

  154.  ARM == the ARM processor
    155. 

  155.  DECALPHA == the DEC Alpha superchip
    156. 

  156.  IA64 == the Intel IA-64 latecomer chip
    157. 

  157.  AMD64 == the AMD hammer chip
    158. 

  158.  S390 == the IBM S/390 processor */
    159. 

  159. #if defined(__vax__)
    160. 

  160.   #define VAX
    161. 

  161. #endif
    162. 

  162. #if defined(arm) || defined(__arm) || defined(__arm__)
    163. 

  163.   #define ARM
    164. 

  164. #endif
    165. 

  165. #ifdef WIN32
    166. 

  166.   #if defined(_M_IX86) || defined(_X86_)
    167. 

  167.     #define I80386
    168. 

  168.   #endif
    169. 

  169. #endif
    170. 

  170. #ifdef GENERIC_UNIX
    171. 

  171.   #if defined(m68k) || defined(__m68k__) || defined(mc68000)
    172. 

  172.     #define MC680X0
    173. 

  173.   #endif
    174. 

  174.   #if defined(mc68020) || defined(__mc68020__) || (defined(m68k) && defined(NeXT))
    175. 

  175.     #define MC680X0
    176. 

  176.     #define MC680Y0
    177. 

  177.   #endif
    178. 

  178.   #if defined(i386) || defined(__i386) || defined(__i386__) || defined(_I386)
    179. 

  179.     #define I80386
    180. 

  180.   #endif
    181. 

  181.   #if defined(sparc) || defined(__sparc__)
    182. 

  182.     #define SPARC
    183. 

  183.     #if defined(__sparcv9) || defined(__arch64__)
    184. 

  184.       #define SPARC64
    185. 

  185.     #endif
    186. 

  186.   #endif
    187. 

  187.   #if defined(mips) || defined(__mips) || defined(__mips__)
    188. 

  188.     #define MIPS
    189. 

  189.     #if defined(_MIPS_SZLONG)
    190. 

  190.       #if (_MIPS_SZLONG == 64)
    191. 

  191.         /* We should also check for (_MIPS_SZPTR == 64), but gcc keeps this at 32. */
    192. 

  192.         #define MIPS64
    193. 

  193.       #endif
    194. 

  194.     #endif
    195. 

  195.   #endif
    196. 

  196.   #if defined(HP8XX) || defined(hppa) || defined(__hppa) || defined(__hppa__)
    197. 

  197.     #define HPPA
    198. 

  198.   #endif
    199. 

  199.   #if defined(m88000) || defined(__m88k__)
    200. 

  200.     #define M88000
    201. 

  201.   #endif
    202. 

  202.   #if defined(_IBMR2) || defined(__powerpc) || defined(__ppc) || defined(__ppc__) || defined(__powerpc__)
    203. 

  203.     #define POWERPC
    204. 

  204.   #endif
    205. 

  205.   #ifdef __alpha
    206. 

  206.     #define DECALPHA
    207. 

  207.   #endif
    208. 

  208.   #ifdef __ia64__
    209. 

  209.     #define IA64
    210. 

  210.   #endif
    211. 

  211.   #if defined(__x86_64__) || defined(__amd64__)
    212. 

  212.     #define AMD64
    213. 

  213.   #endif
    214. 

  214.   #ifdef __s390__
    215. 

  215.     #define S390
    216. 

  216.   #endif
    217. 

  217. #endif
    218. 

  218. 

  219. 

  220. /* Selection of the operating system */
    221. 

  221. #ifdef WIN32
    222. 

  222.   /* Windows NT, Windows 95 */
    223. 

  223.   #define WIN32_NATIVE  /* native NT API, no DOS calls */
    224. 

  224. #endif
    225. 

  225. #ifdef GENERIC_UNIX
    226. 

  226.   #define UNIX
    227. 

  227.   #ifdef __linux__
    228. 

  228.     #define UNIX_LINUX  /* Linux (Linus Torvalds Unix) */
    229. 

  229.   #endif
    230. 

  230.   #ifdef __GNU__
    231. 

  231.     #define UNIX_HURD  /* the GNU system (Hurd + glibc) */
    232. 

  232.   #endif
    233. 

  233.   #ifdef __NetBSD__
    234. 

  234.     #define UNIX_NETBSD
    235. 

  235.   #endif
    236. 

  236.   #if defined(__FreeBSD__) || defined(__DragonFly__)
    237. 

  237.     /* FreeBSD or its fork called DragonFly BSD. */
    238. 

  238.     #define UNIX_FREEBSD
    239. 

  239.   #endif
    240. 

  240.   #ifdef __OpenBSD__
    241. 

  241.     #define UNIX_OPENBSD
    242. 

  242.   #endif
    243. 

  243.   #if defined(hpux) || defined(__hpux)
    244. 

  244.     #define UNIX_HPUX  /* HP-UX */
    245. 

  245.   #endif
    246. 

  246.   #if defined(SVR3) || defined(__SVR3) || defined(SVR4) || defined(__SVR4) || defined(SYSTYPE_SVR4) || defined(__SYSTYPE_SVR4) || defined(__svr4__) || defined(USG) || defined(UNIX_HPUX) /* ?? */
    247. 

  247.     #define UNIX_SYSV  /* UNIX System V */
    248. 

  248.   #endif
    249. 

  249.   #if defined(UNIX_SYSV) && (defined(sgi) || defined(__sgi))
    250. 

  250.     #define UNIX_IRIX  /* Irix */
    251. 

  251.     #if defined(SYSTYPE_SVR4) || defined(__SYSTYPE_SVR4)
    252. 

  252.       #define UNIX_IRIX5  /* Irix 5 */
    253. 

  253.     #endif
    254. 

  254.   #endif
    255. 

  255.   #if defined(MIPS) && (defined(ultrix) || defined(__ultrix))
    256. 

  256.     #define UNIX_DEC_ULTRIX  /* DEC's (or IBM's ?) RISC/OS Ultrix on DEC MIPS */
    257. 

  257.     #ifdef __GNUC__
    258. 

  258.       #define UNIX_DEC_ULTRIX_GCCBUG  /* work around a bug in GCC 2.3.3 */
    259. 

  259.     #endif
    260. 

  260.   #endif
    261. 

  261.   #if defined(MIPS) && defined(sinix) /* && defined(SNI) */
    262. 

  262.     #define UNIX_SINIX /* Siemens is nix */
    263. 

  263.   #endif
    264. 

  264.   #if defined(USL) || (defined(__svr4__) && defined(I80386) && !defined(__sun))
    265. 

  265.     /* A couple of Unices for 386s (all running under different names)
    266. 

  266.      derive from USL SysV R 4:
    267. 

  267.        386 UHC UNIX System V release 4
    268. 

  268.        Consensys System V 4.2
    269. 

  269.        Onsite System V 4.2
    270. 

  270.        SINIX-Z
    271. 

  271.        DYNIX/ptx V4.1.3
    272. 

  272.        SunOS 5 */
    273. 

  273.     #define UNIX_SYSV_USL  /* Unix System V R 4 by AT&T's subsidiary USL */
    274. 

  274.     #define UNIX_SYSV_UHC_1 /* treat like HPPA && UNIX_HPUX */
    275. 

  275.     #ifdef SNI
    276. 

  276.       #define UNIX_SINIX /* Siemens is nix */
    277. 

  277.     #endif
    278. 

  278.   #endif
    279. 

  279.   #if defined(_SEQUENT_) && !defined(__svr4__)
    280. 

  280.     #define UNIX_SYSV_PTX  /* Dynix/ptx v. 2 or 3 */
    281. 

  281.   #endif
    282. 

  282.   #ifdef _AIX
    283. 

  283.     #define UNIX_AIX  /* IBM AIX */
    284. 

  284.   #endif
    285. 

  285.   #ifdef DGUX
    286. 

  286.     #define UNIX_DGUX  /* Data General DG/UX */
    287. 

  287.   #endif
    288. 

  288.   #ifdef __osf__
    289. 

  289.     #define UNIX_OSF  /* OSF/1 */
    290. 

  290.   #endif
    291. 

  291.   #ifdef AUX
    292. 

  292.     #define UNIX_AUX  /* Apple A/UX, a spiced-up SVR2 */
    293. 

  293.   #endif
    294. 

  294.   #ifdef NeXT
    295. 

  295.     #define UNIX_NEXTSTEP  /* NeXTstep */
    296. 

  296.   #endif
    297. 

  297.   #if defined(__APPLE__) && defined(__MACH__)
    298. 

  298.     #define UNIX_MACOSX  /* MacOS X */
    299. 

  299.   #endif
    300. 

  300.   #ifdef AMIX
    301. 

  301.     #define UNIX_AMIX  /* Amiga UNIX */
    302. 

  302.   #endif
    303. 

  303.   #ifdef __CYGWIN32__
    304. 

  304.     #define UNIX_CYGWIN32  /* Cygwin32 (UNIXlike on WinNT/Win95) */
    305. 

  305.   #endif
    306. 

  306.   #ifdef __BEOS__
    307. 

  307.     #define UNIX_BEOS  /* BeOS (UNIXlike) */
    308. 

  308.   #endif
    309. 

  309. #endif
    310. 

  310. %% #ifdef WIN32_NATIVE
    311. 

  311. %%   puts("#define WIN32_NATIVE");
    312. 

  312. %% #endif
    313. 

  313. %% #ifdef UNIX
    314. 

  314. %%   puts("#define UNIX");
    315. 

  315. %% #endif
    316. 

  316. 

  317. 

  318. /* Determine properties of compiler and environment: */
    319. 

  319. #if defined(UNIX) || defined(__MINGW32__)
    320. 

  320.   #include "config.h"  /* configuration generated by configure */
    321. 

  321.   #include "intparam.h"  /* integer-type characteristics created by the machine */
    322. 

  322.   #include "floatparam.h" /* floating-point type characteristics */
    323. 

  323. #elif defined(WIN32) && !defined(__MINGW32__)
    324. 

  324.   #include "version.h"          /* defines PACKAGE_* */
    325. 

  325.   #define char_bitsize 8
    326. 

  326.   #define short_bitsize 16
    327. 

  327.   #define int_bitsize 32
    328. 

  328.   #if defined(I80386)
    329. 

  329.     #define long_bitsize 32
    330. 

  330.   #elif defined(DECALPHA)
    331. 

  331.     #define long_bitsize 64
    332. 

  332.   #endif
    333. 

  333.   #if defined(I80386)
    334. 

  334.     #define pointer_bitsize 32
    335. 

  335.   #elif defined(DECALPHA)
    336. 

  336.     #define pointer_bitsize 64
    337. 

  337.   #endif
    338. 

  338.   #define alignment_long 4
    339. 

  339.   #if defined(I80386) || defined(VAX) || defined(ARM) || defined(DECALPHA)
    340. 

  340.     #define short_little_endian
    341. 

  341.     #define long_little_endian
    342. 

  342.   #endif
    343. 

  343.   #define stack_grows_down
    344. 

  344.   #define CODE_ADDRESS_RANGE 0
    345. 

  345.   #define MALLOC_ADDRESS_RANGE 0
    346. 

  346.   #define SHLIB_ADDRESS_RANGE 0
    347. 

  347.   #define STACK_ADDRESS_RANGE ~0UL
    348. 

  348.   #define ICONV_CONST
    349. 

  349. #else
    350. 

  350.   #error "where is the configuration for your platform?"
    351. 

  351. #endif
    352. 

  352. 

  353. 

  354. /* A more precise classification of the operating system: */
    355. 

  355. #if defined(UNIX) && defined(SIGNALBLOCK_BSD) && !defined(SIGNALBLOCK_SYSV)
    356. 

  356.   #define UNIX_BSD  /* BSD Unix */
    357. 

  357. #endif
    358. 

  358. #if (defined(SUN3) || defined(SUN386) || defined(SUN4)) && defined(HAVE_MMAP) && defined(HAVE_VADVISE)
    359. 

  359.   #define UNIX_SUNOS4  /* Sun OS Version 4 */
    360. 

  360. #endif
    361. 

  361. #if (defined(SUN4) || (defined(I80386) && defined(__svr4__) && defined(__sun))) && !defined(HAVE_VADVISE) /* && !defined(HAVE_GETPAGESIZE) */
    362. 

  362.   #define UNIX_SUNOS5  /* Sun OS Version 5.[1-5] (Solaris 2) */
    363. 

  363. #endif
    364. 

  364. #if defined(UNIX_MACOSX) && !defined(HAVE_MSYNC)
    365. 

  365.   #define UNIX_RHAPSODY  /* MacOS X Server, a.k.a. Rhapsody */
    366. 

  366. #endif
    367. 

  367. #if defined(UNIX_MACOSX) && defined(HAVE_MSYNC)
    368. 

  368.   #define UNIX_DARWIN  /* MacOS X, a.k.a. Darwin */
    369. 

  369. #endif
    370. 

  370. 

  371. 

  372. /* Choose the character set: */
    373. 

  373. #if defined(UNIX) || defined(WIN32)
    374. 

  374.   #define ISOLATIN_CHS  /* ISO 8859-1, see isolatin.chs */
    375. 

  375.   /* Most Unix systems today support the ISO Latin-1 character set, in
    376. 

  376.    particular because they have X11 and the X11 fonts are in ISO Latin-1.
    377. 

  377.    Exceptions below.
    378. 

  378.    On Win32, the standard character set is ISO-8859-1. Only the DOS box
    379. 

  379.    displays CP437, but we convert from ISO-8859-1 to CP437 in the
    380. 

  380.    low-level output routine full_write(). */
    381. 

  381. #endif
    382. 

  382. #ifdef UNIX_BEOS
    383. 

  383.   /* The default encoding on BeOS is UTF-8, not ISO 8859-1.
    384. 

  384.    If compiling with Unicode support, we use it. Else fall back to ASCII. */
    385. 

  385.   #undef ISOLATIN_CHS
    386. 

  386.   #ifdef UNICODE
    387. 

  387.     #define UTF8_CHS  /* UTF-8 */
    388. 

  388.   #endif
    389. 

  389. #endif
    390. 

  390. #ifdef HP8XX
    391. 

  391.   #undef ISOLATIN_CHS
    392. 

  392.   #define HPROMAN8_CHS  /* HP-Roman8, see hproman8.chs */
    393. 

  393.   /* under X-Term however: #define ISOLATIN_CHS ?? */
    394. 

  394. #endif
    395. 

  395. #ifdef UNIX_NEXTSTEP
    396. 

  396.   #undef ISOLATIN_CHS
    397. 

  397.   #define NEXTSTEP_CHS  /* NeXTstep, see nextstep.chs */
    398. 

  398. #endif
    399. 

  399. #if !(defined(ISOLATIN_CHS) || defined(HPROMAN8_CHS) || defined(NEXTSTEP_CHS))
    400. 

  400.   #define ASCII_CHS  /* Default: plain ASCII charset without special chars */
    401. 

  401. #endif
    402. 

  402. 

  403. 

  404. /* Choose the compiler: */
    405. 

  405. #if defined(__GNUC__)
    406. 

  406.   #define GNU
    407. 

  407. #endif
    408. 

  408. #if defined(__STDC__) || defined(__BORLANDC__) || defined(__cplusplus)
    409. 

  409.   /* ANSI C compilers define __STDC__ (but some define __STDC__=0 !).
    410. 

  410.    Borland C has an ANSI preprocessor and compiler, but fails to define
    411. 

  411.    __STDC__.
    412. 

  412.    HP aCC is an example of a C++ compiler which defines __cplusplus but
    413. 

  413.    not __STDC__. */
    414. 

  414.   #define ANSI
    415. 

  415. #endif
    416. 

  416. #if defined(_MSC_VER)
    417. 

  417.   #define MICROSOFT
    418. 

  418. #endif
    419. 

  419. #if defined(__BORLANDC__)
    420. 

  420.   #define BORLAND
    421. 

  421. #endif
    422. 

  422. #if defined(__INTEL_COMPILER)
    423. 

  423.   #define INTEL
    424. 

  424. #endif
    425. 

  425. 

  426. 

  427. /* Selection of floating-point capabilities:
    428. 

  428.  FAST_DOUBLE should be defined if there is a floating-point coprocessor
    429. 

  429.  with a 'double'-type IEEE-Floating-Points with 64 Bits.
    430. 

  430.  FAST_FLOAT should be defined if there is a floating-point co-processor
    431. 

  431.  with a 'float'-type IEEE-Floating-Points with 32 Bits,
    432. 

  432.  and a C-Compiler that generates 'float'-operations
    433. 

  433.  instead of 'double'-operations */
    434. 

  434. #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)
    435. 

  435.   #define FAST_FLOAT
    436. 

  436. #endif
    437. 

  437. #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)
    438. 

  438.   #define FAST_DOUBLE
    439. 

  439. #endif
    440. 

  440. #ifdef ARM
    441. 

  441.   /* The processor is little-endian w.r.t. integer types but stores 'double'
    442. 

  442.    floats in big-endian word order! */
    443. 

  443.   #undef FAST_DOUBLE
    444. 

  444. #endif
    445. 

  445. #ifdef NO_FAST_DOUBLE
    446. 

  446.   #undef FAST_DOUBLE
    447. 

  447. #endif
    448. 

  448. #ifdef NO_FAST_FLOAT
    449. 

  449.   #undef FAST_FLOAT
    450. 

  450. #endif
    451. 

  451. 

  452. 

  453. /* Selection of the language: */
    454. 

  454. #ifdef ENGLISH
    455. 

  455.   #undef ENGLISH
    456. 

  456.   #define ENGLISH 1
    457. 

  457.   #define LANGUAGE_STATIC
    458. 

  458. #endif
    459. 

  459. 

  460. 

  461. /* Selection of the safety-level:
    462. 

  462.  SAFETY=0 : all optimizations are turned on
    463. 

  463.  SAFETY=1 : all optimizations on, but keep STACKCHECKs
    464. 

  464.  SAFETY=2 : only simple assembler-support
    465. 

  465.  SAFETY=3 : no optimizations */
    466. 

  466. #ifndef SAFETY
    467. 

  467.   #define SAFETY 0
    468. 

  468. #endif
    469. 

  469. #if SAFETY >= 3
    470. 

  470.   #define NO_ASM
    471. 

  471.   #define NO_ARI_ASM
    472. 

  472.   #define NO_FAST_DISPATCH
    473. 

  473. #endif
    474. 

  474. 

  475. /* We don't support pre-ANSI-C compilers any more. */
    476. 

  476. #if !defined(ANSI)
    477. 

  477.   #error "An ANSI C or C++ compiler is required to compile CLISP!"
    478. 

  478. #endif
    479. 

  479. 

  480. /* gcc-2.7.2 has a bug: it interpretes `const' as meaning `not modified by
    481. 

  481.  other parts of the program', and thus miscompiles at least justify_empty_2
    482. 

  482.  and pr_enter_1 in io.d. */
    483. 

  483. #if defined(GNU) && (__GNUC__ == 2) && (__GNUC_MINOR__ == 7)
    484. 

  484.   #undef const
    485. 

  485.   #define const
    486. 

  486.   #define __const const
    487. 

  487.   /* We define __const to const, not to empty, to avoid warnings on
    488. 

  488.    UNIX_RHAPSODY, which unconditionally defines __const to const when
    489. 

  489.    <sys/cdefs.h> is included via <setjmp.h> below. */
    490. 

  490.   #ifdef MULTITHREAD
    491. 

  491.     #warning "Multithreading will not be efficient because of a workaround to a gcc bug."
    492. 

  492.     #warning "Get a newer version of gcc."
    493. 

  493.   #endif
    494. 

  494. #endif
    495. 

  495. 

  496. /* A property of the processor:
    497. 

  497.  The sequence in which words/long-words are being put into bytes */
    498. 

  498. #if defined(short_little_endian) || defined(int_little_endian) || defined(long_little_endian)
    499. 

  499.   /* Z80, VAX, I80386, DECALPHA, MIPSEL, IA64, AMD64, ...:
    500. 

  500.    Low Byte is the lowest, High Byte in a higher address */
    501. 

  501.   #if defined(BIG_ENDIAN_P)
    502. 

  502.     #error "Bogus BIG_ENDIAN_P -- set BIG_ENDIAN_P again!"
    503. 

  503.   #endif
    504. 

  504.   #define BIG_ENDIAN_P  0
    505. 

  505. #endif
    506. 

  506. #if defined(short_big_endian) || defined(int_big_endian) || defined(long_big_endian)
    507. 

  507.   /* MC680X0, SPARC, HPPA, MIPSEB, M88000, POWERPC, S390, ...:
    508. 

  508.    High Byte is the lowest, Low Byte is a higher adress (easier to read) */
    509. 

  509.   #if defined(BIG_ENDIAN_P)
    510. 

  510.     #error "Bogus BIG_ENDIAN_P -- set BIG_ENDIAN_P again"
    511. 

  511.   #endif
    512. 

  512.   #define BIG_ENDIAN_P  1
    513. 

  513. #endif
    514. 

  514. #if !defined(BIG_ENDIAN_P)
    515. 

  515.   #error "Bogus BIG_ENDIAN_P -- set BIG_ENDIAN_P again!"
    516. 

  516. #endif
    517. 

  517. %% export_def(BIG_ENDIAN_P);
    518. 

  518. 

  519. /* A property of the processor (and C compiler): The alignment of C functions.
    520. 

  520.  (See gcc's machine descriptions, macro FUNCTION_BOUNDARY, for information.) */
    521. 

  521. #if defined(IA64)
    522. 

  522.   #define C_CODE_ALIGNMENT  16
    523. 

  523.   #define log2_C_CODE_ALIGNMENT  4
    524. 

  524. #endif
    525. 

  525. #if defined(DECALPHA)
    526. 

  526.   #define C_CODE_ALIGNMENT  8
    527. 

  527.   #define log2_C_CODE_ALIGNMENT  3
    528. 

  528. #endif
    529. 

  529. #if (defined(I80386) && defined(GNU)) || defined(SPARC) || defined(MIPS) || defined(M88000) || defined(POWERPC) || defined(ARM) || defined(AMD64) || defined(S390)
    530. 

  530.   /* When using gcc on i386, this assumes that -malign-functions has not been
    531. 

  531.    used to specify an alignment smaller than 4 bytes. */
    532. 

  532.   #define C_CODE_ALIGNMENT  4
    533. 

  533.   #define log2_C_CODE_ALIGNMENT  2
    534. 

  534. #endif
    535. 

  535. #if defined(HPPA)
    536. 

  536.   /* A function pointer on hppa is either
    537. 

  537.      - a code pointer == 0 mod 4, or
    538. 

  538.      - a pointer to a two-word structure (first word: a code pointer,
    539. 

  539.        second word: a value which will be put in register %r19),
    540. 

  540.        incremented by 2, hence == 2 mod 4.
    541. 

  541.    The current compilers only emit the second kind of function pointers,
    542. 

  542.    hence we can assume that all function pointers are == 2 mod 4. */
    543. 

  543.   #define C_CODE_ALIGNMENT  2
    544. 

  544.   #define log2_C_CODE_ALIGNMENT  1
    545. 

  545. #endif
    546. 

  546. #if defined(MC680X0)
    547. 

  547.   #define C_CODE_ALIGNMENT  2
    548. 

  548.   #define log2_C_CODE_ALIGNMENT  1
    549. 

  549. #endif
    550. 

  550. #if !defined(C_CODE_ALIGNMENT) /* e.g. (defined(I80386) && defined(MICROSOFT)) */
    551. 

  551.   #define C_CODE_ALIGNMENT  1
    552. 

  552.   #define log2_C_CODE_ALIGNMENT  0
    553. 

  553. #endif
    554. 

  554. 

  555. 

  556. /* Flags for the system's include files. */
    557. 

  557. #ifdef MULTITHREAD
    558. 

  558.   #if defined(UNIX_GNU) || defined(UNIX_SUNOS5)
    559. 

  559.     #define _REENTRANT
    560. 

  560.   #endif
    561. 

  561.   #if defined(__GNUC__)
    562. 

  562.     #define per_thread __thread
    563. 

  563.   #else
    564. 

  564.     #error "how does your compiler specify per-thread storage class?"
    565. 

  565.   #endif
    566. 

  566. #else
    567. 

  567.   #define per_thread
    568. 

  568. #endif
    569. 

  569. 

  570. 

  571. /* Width of object representation:
    572. 

  572.  WIDE means than an object (pointer) occupies 64 bits (instead of 32 bits).
    573. 

  573.  WIDE_HARD means on a 64-bit platform.
    574. 

  574.  WIDE_SOFT means on a 32-bit platform, each object pointer occupies 2 words.
    575. 

  575.  WIDE_AUXI means on a 32-bit platform, each object occupies 2 words, the
    576. 

  576.            pointer and some auxiliary word. */
    577. 

  577. 

  578. #if defined(DECALPHA) || defined(MIPS64) || defined(SPARC64) || defined(IA64) || defined(AMD64)
    579. 

  579.   #define WIDE_HARD
    580. 

  580. #endif
    581. 

  581. 

  582. #if defined(WIDE_SOFT_LARGEFIXNUM) && !defined(WIDE_SOFT)
    583. 

  583.   #define WIDE_SOFT
    584. 

  584. #endif
    585. 

  585. 

  586. #if defined(WIDE) && !(defined(WIDE_HARD) || defined(WIDE_SOFT) || defined(WIDE_AUXI))
    587. 

  587.   #define WIDE_SOFT
    588. 

  588. #endif
    589. 

  589. #if (defined(WIDE_HARD) || defined(WIDE_SOFT) || defined(WIDE_AUXI)) && !defined(WIDE)
    590. 

  590.   #define WIDE
    591. 

  591. #endif
    592. 

  592. /* Now: defined(WIDE) == defined(WIDE_HARD) || defined(WIDE_SOFT) || defined(WIDE_AUXI) */
    593. 

  593. 

  594. 

  595. /* Global register declarations.
    596. 

  596.    Speed benefit: Just putting the STACK into a register, brought 5% of speed
    597. 

  597.    around 1992. Now, with an AMD Athlon CPU from 2000, with good caches, it
    598. 

  598.    still brings 4%.
    599. 

  599.    The declarations must occur before any system include files define any
    600. 

  600.    inline function, which is the case on UNIX_DGUX and UNIX_GNU.
    601. 

  601.    Only GCC supports global register variables. Not Apple's variant of GCC.
    602. 

  602.    And only the C frontend, not the C++ frontend, understands the syntax.
    603. 

  603.    And gcc-3.0 to 3.3.3 has severe bugs with global register variables, see
    604. 

  604.    CLISP bugs 710737 and 723097 and
    605. 

  605.    http://gcc.gnu.org/bugzilla/show_bug.cgi?id=7871
    606. 

  606.    http://gcc.gnu.org/bugzilla/show_bug.cgi?id=10684
    607. 

  607.    http://gcc.gnu.org/bugzilla/show_bug.cgi?id=14937
    608. 

  608.    http://gcc.gnu.org/bugzilla/show_bug.cgi?id=14938
    609. 

  609.    Likewise, gcc-4.2 has severe bugs with global register variables, see
    610. 

  610.    CLISP bug 1836142 and http://gcc.gnu.org/bugzilla/show_bug.cgi?id=34300
    611. 

  611.    Likewise for gcc-4.3-20080215 and probably future versions of GCC as well.
    612. 

  612.    Therefore for these versions of gcc enable the global register variables
    613. 

  613.    only when USE_GCC_REGISTER_VARIABLES is explicitly defined.  */
    614. 

  614. #if defined(GNU) && !(__APPLE_CC__ > 1) && !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)
    615. 

  615. /* Overview of use of registers in gcc terminology:
    616. 

  616.  fixed: mentioned in FIXED_REGISTERS
    617. 

  617.  used:  mentioned in CALL_USED_REGISTERS but not FIXED_REGISTERS
    618. 

  618.                      (i.e. caller-saved)
    619. 

  619.  save:  otherwise (i.e. call-preserved, callee-saved)
    620. 

    621. 

  621.                STACK    mv_count  value1   back_trace
    622. 

  622.  MC680X0       used
    623. 

  623.  I80386        save
    624. 

  624.  SPARC (gcc2)  fixed    fixed     fixed    used
    625. 

  625.  MIPS
    626. 

  626.  HPPA          save     save      save     save
    627. 

  627.  M88000        save     save      save
    628. 

  628.  ARM           save
    629. 

  629.  DECALPHA      save     save      save
    630. 

  630.  IA64
    631. 

  631.  AMD64
    632. 

  632.  S390          save
    633. 

    634. 

  634.  Special notes:
    635. 

  635.  - gcc3/Sparc (Linux & Solaris) handles registers differently from gcc2. FIXME
    636. 

  636.  - If STACK is in a "used"/"save" register, it needs to be saved into
    637. 

  637.    saved_STACK upon begin_call(), so that asynchronous interrupts will
    638. 

  638.    be able to restore it.
    639. 

  639.  - All of the "used" registers need to be backed up upon begin_call()
    640. 

  640.    and restored during end_call().
    641. 

  641.  - All of the "save" registers need to be backed up upon begin_callback()
    642. 

  642.    and restored during end_callback().
    643. 

  643.  - When the interpreter does a longjmp(), the registers STACK, mv_count,
    644. 

  644.    value1 may need to be temporarily saved. This is highly machine
    645. 

  645.    dependent and is indicated by the NEED_temp_xxxx macros.
    646. 

    647. 

  647.    * Register for STACK. */
    648. 

  648.   #if defined(MC680X0)
    649. 

  649.     #define STACK_register "a4" /* highest address register after sp=A7,fp=A6/A5 */
    650. 

  650.   #endif
    651. 

  651.   #if defined(I80386) && !defined(UNIX_BEOS) && !defined(DYNAMIC_MODULES)
    652. 

  652.     /* On BeOS, everything is compiled as PIC, hence %ebx is already booked.
    653. 

  653.      If DYNAMIC_MODULES is defined, external modules are compiled as PIC,
    654. 

  654.      which is why %ebx is already in use. */
    655. 

  655.     #if (__GNUC__ >= 2) /* The register names have changed */
    656. 

  656.       #define STACK_register  "%ebx"  /* one of the call-saved registers without special hardware commands */
    657. 

  657.     #else
    658. 

  658.       #define STACK_register  "bx"
    659. 

  659.     #endif
    660. 

  660.   #endif
    661. 

  661.   #if defined(SPARC)
    662. 

  662.     #define STACK_register  "%g5"  /* a global register */
    663. 

  663.   #endif
    664. 

  664.   #if defined(HPPA) && (__GNUC__*100 + __GNUC_MINOR__ >= 2*100+7) /* gcc versions earlier than 2.7 had bugs */
    665. 

  665.     #define STACK_register  "%r10"  /* one of the general registers %r5..%r18 */
    666. 

  666.   #endif
    667. 

  667.   #if defined(M88000)
    668. 

  668.     #define STACK_register  "%r14"  /* one of the general registers %r14..%r25 */
    669. 

  669.   #endif
    670. 

  670.   #if defined(ARM)
    671. 

  671.     #define STACK_register  "%r8"   /* one of the general registers %r4..%r8 */
    672. 

  672.   #endif
    673. 

  673.   #if defined(DECALPHA)
    674. 

  674.     #define STACK_register  "$9"    /* one of the general registers $9..$14 */
    675. 

  675.   #endif
    676. 

  676.   #if defined(S390) && ((__GNUC__ > 3) || ((__GNUC__ == 3) && (__GNUC_MINOR__ >= 1)))
    677. 

  677.     /* global register assignment did not work on s390 until gcc 3.1 */
    678. 

  678.     #define STACK_register  "9"     /* one of the general registers %r8..%r9 */
    679. 

  679.   #endif
    680. 

  680.   /* What about NEED_temp_STACK ?? Needed if STACK is in a "used" register??
    681. 

  681.    Register for mv_count. */
    682. 

  682.   #if defined(SPARC)
    683. 

  683.     #define mv_count_register  "%g6"
    684. 

  684.     #if defined(UNIX_NETBSD)
    685. 

  685.       #define NEED_temp_mv_count
    686. 

  686.     #endif
    687. 

  687.   #endif
    688. 

  688.   #if defined(HPPA)
    689. 

  689.     #define mv_count_register  "%r11"  /* one of the general registers %r5..%r18 */
    690. 

  690.     #define NEED_temp_mv_count
    691. 

  691.   #endif
    692. 

  692.   #if defined(M88000)
    693. 

  693.     #define mv_count_register  "%r15" /* one of the general registers %r14..%r25 */
    694. 

  694.     #define NEED_temp_mv_count
    695. 

  695.   #endif
    696. 

  696.   #if defined(DECALPHA)
    697. 

  697.     #define mv_count_register  "$10"  /* one of the general registers $9..$14 */
    698. 

  698.     #define NEED_temp_mv_count
    699. 

  699.   #endif
    700. 

  700.   /* Register for value1. */
    701. 

  701.   #if !(defined(WIDE) && !defined(WIDE_HARD))
    702. 

  702.     #if defined(SPARC)
    703. 

  703.       #define value1_register  "%g7"
    704. 

  704.       #if defined(UNIX_NETBSD)
    705. 

  705.         #define NEED_temp_value1
    706. 

  706.       #endif
    707. 

  707.     #endif
    708. 

  708.     #if defined(HPPA)
    709. 

  709.       #define value1_register  "%r12"  /* one of the general registers %r5..%r18 */
    710. 

  710.       #define NEED_temp_value1
    711. 

  711.     #endif
    712. 

  712.     #if defined(M88000)
    713. 

  713.       #define value1_register  "%r16"  /* one of the general registers %r14..%r25 */
    714. 

  714.       #define NEED_temp_value1
    715. 

  715.     #endif
    716. 

  716.     #if defined(DECALPHA)
    717. 

  717.       #define value1_register  "$11"  /* one of the general registers $9..$14 */
    718. 

  718.       #define NEED_temp_value1
    719. 

  719.     #endif
    720. 

  720.   #endif
    721. 

  721.   /* Register for back_trace. */
    722. 

  722.   #if !(defined(WIDE) && !defined(WIDE_HARD))
    723. 

  723.     #if defined(SPARC)
    724. 

  724.       #define back_trace_register  "%g4"  /* a global register */
    725. 

  725.       /* %g4 seems to be a scratch-register as of lately with gcc 2.3
    726. 

  726.        This causes problems with libc.so.1.6.1 (and higher) (in getwd())
    727. 

  727.        That's why HAVE_SAVED_back_trace has been defined above. */
    728. 

  728.     #endif
    729. 

  729.     #if defined(HPPA)
    730. 

  730.       #define back_trace_register  "%r13"  /* one of the general registers  %r5..%r18 */
    731. 

  731.     #endif
    732. 

  732.   #endif
    733. 

  733.   /* Declare the registers now (before any system include file which could
    734. 

  734.    contain some inline functions). */
    735. 

  735.   #ifdef STACK_register
    736. 

  736.     register long STACK_reg __asm__(STACK_register);
    737. 

  737.   #endif
    738. 

  738.   #ifdef mv_count_register
    739. 

  739.     register long mv_count_reg __asm__(mv_count_register);
    740. 

  740.   #endif
    741. 

  741.   #ifdef value1_register
    742. 

  742.     register long value1_reg __asm__(value1_register);
    743. 

  743.   #endif
    744. 

  744.   #ifdef back_trace_register
    745. 

  745.     register long back_trace_reg __asm__(back_trace_register);
    746. 

  746.   #endif
    747. 

  747.   /* Saving "save" registers. */
    748. 

  748.   #if (defined(I80386) || defined(HPPA) || defined(M88000) || defined(ARM) || defined(DECALPHA) || defined(S390)) && (defined(STACK_register) || defined(mv_count_register) || defined(value1_register) || defined(back_trace_register))
    749. 

  749.     #define HAVE_SAVED_REGISTERS
    750. 

  750.     struct registers {
    751. 

  751.       #ifdef STACK_register
    752. 

  752.         long STACK_register_contents;
    753. 

  753.       #endif
    754. 

  754.       #ifdef mv_count_register
    755. 

  755.         long mv_count_register_contents;
    756. 

  756.       #endif
    757. 

  757.       #ifdef value1_register
    758. 

  758.         long value1_register_contents;
    759. 

  759.       #endif
    760. 

  760.       #ifdef back_trace_register
    761. 

  761.         long back_trace_register_contents;
    762. 

  762.       #endif
    763. 

  763.     };
    764. 

  764.     extern per_thread struct registers * callback_saved_registers;
    765. 

  765.     #ifdef STACK_register
    766. 

  766.       #define SAVE_STACK_register(registers)     \
    767. 

  767.               registers->STACK_register_contents = STACK_reg
    768. 

  768.       #define RESTORE_STACK_register(registers)  \
    769. 

  769.               STACK_reg = registers->STACK_register_contents
    770. 

  770.     #else
    771. 

  771.       #define SAVE_STACK_register(registers)
    772. 

  772.       #define RESTORE_STACK_register(registers)
    773. 

  773.     #endif
    774. 

  774.     #ifdef mv_count_register
    775. 

  775.       #define SAVE_mv_count_register(registers)     \
    776. 

  776.               registers->mv_count_register_contents = mv_count_reg
    777. 

  777.       #define RESTORE_mv_count_register(registers)  \
    778. 

  778.               mv_count_reg = registers->mv_count_register_contents
    779. 

  779.     #else
    780. 

  780.       #define SAVE_mv_count_register(registers)
    781. 

  781.       #define RESTORE_mv_count_register(registers)
    782. 

  782.     #endif
    783. 

  783.     #ifdef value1_register
    784. 

  784.       #define SAVE_value1_register(registers)     \
    785. 

  785.               registers->value1_register_contents = value1_reg
    786. 

  786.       #define RESTORE_value1_register(registers)  \
    787. 

  787.               value1_reg = registers->value1_register_contents
    788. 

  788.     #else
    789. 

  789.       #define SAVE_value1_register(registers)
    790. 

  790.       #define RESTORE_value1_register(registers)
    791. 

  791.     #endif
    792. 

  792.     #ifdef back_trace_register
    793. 

  793.       #define SAVE_back_trace_register(registers)     \
    794. 

  794.               registers->back_trace_register_contents = back_trace_reg
    795. 

  795.       #define RESTORE_back_trace_register(registers)  \
    796. 

  796.               back_trace_reg = registers->back_trace_register_contents
    797. 

  797.     #else
    798. 

  798.       #define SAVE_back_trace_register(registers)
    799. 

  799.       #define RESTORE_back_trace_register(registers)
    800. 

  800.     #endif
    801. 

  801.     #define SAVE_REGISTERS(inner_statement)                                  \
    802. 

  802.       do {                                                                   \
    803. 

  803.         var struct registers * registers = alloca(sizeof(struct registers)); \
    804. 

  804.         SAVE_STACK_register(registers);                                      \
    805. 

  805.         SAVE_mv_count_register(registers);                                   \
    806. 

  806.         SAVE_value1_register(registers);                                     \
    807. 

  807.         SAVE_back_trace_register(registers);                                 \
    808. 

  808.         inner_statement;                                                     \
    809. 

  809.         { var gcv_object_t* top_of_frame = STACK;                            \
    810. 

  810.           pushSTACK(fake_gcv_object((aint)callback_saved_registers));        \
    811. 

  811.           finish_frame(CALLBACK);                                            \
    812. 

  812.         }                                                                    \
    813. 

  813.         callback_saved_registers = registers;                                \
    814. 

  814.       } while(0)
    815. 

  815.     #define RESTORE_REGISTERS(inner_statement)                                \
    816. 

  816.       do {                                                                    \
    817. 

  817.         var struct registers * registers = callback_saved_registers;          \
    818. 

  818.         if (!(framecode(STACK_0) == CALLBACK_frame_info)) abort();            \
    819. 

  819.         callback_saved_registers = (struct registers *)(aint)as_oint(STACK_1);\
    820. 

  820.         skipSTACK(2);                                                         \
    821. 

  821.         inner_statement;                                                      \
    822. 

  822.         RESTORE_STACK_register(registers);                                    \
    823. 

  823.         RESTORE_mv_count_register(registers);                                 \
    824. 

  824.         RESTORE_value1_register(registers);                                   \
    825. 

  825.         RESTORE_back_trace_register(registers);                               \
    826. 

  826.       } while(0)
    827. 

  827.   #endif
    828. 

  828.   /* Saving the STACK (for asynchronous interrupts).
    829. 

  829.    If STACK is a global variable or lies in a register which is left
    830. 

  830.    untouched by operating system and library (this is the case on SUN4),
    831. 

  831.    we don't need to worry about it. */
    832. 

  832.   #if defined(STACK_register) && !defined(SUN4)
    833. 

  833.     #define HAVE_SAVED_STACK
    834. 

  834.   #endif
    835. 

  835.   /* Saving "used" registers. */
    836. 

  836.   #if defined(mv_count_register) && 0
    837. 

  837.     #define HAVE_SAVED_mv_count
    838. 

  838.   #endif
    839. 

  839.   #if defined(value1_register) && 0
    840. 

  840.     #define HAVE_SAVED_value1
    841. 

  841.   #endif
    842. 

  842.   #if defined(back_trace_register) && defined(SPARC)
    843. 

  843.     #define HAVE_SAVED_back_trace
    844. 

  844.   #endif
    845. 

  845. #endif
    846. 

  846. #ifndef HAVE_SAVED_REGISTERS
    847. 

  847.   #define SAVE_REGISTERS(inner_statement)
    848. 

  848.   #define RESTORE_REGISTERS(inner_statement)
    849. 

  849. #endif
    850. 

  850. %% #ifdef HAVE_SAVED_REGISTERS
    851. 

  851. %%   puts("#ifndef IN_MODULE_CC");
    852. 

  852. %%   #ifdef STACK_register
    853. 

  853. %%     printf("register long STACK_reg __asm__(\"%s\");\n",STACK_register);
    854. 

  854. %%   #endif
    855. 

  855. %%   #ifdef mv_count_register
    856. 

  856. %%     printf("register long mv_count_reg __asm__(\"%s\");\n",mv_count_register);
    857. 

  857. %%   #endif
    858. 

  858. %%   #ifdef value1_register
    859. 

  859. %%     printf("register long value1_reg __asm__(\"%s\");\n",value1_register);
    860. 

  860. %%   #endif
    861. 

  861. %%   #ifdef back_trace_register
    862. 

  862. %%     printf("register long back_trace_reg __asm__(\"%s\");\n",back_trace_register);
    863. 

  863. %%   #endif
    864. 

  864. %%   printf("struct registers { ");
    865. 

  865. %%   #ifdef STACK_register
    866. 

  866. %%     printf("long STACK_register_contents; ");
    867. 

  867. %%   #endif
    868. 

  868. %%   #ifdef mv_count_register
    869. 

  869. %%     printf("long mv_count_register_contents; ");
    870. 

  870. %%   #endif
    871. 

  871. %%   #ifdef value1_register
    872. 

  872. %%     printf("long value1_register_contents; ");
    873. 

  873. %%   #endif
    874. 

  874. %%   #ifdef back_trace_register
    875. 

  875. %%     printf("long back_trace_register_contents; ");
    876. 

  876. %%   #endif
    877. 

  877. %%   puts("};");
    878. 

  878. %%   puts("extern struct registers * callback_saved_registers;");
    879. 

  879. %%   puts("#endif");
    880. 

  880. %% #endif
    881. 

  881. 

  882. #define VALUES_IF(cond)                         \
    883. 

  883.   do { value1 = (cond) ? T : NIL; mv_count = 1; } while (0)
    884. 

  884. %% export_def(VALUES_IF(C));
    885. 

  885. 

  886. #define VALUES0                                 \
    887. 

  887.   do { value1 = NIL; mv_count = 0; } while (0)
    888. 

  888. %% export_def(VALUES0);
    889. 

  889. 

  890. #define VALUES1(A)                               \
    891. 

  891.   do { value1 = (A); mv_count = 1; } while (0)
    892. 

  892. %% export_def(VALUES1(A));
    893. 

  893. 

  894. #define VALUES2(A,B)                            \
    895. 

  895.   do { value1 = (A); value2 = (B); mv_count = 2; } while (0)
    896. 

  896. %% export_def(VALUES2(A,B));
    897. 

  897. 

  898. #define VALUES3(A,B,C)                          \
    899. 

  899.   do { value1 = (A); value2 = (B); value3 = (C); mv_count = 3; } while (0)
    900. 

  900. %% export_def(VALUES3(A,B,C));
    901. 

  901. 

  902. /* ###################### Macros for C #################### */
    903. 

  903. 

  904. #if !defined(return_void)
    905. 

  905.   /* To return a type of value void: return_void(...); */
    906. 

  906.   #ifdef GNU
    907. 

  907.     #define return_void  return /* 'return void;' is admissible */
    908. 

  908.   #else
    909. 

  909.     /* In general it is not legal to return `void' values. */
    910. 

  910.     #define return_void  /* Don't use 'return' for expressions of type 'void'. */
    911. 

  911.   #endif
    912. 

  912. #endif
    913. 

  913. #if defined(GNU) && defined(__GNUG__)
    914. 

  914.   /* Although legal, g++ warns about 'return void;'. Shut up the warning. */
    915. 

  915.   #undef return_void
    916. 

  916.   #define return_void
    917. 

  917. #endif
    918. 

  918. 

  919. #if !defined(GNU) && !defined(inline)
    920. 

  920.   #define inline      /* inline foo() {...} --> foo() {...} */
    921. 

  921. #endif
    922. 

  922. %% puts("#if !defined(__GNUC__) && !defined(inline)");
    923. 

  923. %% puts("#define inline");
    924. 

  924. %% puts("#endif");
    925. 

  925. 

  926. /* Definitions for C++-Compilers: */
    927. 

  927. #ifdef __cplusplus
    928. 

  928.   #define BEGIN_DECLS  extern "C" {
    929. 

  929.   #define END_DECLS    }
    930. 

  930. #else
    931. 

  931.   #define BEGIN_DECLS
    932. 

  932.   #define END_DECLS
    933. 

  933. #endif
    934. 

  934. %% export_def(BEGIN_DECLS);
    935. 

  935. %% export_def(END_DECLS);
    936. 

  936. 

  937. /* Empty macro-arguments:
    938. 

  938.  Some compilers (ie. cc under HP-UX) seem to interpret a macro call
    939. 

  939.  foo(arg1,...,argn,) as equivalent to foo(arg1,...,argn), which will
    940. 

  940.  yield an error. _EMA_ stands for "empty macro argument".
    941. 

  941.  It will be inserted by CC_NEED_DEEMA,
    942. 

  942.  each time between comma and closing parentheses.
    943. 

  943.  It is also needed when potentially empty arguments
    944. 

  944.  are returned to other macros */
    945. 

  945. 

  946. #define _EMA_
    947. 

  947. 

  948. /* Concatenation of two macro-expanded tokens:
    949. 

  949.  Example:
    950. 

  950.    #undef x
    951. 

  951.    #define y 16
    952. 

  952.    CONCAT(x,y)        ==>  'x16' (not 'xy' !) */
    953. 

  953. #define CONCAT_(xxx,yyy)  xxx##yyy
    954. 

  954. #define CONCAT3_(aaa,bbb,ccc)  aaa##bbb##ccc
    955. 

  955. #define CONCAT4_(aaa,bbb,ccc,ddd)  aaa##bbb##ccc##ddd
    956. 

  956. #define CONCAT5_(aaa,bbb,ccc,ddd,eee)  aaa##bbb##ccc##ddd##eee
    957. 

  957. #define CONCAT6_(aaa,bbb,ccc,ddd,eee,fff)  aaa##bbb##ccc##ddd##eee##fff
    958. 

  958. #define CONCAT7_(aaa,bbb,ccc,ddd,eee,fff,ggg)  aaa##bbb##ccc##ddd##eee##fff##ggg
    959. 

  959. #define CONCAT(xxx,yyy)  CONCAT_(xxx,yyy)
    960. 

  960. #define CONCAT3(aaa,bbb,ccc)  CONCAT3_(aaa,bbb,ccc)
    961. 

  961. #define CONCAT4(aaa,bbb,ccc,ddd)  CONCAT4_(aaa,bbb,ccc,ddd)
    962. 

  962. #define CONCAT5(aaa,bbb,ccc,ddd,eee)  CONCAT5_(aaa,bbb,ccc,ddd,eee)
    963. 

  963. #define CONCAT6(aaa,bbb,ccc,ddd,eee,fff)  CONCAT6_(aaa,bbb,ccc,ddd,eee,fff)
    964. 

  964. #define CONCAT7(aaa,bbb,ccc,ddd,eee,fff,ggg)  CONCAT7_(aaa,bbb,ccc,ddd,eee,fff,ggg)
    965. 

  965. %% puts("#define CONCAT_(xxx,yyy)  xxx##yyy");
    966. 

  966. %% puts("#define CONCAT3_(aaa,bbb,ccc)  aaa##bbb##ccc");
    967. 

  967. %% #if notused
    968. 

  968. %% puts("#define CONCAT4_(aaa,bbb,ccc,ddd)  aaa##bbb##ccc##ddd");
    969. 

  969. %% puts("#define CONCAT5_(aaa,bbb,ccc,ddd,eee)  aaa##bbb##ccc##ddd##eee");
    970. 

  970. %% #endif
    971. 

  971. %% puts("#define CONCAT(xxx,yyy)  CONCAT_(xxx,yyy)");
    972. 

  972. %% puts("#define CONCAT3(aaa,bbb,ccc)  CONCAT3_(aaa,bbb,ccc)");
    973. 

  973. %% #if notused
    974. 

  974. %% puts("#define CONCAT4(aaa,bbb,ccc,ddd)  CONCAT4_(aaa,bbb,ccc,ddd)");
    975. 

  975. %% puts("#define CONCAT5(aaa,bbb,ccc,ddd,eee)  CONCAT5_(aaa,bbb,ccc,ddd,eee)");
    976. 

  976. %% #endif
    977. 

  977. 

  978. /* Generation of goto-tag macros:
    979. 

  979.  GENTAG(end)  ==>  end116
    980. 

  980.  This allows a macro defining marks to be used more than once per function
    981. 

  981.  but still only once per source-line. */
    982. 

  982. #define GENTAG(xxx)  CONCAT(xxx,__LINE__)
    983. 

  983. 

  984. /* Converting tokens to strings:
    985. 

  985.  STRING(token)  ==>  "token" */
    986. 

  986. #define STRING(token) #token
    987. 

  987. #define STRINGIFY(token) STRING(token)
    988. 

  988. %% puts("#define STRING(token) #token");
    989. 

  989. %% puts("#define STRINGIFY(token) STRING(token)");
    990. 

  990. 

  991. /* Storage-Class-Specifier in top-level-declarations:
    992. 

  992.  for variables:
    993. 

  993.    global           globally visible variable
    994. 

  994.    local            variable that is only visible in the file (local)
    995. 

  995.    extern           pointer to a variable that's defined externally
    996. 

  996.  for functions:
    997. 

  997.    global           globally visible function
    998. 

  998.    local            function that is only visible in the file (local)
    999. 

  999.    extern           pointer to a function that's defined externally
    1000. 

  1000.    extern_C         pointer to a c-function that's defined externally
    1001. 

  1001.    nonreturning     function that will never return
    1002. 

  1002.    maygc            function that can trigger GC */
    1003. 

  1003. #define global
    1004. 

  1004. #define local  static
    1005. 

  1005. /* #define extern extern */
    1006. 

  1006. #ifdef __cplusplus
    1007. 

  1007.   #define extern_C  extern "C"
    1008. 

  1008. #else
    1009. 

  1009.   #define extern_C  extern
    1010. 

  1010. #endif
    1011. 

  1011. 

  1012. /* Declaration of a function that will never return (nonreturning function)
    1013. 

  1013.  nonreturning_function(extern,abort,(void)); == extern void abort (void); */
    1014. 

  1014. #if defined(GNU) && !(__APPLE_CC__ > 1)
    1015. 

  1015.   #if (__GNUC__ >= 3) || ((__GNUC__ == 2) && (__GNUC_MINOR__ >= 7))
    1016. 

  1016.     /* Note:
    1017. 

  1017.        storclass __attribute__((__noreturn__)) void funname arguments
    1018. 

  1018.          works in gcc 2.95 or newer, and in g++ 2.7.2 or newer.
    1019. 

  1019.        storclass void __attribute__((__noreturn__)) funname arguments
    1020. 

  1020.          works in gcc 2.7.2 or newer and in g++ 2.7.2 or newer.
    1021. 

  1021.        storclass void funname arguments __attribute__((__noreturn__))
    1022. 

  1022.          works in gcc 2.7.2 or newer and in g++ 2.7.2 or newer, but
    1023. 

  1023.          only when followed by a semicolon, not in a function definition. */
    1024. 

  1024.     #define nonreturning_function(storclass,funname,arguments)  \
    1025. 

  1025.       storclass void __attribute__((__noreturn__)) funname arguments
    1026. 

  1026.   #else
    1027. 

  1027.     #define nonreturning_function(storclass,funname,arguments)  \
    1028. 

  1028.       storclass void funname arguments
    1029. 

  1029.   #endif
    1030. 

  1030. #elif defined(MICROSOFT)
    1031. 

  1031.   #define nonreturning_function(storclass,funname,arguments)  \
    1032. 

  1032.     __declspec(noreturn) storclass void funname arguments
    1033. 

  1033. #else
    1034. 

  1034.   #define nonreturning_function(storclass,funname,arguments)  \
    1035. 

  1035.     storclass void funname arguments
    1036. 

  1036. #endif
    1037. 

  1037. %% export_def(nonreturning_function(storclass,funname,arguments));
    1038. 

  1038. 

  1039. /* A function that can trigger GC is declared either as
    1040. 

  1040.    - maygc, if (1) all callers must assume the worst case: that it triggers GC,
    1041. 

  1041.             and (2) the function uses only the 'object's passed as arguments and
    1042. 

  1042.             on the STACK, but no objects stored in other non-GCsafe locations.
    1043. 

  1043.    - ／＊maygc＊／ otherwise. If (1) is not fulfilled, the functions begins
    1044. 

  1044.                    with an appropriate GCTRIGGER_IF statement. If (2) is not
    1045. 

  1045.                    fulfilled, the GCTRIGGER call needs to mention all other
    1046. 

  1046.                    non-GCsafe locations whose values are used by the function,
    1047. 

  1047.                    such as 'value1' or 'mv_space'. */
    1048. 

  1048. #define maygc
    1049. 

  1049. 

  1050. /* Storage-Class-Specifier in declarations at the beginning of a block:
    1051. 

  1051.  var                       will lead a variable declaration
    1052. 

  1052.  used by utils/varbrace to allow declarations mixed with other statements */
    1053. 

  1053. #define var
    1054. 

  1054. 

  1055. /* Ignore C++ keyword. */
    1056. 

  1056. #define export export_sym
    1057. 

  1057. 

  1058. /* Swap the contents of two variables:  swap(register int, x1, x2); */
    1059. 

  1059. #define swap(swap_type,swap_var1,swap_var2)  \
    1060. 

  1060.   do { var swap_type swap_temp;                                          \
    1061. 

  1061.     swap_temp = swap_var1; swap_var1 = swap_var2; swap_var2 = swap_temp; \
    1062. 

  1062.   } while(0)
    1063. 

  1063. 

  1064. /* Marking a program line that may not be reached: NOTREACHED; */
    1065. 

  1065. #define NOTREACHED  error_notreached(__FILE__,__LINE__)
    1066. 

  1066. %% puts("#define NOTREACHED  error_notreached(__FILE__,__LINE__)");
    1067. 

  1067. 

  1068. /* Asserting an arithmetic expression: ASSERT(expr); */
    1069. 

  1069. #define ASSERT(expr)  do { if (!(expr)) NOTREACHED; } while(0)
    1070. 

  1070. %%  puts("#define ASSERT(expr)  do { if (!(expr)) NOTREACHED; } while(0)");
    1071. 

  1071. 

  1072. /* alloca() */
    1073. 

  1073. #ifdef GNU
    1074. 

  1074.   #define alloca  __builtin_alloca
    1075. 

  1075. #elif defined(MICROSOFT)
    1076. 

  1076.   #include <malloc.h>
    1077. 

  1077.   #define alloca _alloca
    1078. 

  1078. #elif defined(HAVE_ALLOCA_H)
    1079. 

  1079.   #include <alloca.h>
    1080. 

  1080.   #ifndef alloca /* Manche definieren 'alloca' als Macro... */
    1081. 

  1081.     #if !(defined(UNIX_OSF) || defined(UNIX_DEC_ULTRIX))
    1082. 

  1082.       /* OSF/1 V3 declares `alloca' as returning char*, but in OSF/1 V4
    1083. 

  1083.        it returns void*. I don't know how to distinguish the two. */
    1084. 

  1084.       extern_C void* alloca (int size); /* see MALLOC(3V) */
    1085. 

  1085.     #endif
    1086. 

  1086.   #endif
    1087. 

  1087. #elif defined(_AIX)
    1088. 

  1088.   #pragma alloca /* AIX requires this to be the first thing in the file. */
    1089. 

  1089. #elif defined(BORLAND)
    1090. 

  1090.   #include <malloc.h> /* defines  'alloca' as macro */
    1091. 

  1091. #elif !defined(NO_ALLOCA)
    1092. 

  1092.   extern_C void* alloca (int size); /* see MALLOC(3V) */
    1093. 

  1093. #endif
    1094. 

  1094. %% #ifdef GNU
    1095. 

  1095. %%   emit_define("alloca","__builtin_alloca");
    1096. 

  1096. %% #elif defined(MICROSOFT)
    1097. 

  1097. %%   puts("#include <malloc.h>");
    1098. 

  1098. %%   emit_define("alloca","_alloca");
    1099. 

  1099. %% #elif defined(HAVE_ALLOCA_H)
    1100. 

  1100. %%   puts("#include <alloca.h>");
    1101. 

  1101. %%   #ifndef alloca
    1102. 

  1102. %%     #if !(defined(UNIX_OSF) || defined(UNIX_DEC_ULTRIX))
    1103. 

  1103. %%       puts("extern void* alloca (int size);");
    1104. 

  1104. %%     #endif
    1105. 

  1105. %%   #endif
    1106. 

  1106. %% #elif defined(_AIX)
    1107. 

  1107. %%   puts("#pragma alloca");
    1108. 

  1108. %% #elif !defined(NO_ALLOCA)
    1109. 

  1109. %%   puts("extern void* alloca (int size);");
    1110. 

  1110. %% #endif
    1111. 

  1111. 

  1112. #define MALLOC(size,type)   (type*)malloc((size)*sizeof(type))
    1113. 

  1113. 

  1114. /* Literal constants of 64-bit integer types
    1115. 

  1115.  LL(nnnn)  = nnnn parsed as a sint64
    1116. 

  1116.  ULL(nnnn) = nnnn parsed as a uint64 */
    1117. 

  1117. #if defined(HAVE_LONG_LONG_INT)
    1118. 

  1118.   #define LL(nnnn) nnnn##LL
    1119. 

  1119.   #define ULL(nnnn) nnnn##ULL
    1120. 

  1120. #elif defined(MICROSOFT)
    1121. 

  1121.   #define LL(nnnn) nnnn##i64
    1122. 

  1122.   #define ULL(nnnn) nnnn##ui64
    1123. 

  1123. #endif
    1124. 

  1124. %% #if defined(HAVE_LONG_LONG_INT)
    1125. 

  1125. %%   puts("#define LL(nnnn) nnnn##LL");
    1126. 

  1126. %%   puts("#define ULL(nnnn) nnnn##ULL");
    1127. 

  1127. %% #elif defined(MICROSOFT)
    1128. 

  1128. %%   puts("#define LL(nnnn) nnnn##i64");
    1129. 

  1129. %%   puts("#define ULL(nnnn) nnnn##ui64");
    1130. 

  1130. %% #endif
    1131. 

  1131. 

  1132. /* Synonyms for Byte, Word, Longword:
    1133. 

  1133.  SBYTE   = signed 8 bit integer
    1134. 

  1134.  UBYTE   = unsigned 8 bit int
    1135. 

  1135.  SWORD   = signed 16 bit int
    1136. 

  1136.  UWORD   = unsigned 16 bit int
    1137. 

  1137.  SLONG   = signed 32 bit int
    1138. 

  1138.  ULONG   = unsigned 32 bit int
    1139. 

  1139.  On the other hand, "char" is only used as an element of a string
    1140. 

  1140.  You never really compute with a "char"; it might depend on
    1141. 

  1141.  __CHAR_UNSIGNED___! */
    1142. 

  1142. #if (char_bitsize==8)
    1143. 

  1143.   #ifdef __CHAR_UNSIGNED__
    1144. 

  1144.     typedef signed char  SBYTE;
    1145. 

  1145.   #else
    1146. 

  1146.     typedef char         SBYTE;
    1147. 

  1147.   #endif
    1148. 

  1148.   typedef unsigned char  UBYTE;
    1149. 

  1149. #else
    1150. 

  1150.   #error "No 8 bit integer type? -- Which Interger-type has 8 Bit?"
    1151. 

  1151. #endif
    1152. 

  1152. #if (short_bitsize==16)
    1153. 

  1153.   typedef short          SWORD;
    1154. 

  1154.   typedef unsigned short UWORD;
    1155. 

  1155. #else
    1156. 

  1156.   #error "No 16 bit integer type? -- Which Integer-type has 16 Bit?"
    1157. 

  1157. #endif
    1158. 

  1158. #if (long_bitsize==32)
    1159. 

  1159.   typedef long           SLONG;
    1160. 

  1160.   typedef unsigned long  ULONG;
    1161. 

  1161. #elif (int_bitsize==32)
    1162. 

  1162.   typedef int            SLONG;
    1163. 

  1163.   typedef unsigned int   ULONG;
    1164. 

  1164. #else
    1165. 

  1165.   #error "No 32 bit integer type? -- Which Integer-type has 32 Bit?"
    1166. 

  1166. #endif
    1167. 

  1167. #if (long_bitsize==64)
    1168. 

  1168.   typedef long           SLONGLONG;
    1169. 

  1169.   typedef unsigned long  ULONGLONG;
    1170. 

  1170.   #ifndef HAVE_LONG_LONG_INT
    1171. 

  1171.   #define HAVE_LONG_LONG_INT
    1172. 

  1172.   #endif
    1173. 

  1173. #elif defined(MICROSOFT)
    1174. 

  1174.   typedef __int64           SLONGLONG;
    1175. 

  1175.   typedef unsigned __int64  ULONGLONG;
    1176. 

  1176.   #define HAVE_LONG_LONG_INT
    1177. 

  1177. #elif defined(HAVE_LONG_LONG_INT)
    1178. 

  1178.  #if defined(long_long_bitsize) && (long_long_bitsize==64)
    1179. 

  1179.   typedef long long           SLONGLONG;
    1180. 

  1180.   typedef unsigned long long  ULONGLONG;
    1181. 

  1181.  #else /* useless type */
    1182. 

  1182.   #undef HAVE_LONG_LONG_INT
    1183. 

  1183.  #endif
    1184. 

  1184. #endif
    1185. 

  1185. #if defined(WIDE) && !defined(HAVE_LONG_LONG_INT)
    1186. 

  1186.   #error "No 64 bit integer type? -- Which Integer-type has 64 Bit?"
    1187. 

  1187. #endif
    1188. 

  1188. %% #ifdef __CHAR_UNSIGNED__
    1189. 

  1189. %%   emit_typedef("signed char","SBYTE");
    1190. 

  1190. %% #else
    1191. 

  1191. %%   emit_typedef("char","SBYTE");
    1192. 

  1192. %% #endif
    1193. 

  1193. %% emit_typedef("unsigned char","UBYTE");
    1194. 

  1194. %% emit_typedef("short","SWORD");
    1195. 

  1195. %% emit_typedef("unsigned short","UWORD");
    1196. 

  1196. %% #if (long_bitsize==32)
    1197. 

  1197. %%   emit_typedef("long","SLONG");
    1198. 

  1198. %%   emit_typedef("unsigned long","ULONG");
    1199. 

  1199. %% #elif (int_bitsize==32)
    1200. 

  1200. %%   emit_typedef("int","SLONG");
    1201. 

  1201. %%   emit_typedef("unsigned int","ULONG");
    1202. 

  1202. %% #endif
    1203. 

  1203. %% #if (long_bitsize==64)
    1204. 

  1204. %%   emit_typedef("long","SLONGLONG");
    1205. 

  1205. %%   emit_typedef("unsigned long","ULONGLONG");
    1206. 

  1206. %% #elif defined(MICROSOFT)
    1207. 

  1207. %%   emit_typedef("__int64","SLONGLONG");
    1208. 

  1208. %%   emit_typedef("unsigned __int64","ULONGLONG");
    1209. 

  1209. %% #elif defined(HAVE_LONG_LONG_INT)
    1210. 

  1210. %%   emit_typedef("long long","SLONGLONG");
    1211. 

  1211. %%   emit_typedef("unsigned long long","ULONGLONG");
    1212. 

  1212. %% #endif
    1213. 

  1213. 

  1214. #include <stdbool.h>  /* boolean values */
    1215. 

  1215. %% #ifdef HAVE_STDBOOL_H
    1216. 

  1216. %%   puts("#include <stdbool.h>");
    1217. 

  1217. %% #else
    1218. 

  1218. %%   print_file("stdbool.h");
    1219. 

  1219. %% #endif
    1220. 

  1220. 

  1221. /* Type for signed values, results of comparisons, tertiary enums
    1222. 

  1222.  with values +1, 0, -1 */
    1223. 

  1223. typedef signed int  signean;
    1224. 

  1224. #define signean_plus    1 /* +1 */
    1225. 

  1225. #define signean_null    0 /*  0 */
    1226. 

  1226. #define signean_minus  -1 /* -1 */
    1227. 

  1227. 

  1228. /* Null pointers */
    1229. 

  1229. #ifdef __cplusplus
    1230. 

  1230.   #undef NULL
    1231. 

  1231.   #define NULL  0
    1232. 

  1232. #elif !(defined(INTEL) || defined(_AIX))
    1233. 

  1233.   #undef NULL
    1234. 

  1234.   #define NULL  ((void*) 0L)
    1235. 

  1235. #endif
    1236. 

  1236. %% puts("#undef NULL");
    1237. 

  1237. %% export_def(NULL);
    1238. 

  1238. 

  1239. #include <stdio.h>    /* libc i/o */
    1240. 

  1240. 

  1241. /* A more precise classification of the operating system:
    1242. 

  1242.  (This test works only after at least one system header has been included.) */
    1243. 

  1243. #if (__GLIBC__ >= 2)
    1244. 

  1244.   #define UNIX_GNU /* glibc2 (may be UNIX_LINUX, UNIX_HURD or UNIX_FREEBSD) */
    1245. 

  1245. #endif
    1246. 

  1246. 

  1247. /* Determine the offset of a component 'ident' in a struct of the type 'type':
    1248. 

  1248.  See 0 as pointer to 'type', put a struct 'type' there and determine the
    1249. 

  1249.  address of its component 'ident' and return it as number: */
    1250. 

  1250. #if defined(HAVE_OFFSETOF) || defined(__MINGW32__) || (defined(BORLAND) && defined(WIN32)) || defined(MICROSOFT)
    1251. 

  1251.   #include <stddef.h>
    1252. 

  1252. #else
    1253. 

  1253.   #undef offsetof
    1254. 

  1254.   #define offsetof(type,ident)  ((ULONG)&(((type*)0)->ident))
    1255. 

  1255. #endif
    1256. 

  1256. /* Determine the offset of an array 'ident' in a struct of the type 'type': */
    1257. 

  1257. #if defined(__cplusplus) || defined(MICROSOFT)
    1258. 

  1258.   #define offsetofa(type,ident)  offsetof(type,ident)
    1259. 

  1259. #else
    1260. 

  1260.   #define offsetofa(type,ident)  offsetof(type,ident[0])
    1261. 

  1261. #endif
    1262. 

  1262. 

  1263. /* alignof(type) is a constant expression, returning the alignment of type. */
    1264. 

  1264. #ifdef __cplusplus
    1265. 

  1265.   #ifdef GNU
    1266. 

  1266.     #define alignof(type)  __alignof__(type)
    1267. 

  1267.   #else
    1268. 

  1268.     template <class type> struct alignof_helper { char slot1; type slot2; };
    1269. 

  1269.     #define alignof(type)  offsetof(alignof_helper<type>, slot2)
    1270. 

  1270.   #endif
    1271. 

  1271. #else
    1272. 

  1272.   #define alignof(type)  offsetof(struct { char slot1; type slot2; }, slot2)
    1273. 

  1273. #endif
    1274. 

  1274. 

  1275. /* Unspecified length of arrays in structures:
    1276. 

  1276.  struct { ...; ...; type x[unspecified]; }
    1277. 

  1277.  Instead of sizeof(..) you'll always have to use offsetof(..,x). */
    1278. 

  1278. #if defined(GNU) || defined(MICROSOFT) /* GNU & MS C are able to work with arrays of length 0 */
    1279. 

  1279.   #define unspecified 0
    1280. 

  1280. #elif 0
    1281. 

  1281.   /* Usually one would omit the array's limit */
    1282. 

  1282.   #define unspecified
    1283. 

  1283. #else
    1284. 

  1284.   /* However, HP-UX- and IRIX-compilers will only work with this: */
    1285. 

  1285.   #define unspecified 1
    1286. 

  1286. #endif
    1287. 

  1287. %% export_def(unspecified);
    1288. 

  1288. 

  1289. /* Pointer arithmetics: add a given offset (measured in bytes)
    1290. 

  1290.  to a pointer. */
    1291. 

  1291. #if defined(GNU) || (pointer_bitsize > 32)
    1292. 

  1292.  /* Essential for GNU-C for initialization of static-variables
    1293. 

  1293.    (must be a bug in 'c-typeck.c' in 'initializer_constant_valid_p'):
    1294. 

  1294.    The only correct way, if sizeof(ULONG) < sizeof(void*): */
    1295. 

  1295.   #define pointerplus(pointer,offset)  ((UBYTE*)(pointer)+(offset))
    1296. 

  1296. #else
    1297. 

  1297.   /* Cheap way: */
    1298. 

  1298.   #define pointerplus(pointer,offset)  ((void*)((ULONG)(pointer)+(offset)))
    1299. 

  1299. #endif
    1300. 

  1300. %% export_def(pointerplus(pointer,offset));
    1301. 

  1301. 

  1302. /* Bit number n (0<=n<32)
    1303. 

  1303.  This is an unsigned expression, in order to avoid signed integer overflow
    1304. 

  1304.  in expressions like bit(31) or bit(31)-1. */
    1305. 

  1305. #define bit(n)  (1UL<<(n))
    1306. 

  1306. /* Bit number n (0<n<=32) mod 2^32 */
    1307. 

  1307. #define bitm(n)  (2UL<<((n)-1))
    1308. 

  1308. /* Bit-test of bit n in x, n constant, x an oint: */
    1309. 

  1309. #if !defined(SPARC)
    1310. 

  1310.   #define bit_test(x,n)  ((x) & bit(n))
    1311. 

  1311. #else
    1312. 

  1312.   /* On SPARC-processors, long constants are slower than shifts. */
    1313. 

  1313.   #if defined(SPARC64)
    1314. 

  1314.     #if !defined(GNU)
    1315. 

  1315.       #define bit_test(x,n)  \
    1316. 

  1316.         ((n)<12 ? ((x) & bit(n)) : ((sint64)((uint64)(x) << (63-(n))) < 0))
    1317. 

  1317.     #else /* the GNU-compiler will optimize boolean expressions better this way: */
    1318. 

  1318.       #define bit_test(x,n)  \
    1319. 

  1319.         (   ( ((n)<12) && ((x) & bit(n)) )                           \
    1320. 

  1320.          || ( ((n)>=12) && ((sint64)((uint64)(x) << (63-(n))) < 0) ) \
    1321. 

  1321.         )
    1322. 

  1322.     #endif
    1323. 

  1323.   #else
    1324. 

  1324.     #if !defined(GNU)
    1325. 

  1325.       #define bit_test(x,n)  \
    1326. 

  1326.         ((n)<12 ? ((x) & bit(n)) : ((sint32)((uint32)(x) << (31-(n))) < 0))
    1327. 

  1327.     #else /* the GNU-compiler will optimize boolean expressions better this way: */
    1328. 

  1328.       #define bit_test(x,n)  \
    1329. 

  1329.         (   ( ((n)<12) && ((x) & bit(n)) )                           \
    1330. 

  1330.          || ( ((n)>=12) && ((sint32)((uint32)(x) << (31-(n))) < 0) ) \
    1331. 

  1331.         )
    1332. 

  1332.     #endif
    1333. 

  1333.   #endif
    1334. 

  1334. #endif
    1335. 

  1335. /* Minus bit number n (0<=n<32) */
    1336. 

  1336. #define minus_bit(n)  (-1L<<(n))
    1337. 

  1337. /* Minus bit number n (0<n<=32) mod 2^32 */
    1338. 

  1338. #define minus_bitm(n)  (-2L<<((n)-1))
    1339. 

  1339. %% export_def(bit(n));
    1340. 

  1340. %% #if notused
    1341. 

  1341. %% export_def(bitm(n));
    1342. 

  1342. %% #endif
    1343. 

  1343. %% export_def(bit_test(x,n));
    1344. 

  1344. %% export_def(minus_bit(n));
    1345. 

  1345. %% #if notused
    1346. 

  1346. %% export_def(minus_bitm(n));
    1347. 

  1347. %% #endif
    1348. 

  1348. 

  1349. /* floor(a,b) yields for a>=0, b>0  floor(a/b).
    1350. 

  1350.  b should be a 'constant expression'. */
    1351. 

  1351. #define floor(a_from_floor,b_from_floor)  ((a_from_floor) / (b_from_floor))
    1352. 

  1352. %% /* FIXME: Difference between lispbibl.d and clisp.h */
    1353. 

  1353. %% puts("#define ifloor(a_from_floor,b_from_floor)  ((a_from_floor) / (b_from_floor))");
    1354. 

  1354. 

  1355. /* ceiling(a,b) yields for a>=0, b>0  ceiling(a/b) = floor((a+b-1)/b).
    1356. 

  1356.  b should be a 'constant expression'. */
    1357. 

  1357. #define ceiling(a_from_ceiling,b_from_ceiling)  \
    1358. 

  1358.   (((a_from_ceiling) + (b_from_ceiling) - 1) / (b_from_ceiling))
    1359. 

  1359. %% export_def(ceiling(a_from_ceiling,b_from_ceiling));
    1360. 

  1360. 

  1361. /* round_down(a,b) rounds a>=0 so that b>0 divides it.
    1362. 

  1362.  b should be a 'constant expression'. */
    1363. 

  1363. #define round_down(a_from_round,b_from_round)  \
    1364. 

  1364.   (floor(a_from_round,b_from_round)*(b_from_round))
    1365. 

  1365. %% /* FIXME: Difference between lispbibl.d and clisp.h */
    1366. 

  1366. %% puts("#define round_down(a_from_round,b_from_round)  (ifloor(a_from_round,b_from_round)*(b_from_round))");
    1367. 

  1367. 

  1368. /* round_up(a,b) rounds a>=0 so that b>0 divides it.
    1369. 

  1369.  b should be a 'constant expression'. */
    1370. 

  1370. #define round_up(a_from_round,b_from_round)  \
    1371. 

  1371.   (ceiling(a_from_round,b_from_round)*(b_from_round))
    1372. 

  1372. %% export_def(round_up(a_from_round,b_from_round));
    1373. 

  1373. 

  1374. /* non-local exits */
    1375. 

  1375. #include <setjmp.h>
    1376. 

  1376. #if defined(UNIX) && defined(HAVE__JMP) && !defined(UNIX_LINUX) && !defined(UNIX_GNU) && !defined(UNIX_BEOS) && !defined(UNIX_CYGWIN32)
    1377. 

  1377.   /* The following routines are more efficient (don't use with signal-masks): */
    1378. 

  1378.   #undef setjmp
    1379. 

  1379.   #undef longjmp
    1380. 

  1380.   #define setjmp  _setjmp
    1381. 

  1381.   #define longjmp  _longjmp
    1382. 

  1382.   #ifdef LONGJMP_RETURNS
    1383. 

  1383.     /* _longjmp(jmpbuf,value) can return if jmpbuf is invalid. */
    1384. 

  1384.     #undef longjmp
    1385. 

  1385.     #define longjmp(x,y)  (_longjmp(x,y), NOTREACHED)
    1386. 

  1386.   #endif
    1387. 

  1387. #endif
    1388. 

  1388. /* A longjmp() can only be called using an `int'.
    1389. 

  1389.  But if we want to use a `long' and if sizeof(int) < sizeof(long),
    1390. 

  1390.  we'll need a global variable: */
    1391. 

  1391. #if (int_bitsize == long_bitsize)
    1392. 

  1392.   #define setjmpl(x)  setjmp(x)
    1393. 

  1393.   #define longjmpl(x,y)  longjmp(x,y)
    1394. 

  1394. #else /* (int_bitsize < long_bitsize) */
    1395. 

  1395.   extern long jmpl_value;
    1396. 

  1396.   #define setjmpl(x)  (setjmp(x) ? jmpl_value : 0)
    1397. 

  1397.   #define longjmpl(x,y)  (jmpl_value = (y), longjmp(x,1))
    1398. 

  1398. #endif
    1399. 

  1399. 

  1400. /* An alloca() replacement, used for DYNAMIC_ARRAY and SAVE_NUM_STACK.
    1401. 

  1401.  See spvw_alloca.d. */
    1402. 

  1402. #if !(defined(GNU) || (defined(UNIX) && !defined(NO_ALLOCA) && !defined(SPARC)) || defined(BORLAND) || defined(MICROSOFT))
    1403. 

  1403.   #define NEED_MALLOCA
    1404. 

  1404.   #include <stdlib.h>
    1405. 

  1405.   extern void* malloca (size_t size);
    1406. 

  1406.   extern void freea (void* ptr);
    1407. 

  1407. #endif
    1408. 

  1408. 

  1409. /* Dynamically allocated array with dynamic extent:
    1410. 

  1410.  Example:
    1411. 

  1411.      var DYNAMIC_ARRAY(my_array,uintL,n);
    1412. 

  1412.      ...
    1413. 

  1413.      FREE_DYNAMIC_ARRAY(my_array);
    1414. 

  1414.  Attention: depending on your implementation my_array is either the array
    1415. 

  1415.  itself or a pointer to the array! Always use my_array only as expression! */
    1416. 

  1416. #if defined(GNU)
    1417. 

  1417.   /* can deal with dynamically allocated arrays in the machine stack
    1418. 

  1418.    { var uintL my_array[n]; ... } */
    1419. 

  1419.   #define DYNAMIC_ARRAY(arrayvar,arrayeltype,arraysize)  \
    1420. 

  1420.     arrayeltype arrayvar[arraysize]
    1421. 

  1421.   #define FREE_DYNAMIC_ARRAY(arrayvar)
    1422. 

  1422.   #ifdef DECALPHA /* GCC 2.5.5 Bug umgehen */
    1423. 

  1423.     #undef DYNAMIC_ARRAY
    1424. 

  1424.     #define DYNAMIC_ARRAY(arrayvar,arrayeltype,arraysize)  \
    1425. 

  1425.       arrayeltype arrayvar[(arraysize)+1]
    1426. 

  1426.   #endif
    1427. 

  1427. #elif (defined(UNIX) && (defined(HAVE_ALLOCA_H) || defined(_AIX) || !defined(NO_ALLOCA))) || defined(BORLAND) || defined(MICROSOFT)
    1428. 

  1428.   /* Allocate space in machine stack.
    1429. 

  1429.    { var uintL* my_array = (uintL*)alloca(n*sizeof(uintL)); ... } */
    1430. 

  1430.   #define DYNAMIC_ARRAY(arrayvar,arrayeltype,arraysize)  \
    1431. 

  1431.     arrayeltype* arrayvar = (arrayeltype*)alloca((arraysize)*sizeof(arrayeltype))
    1432. 

  1432.   #define FREE_DYNAMIC_ARRAY(arrayvar)
    1433. 

  1433.   /* no error check?? */
    1434. 

  1434. #else
    1435. 

  1435.   /* Allocate space somewhere else and then free it.
    1436. 

  1436.    { var uintL* my_array = (uintL*)malloc(n*sizeof(uintL)); ... free(my_array); } */
    1437. 

  1437.   #define DYNAMIC_ARRAY(arrayvar,arrayeltype,arraysize)  \
    1438. 

  1438.     arrayeltype* arrayvar = (arrayeltype*)malloca((arraysize)*sizeof(arrayeltype))
    1439. 

  1439.   #define FREE_DYNAMIC_ARRAY(arrayvar)  freea(arrayvar)
    1440. 

  1440. #endif
    1441. 

  1441. %% export_def(DYNAMIC_ARRAY(arrayvar,arrayeltype,arraysize));
    1442. 

  1442. %% export_def(FREE_DYNAMIC_ARRAY(arrayvar));
    1443. 

  1443. 

  1444. /* Signed/Unsigned-Integer-types with given minumum size: */
    1445. 

  1445. typedef UBYTE   uint1;   /* unsigned 1 bit Integer */
    1446. 

  1446. typedef SBYTE   sint1;   /* signed 1 bit Integer */
    1447. 

  1447. typedef UBYTE   uint2;   /* unsigned 2 bit Integer */
    1448. 

  1448. typedef SBYTE   sint2;   /* signed 2 bit Integer */
    1449. 

  1449. typedef UBYTE   uint3;   /* unsigned 3 bit Integer */
    1450. 

  1450. typedef SBYTE   sint3;   /* signed 3 bit Integer */
    1451. 

  1451. typedef UBYTE   uint4;   /* unsigned 4 bit Integer */
    1452. 

  1452. typedef SBYTE   sint4;   /* signed 4 bit Integer */
    1453. 

  1453. typedef UBYTE   uint5;   /* unsigned 5 bit Integer */
    1454. 

  1454. typedef SBYTE   sint5;   /* signed 5 bit Integer */
    1455. 

  1455. typedef UBYTE   uint6;   /* unsigned 6 bit Integer */
    1456. 

  1456. typedef SBYTE   sint6;   /* signed 6 bit Integer */
    1457. 

  1457. typedef UBYTE   uint7;   /* unsigned 7 bit Integer */
    1458. 

  1458. typedef SBYTE   sint7;   /* signed 7 bit Integer */
    1459. 

  1459. typedef UBYTE   uint8;   /* unsigned 8 bit Integer */
    1460. 

  1460. typedef SBYTE   sint8;   /* signed 8 bit Integer */
    1461. 

  1461. typedef UWORD   uint9;   /* unsigned 9 bit Integer */
    1462. 

  1462. typedef SWORD   sint9;   /* signed 9 bit Integer */
    1463. 

  1463. typedef UWORD   uint10;  /* unsigned 10 bit Integer */
    1464. 

  1464. typedef SWORD   sint10;  /* signed 10 bit Integer */
    1465. 

  1465. typedef UWORD   uint11;  /* unsigned 11 bit Integer */
    1466. 

  1466. typedef SWORD   sint11;  /* signed 11 bit Integer */
    1467. 

  1467. typedef UWORD   uint12;  /* unsigned 12 bit Integer */
    1468. 

  1468. typedef SWORD   sint12;  /* signed 12 bit Integer */
    1469. 

  1469. typedef UWORD   uint13;  /* unsigned 13 bit Integer */
    1470. 

  1470. typedef SWORD   sint13;  /* signed 13 bit Integer */
    1471. 

  1471. typedef UWORD   uint14;  /* unsigned 14 bit Integer */
    1472. 

  1472. typedef SWORD   sint14;  /* signed 14 bit Integer */
    1473. 

  1473. typedef UWORD   uint15;  /* unsigned 15 bit Integer */
    1474. 

  1474. typedef SWORD   sint15;  /* signed 15 bit Integer */
    1475. 

  1475. typedef UWORD   uint16;  /* unsigned 16 bit Integer */
    1476. 

  1476. typedef SWORD   sint16;  /* signed 16 bit Integer */
    1477. 

  1477. typedef ULONG   uint17;  /* unsigned 17 bit Integer */
    1478. 

  1478. typedef SLONG   sint17;  /* signed 17 bit Integer */
    1479. 

  1479. typedef ULONG   uint18;  /* unsigned 18 bit Integer */
    1480. 

  1480. typedef SLONG   sint18;  /* signed 18 bit Integer */
    1481. 

  1481. typedef ULONG   uint19;  /* unsigned 19 bit Integer */
    1482. 

  1482. typedef SLONG   sint19;  /* signed 19 bit Integer */
    1483. 

  1483. typedef ULONG   uint20;  /* unsigned 20 bit Integer */
    1484. 

  1484. typedef SLONG   sint20;  /* signed 20 bit Integer */
    1485. 

  1485. typedef ULONG   uint21;  /* unsigned 21 bit Integer */
    1486. 

  1486. typedef SLONG   sint21;  /* signed 21 bit Integer */
    1487. 

  1487. typedef ULONG   uint22;  /* unsigned 22 bit Integer */
    1488. 

  1488. typedef SLONG   sint22;  /* signed 22 bit Integer */
    1489. 

  1489. typedef ULONG   uint23;  /* unsigned 23 bit Integer */
    1490. 

  1490. typedef SLONG   sint23;  /* signed 23 bit Integer */
    1491. 

  1491. typedef ULONG   uint24;  /* unsigned 24 bit Integer */
    1492. 

  1492. typedef SLONG   sint24;  /* signed 24 bit Integer */
    1493. 

  1493. typedef ULONG   uint25;  /* unsigned 25 bit Integer */
    1494. 

  1494. typedef SLONG   sint25;  /* signed 25 bit Integer */
    1495. 

  1495. typedef ULONG   uint26;  /* unsigned 26 bit Integer */
    1496. 

  1496. typedef SLONG   sint26;  /* signed 26 bit Integer */
    1497. 

  1497. typedef ULONG   uint27;  /* unsigned 27 bit Integer */
    1498. 

  1498. typedef SLONG   sint27;  /* signed 27 bit Integer */
    1499. 

  1499. typedef ULONG   uint28;  /* unsigned 28 bit Integer */
    1500. 

  1500. typedef SLONG   sint28;  /* signed 28 bit Integer */
    1501. 

  1501. typedef ULONG   uint29;  /* unsigned 29 bit Integer */
    1502. 

  1502. typedef SLONG   sint29;  /* signed 29 bit Integer */
    1503. 

  1503. typedef ULONG   uint30;  /* unsigned 30 bit Integer */
    1504. 

  1504. typedef SLONG   sint30;  /* signed 30 bit Integer */
    1505. 

  1505. typedef ULONG   uint31;  /* unsigned 31 bit Integer */
    1506. 

  1506. typedef SLONG   sint31;  /* signed 31 bit Integer */
    1507. 

  1507. typedef ULONG   uint32;  /* unsigned 32 bit Integer */
    1508. 

  1508. typedef SLONG   sint32;  /* signed 32 bit Integer */
    1509. 

  1509. #ifdef HAVE_LONG_LONG_INT
    1510. 

  1510.   typedef ULONGLONG  uint33;  /* unsigned 33 bit Integer */
    1511. 

  1511.   typedef SLONGLONG  sint33;  /* signed 33 bit Integer */
    1512. 

  1512.   typedef ULONGLONG  uint48;  /* unsigned 48 bit Integer */
    1513. 

  1513.   typedef SLONGLONG  sint48;  /* signed 48 bit Integer */
    1514. 

  1514.   typedef ULONGLONG  uint64;  /* unsigned 64 bit Integer */
    1515. 

  1515.   typedef SLONGLONG  sint64;  /* signed 64 bit Integer */
    1516. 

  1516. #endif
    1517. 

  1517. #define exact_uint_size_p(n) (((n)==char_bitsize)||((n)==short_bitsize)||((n)==int_bitsize)||((n)==long_bitsize))
    1518. 

  1518. #define signed_int_with_n_bits(n) CONCAT(sint,n)
    1519. 

  1519. #define unsigned_int_with_n_bits(n) CONCAT(uint,n)
    1520. 

  1520. /* Use 'uintn' and 'sintn' for Integers with exactly specified width.
    1521. 

  1521.  exact_uint_size_p(n) specifies, whether the uint with n Bits has really
    1522. 

  1522.  only n Bits. */
    1523. 

  1523. %% { int i;
    1524. 

  1524. %%   for (i=1; i<=8; i++) {
    1525. 

  1525. %%     sprintf(buf,"uint%d",i); emit_typedef("UBYTE",buf);
    1526. 

  1526. %%     sprintf(buf,"sint%d",i); emit_typedef("SBYTE",buf);
    1527. 

  1527. %%   }
    1528. 

  1528. %%   for (i=9; i<=16; i++) {
    1529. 

  1529. %%     sprintf(buf,"uint%d",i); emit_typedef("UWORD",buf);
    1530. 

  1530. %%     sprintf(buf,"sint%d",i); emit_typedef("SWORD",buf);
    1531. 

  1531. %%   }
    1532. 

  1532. %%   for (i=17; i<=32; i++) {
    1533. 

  1533. %%     sprintf(buf,"uint%d",i); emit_typedef("ULONG",buf);
    1534. 

  1534. %%     sprintf(buf,"sint%d",i); emit_typedef("SLONG",buf);
    1535. 

  1535. %%   }
    1536. 

  1536. %%   #ifdef HAVE_LONG_LONG_INT
    1537. 

  1537. %%     for (i=33; i<=64; i++)
    1538. 

  1538. %%       if ((i==33) || (i==48) || (i==64)) {
    1539. 

  1539. %%         sprintf(buf,"uint%d",i); emit_typedef("ULONGLONG",buf);
    1540. 

  1540. %%         sprintf(buf,"sint%d",i); emit_typedef("SLONGLONG",buf);
    1541. 

  1541. %%       }
    1542. 

  1542. %%   #endif
    1543. 

  1543. %% }
    1544. 

  1544. 

  1545. /* 'uintX' and 'sintX' mean unsigned bzw. signed integer - types with
    1546. 

  1546.  wordsize X (X=B,W,L,Q) here as well. */
    1547. 

  1547. #define intBsize 8
    1548. 

  1548.   typedef signed_int_with_n_bits(intBsize)    sintB;
    1549. 

  1549.   typedef unsigned_int_with_n_bits(intBsize)  uintB;
    1550. 

  1550. #define intWsize 16
    1551. 

  1551.   typedef signed_int_with_n_bits(intWsize)    sintW;
    1552. 

  1552.   typedef unsigned_int_with_n_bits(intWsize)  uintW;
    1553. 

  1553. #define intLsize 32
    1554. 

  1554.   typedef signed_int_with_n_bits(intLsize)    sintL;
    1555. 

  1555.   typedef unsigned_int_with_n_bits(intLsize)  uintL;
    1556. 

  1556. #if defined(DECALPHA) || defined(MIPS64) || defined(SPARC64) || defined(IA64) || defined(AMD64)
    1557. 

  1557.   /* Machine has real 64-bit integers in hardware. */
    1558. 

  1558.   #define intQsize 64
    1559. 

  1559.   typedef signed_int_with_n_bits(intQsize)    sintQ;
    1560. 

  1560.   typedef unsigned_int_with_n_bits(intQsize)  uintQ;
    1561. 

  1561.   typedef sintQ  sintL2;
    1562. 

  1562.   typedef uintQ  uintL2;
    1563. 

  1563. #else
    1564. 

  1564.   /* Emulate 64-Bit-numbers using two 32-Bit-numbers. */
    1565. 

  1565.   typedef struct { sintL hi; uintL lo; } sintL2; /* signed 64 Bit integer */
    1566. 

  1566.   typedef struct { uintL hi; uintL lo; } uintL2; /* unsigned 64 Bit integer */
    1567. 

  1567. #endif
    1568. 

  1568. /* Use 'uintX' and 'sintX' for Integers with approximately given width
    1569. 

  1569.  and a minumum of storage space. */
    1570. 

  1570. %% sprintf(buf,"sint%d",intBsize); emit_typedef(buf,"sintB");
    1571. 

  1571. %% sprintf(buf,"uint%d",intBsize); emit_typedef(buf,"uintB");
    1572. 

  1572. %% #if notused
    1573. 

  1573. %% sprintf(buf,"sint%d",intWsize); emit_typedef(buf,"sintW");
    1574. 

  1574. %% #endif
    1575. 

  1575. %% sprintf(buf,"uint%d",intWsize); emit_typedef(buf,"uintW");
    1576. 

  1576. %% sprintf(buf,"sint%d",intLsize); emit_typedef(buf,"sintL");
    1577. 

  1577. %% sprintf(buf,"uint%d",intLsize); emit_typedef(buf,"uintL");
    1578. 

  1578. %% #if notused
    1579. 

  1579. %% #ifdef intQsize
    1580. 

  1580. %%   sprintf(buf,"sint%d",intQsize); emit_typedef(buf,"sintQ");
    1581. 

  1581. %%   sprintf(buf,"uint%d",intQsize); emit_typedef(buf,"uintQ");
    1582. 

  1582. %% #else
    1583. 

  1583. %%   emit_typedef("struct { sintL hi; uintL lo; }","sintL2");
    1584. 

  1584. %%   emit_typedef("struct { uintL hi; uintL lo; }","uintL2");
    1585. 

  1585. %% #endif
    1586. 

  1586. %% #endif
    1587. 

  1587. 

  1588. /* From here on 'uintP' and 'sintP' are unsigned or signed integer types,
    1589. 

  1589.  which are as wide as void* - pointers */
    1590. 

  1590. typedef signed_int_with_n_bits(pointer_bitsize)    sintP;
    1591. 

  1591. typedef unsigned_int_with_n_bits(pointer_bitsize)  uintP;
    1592. 

  1592. %% sprintf(buf,"sint%d",pointer_bitsize); emit_typedef(buf,"sintP");
    1593. 

  1593. %% sprintf(buf,"uint%d",pointer_bitsize); emit_typedef(buf,"uintP");
    1594. 

  1594. 

  1595. /* From here on 'uintXY' and 'sintXY' mean unsigned or signed integer types,
    1596. 

  1596.  with word sizes X or Y (X,Y=B,W,L). */
    1597. 

  1597. #if (defined(MC680X0) && !defined(HPUX_ASSEMBLER)) || defined(VAX)
    1598. 

  1598.   /* The 68000 offers good processing of uintB and uintW, especially
    1599. 

  1599.    DBRA-commands for uintW. */
    1600. 

  1600.   #define intBWsize intBsize
    1601. 

  1601.   #define intWLsize intWsize
    1602. 

  1602.   #define intBWLsize intBsize
    1603. 

  1603. #elif (defined(MC680X0) && defined(HPUX_ASSEMBLER)) || defined(SPARC) || defined(HPPA) || defined(MIPS) || defined(M88000) || defined(POWERPC) || defined(S390)
    1604. 

  1604.   /* The Sparc-processor computes rather badly with uintB and uintW.
    1605. 

  1605.    Other 32-Bit-processoren have similar weaknesses. */
    1606. 

  1606.   #define intBWsize intWsize
    1607. 

  1607.   #define intWLsize intLsize
    1608. 

  1608.   #define intBWLsize intLsize
    1609. 

  1609. #elif defined(I80386) || defined(AMD64)
    1610. 

  1610.   /* If you compute using uintB and uintW on a 80386, there will be many
    1611. 

  1611.    Zero-Extends, that will - because there aren't enough registers - load
    1612. 

  1612.    other variables into memory, which is rather unnecessary. */
    1613. 

  1613.   #define intBWsize intWsize
    1614. 

  1614.   #define intWLsize intLsize
    1615. 

  1615.   #define intBWLsize intLsize
    1616. 

  1616. #elif defined(ARM)
    1617. 

  1617.   /* The ARM computes very badly when it uses uintB and uintW. */
    1618. 

  1618.   #define intBWsize intBsize
    1619. 

  1619.   #define intWLsize intLsize
    1620. 

  1620.   #define intBWLsize intLsize
    1621. 

  1621. #elif defined(DECALPHA) || defined(IA64)
    1622. 

  1622.   /* 64-bit processors also compute badly with uintB and uintW. */
    1623. 

  1623.   #define intBWsize intWsize
    1624. 

  1624.   #define intWLsize intLsize
    1625. 

  1625.   #define intBWLsize intLsize
    1626. 

  1626. #else
    1627. 

  1627.   #error "Preferred integer sizes depend on CPU -- readjust intBWsize, intWLsize, intBWLsize!"
    1628. 

  1628. #endif
    1629. 

  1629. typedef signed_int_with_n_bits(intBWsize)     sintBW;
    1630. 

  1630. typedef unsigned_int_with_n_bits(intBWsize)   uintBW;
    1631. 

  1631. typedef signed_int_with_n_bits(intWLsize)     sintWL;
    1632. 

  1632. typedef unsigned_int_with_n_bits(intWLsize)   uintWL;
    1633. 

  1633. typedef signed_int_with_n_bits(intBWLsize)    sintBWL;
    1634. 

  1634. typedef unsigned_int_with_n_bits(intBWLsize)  uintBWL;
    1635. 

  1635. /* Use 'uintXY' and 'sintXY' for integers with given minumum width,
    1636. 

  1636.  that allow easy computations. */
    1637. 

  1637. %% #if notused
    1638. 

  1638. %% sprintf(buf,"sint%d",intBWsize); emit_typedef(buf,"sintBW");
    1639. 

  1639. %% sprintf(buf,"uint%d",intBWsize); emit_typedef(buf,"uintBW");
    1640. 

  1640. %% sprintf(buf,"sint%d",intWLsize); emit_typedef(buf,"sintWL");
    1641. 

  1641. %% #endif
    1642. 

  1642. %% sprintf(buf,"uint%d",intWLsize); emit_typedef(buf,"uintWL");
    1643. 

  1643. %% #if notused
    1644. 

  1644. %% sprintf(buf,"sint%d",intBWLsize); emit_typedef(buf,"sintBWL");
    1645. 

  1645. %% #endif
    1646. 

  1646. %% sprintf(buf,"uint%d",intBWLsize); emit_typedef(buf,"uintBWL");
    1647. 

  1647. 

  1648. /* Loop that will excute as statement a certain number of times:
    1649. 

  1649.  dotimesW(countvar,count,statement);  if count fits into a uintW,
    1650. 

  1650.  dotimesL(countvar,count,statement);  if  count only fits into a uintL,
    1651. 

  1651.  dotimesV(countvar,count,statement);  if  count only fits into a uintV,
    1652. 

  1652.  dotimespW(countvar,count,statement);  if count fits into a uintW and is >0,
    1653. 

  1653.  dotimespL(countvar,count,statement);  if count fits only into a uintL and is >0.
    1654. 

  1654.  dotimespV(countvar,count,statement);  if count fits only into a uintV and is >0.
    1655. 

  1655.  The variable countvar has to be declared previously, be of type uintW or uintL,
    1656. 

  1656.  and will be changed by this expression.
    1657. 

  1657.  It must not be used in the statement itself!
    1658. 

  1658.  The expression count will only be evaluated once (at the beginning). */
    1659. 

  1659. #if defined(GNU) && defined(MC680X0) && !defined(HPUX_ASSEMBLER)
    1660. 

  1660.   /* GNU-C on a 680X0 can be persuaded to use the DBRA-instruction: */
    1661. 

  1661.   #define fast_dotimesW
    1662. 

  1662.   /* To find out, what the best was to 'persuade' GNU-C is, check the
    1663. 

  1663.    code, that'll be generated for spvw.d:gc_markphase().
    1664. 

  1664.    Or a small test program (dbratest.c), that is compiled with
    1665. 

  1665.    "gcc -O6 -da -S dbratest.c", and take a look at dbratest.s
    1666. 

  1666.    and dbratest.c.flow as well as dbratest.c.combine. */
    1667. 

  1667.   #if (__GNUC__<2) /* GNU C Version 1 */
    1668. 

  1668.     #define dotimesW_(countvar_from_dotimesW,count_from_dotimesW,statement_from_dotimesW)  \
    1669. 

  1669.       { countvar_from_dotimesW = (count_from_dotimesW);     \
    1670. 

  1670.         if (!(countvar_from_dotimesW==0))                   \
    1671. 

  1671.           { countvar_from_dotimesW--;                       \
    1672. 

  1672.             do {statement_from_dotimesW}                    \
    1673. 

  1673.             while ((sintW)--countvar_from_dotimesW != -1);  \
    1674. 

  1674.       }   }
    1675. 

  1675.     #define dotimespW_(countvar_from_dotimespW,count_from_dotimespW,statement_from_dotimespW)  \
    1676. 

  1676.       { countvar_from_dotimespW = (count_from_dotimespW)-1;                         \
    1677. 

  1677.         do {statement_from_dotimespW} while ((sintW)--countvar_from_dotimespW != -1); \
    1678. 

  1678.       }
    1679. 

  1679.   #else
    1680. 

  1680.     #define dotimesW_(countvar_from_dotimesW,count_from_dotimesW,statement_from_dotimesW)  \
    1681. 

  1681.       { countvar_from_dotimesW = (count_from_dotimesW);        \
    1682. 

  1682.         if (!(countvar_from_dotimesW==0))                      \
    1683. 

  1683.           { countvar_from_dotimesW--;                          \
    1684. 

  1684.             do {statement_from_dotimesW}                       \
    1685. 

  1685.             while ((sintW)(--countvar_from_dotimesW)+1 != 0);  \
    1686. 

  1686.       }   }
    1687. 

  1687.     #define dotimespW_(countvar_from_dotimespW,count_from_dotimespW,statement_from_dotimespW)  \
    1688. 

  1688.       { countvar_from_dotimespW = (count_from_dotimespW)-1;                            \
    1689. 

  1689.         do {statement_from_dotimespW} while ((sintW)(--countvar_from_dotimespW)+1 != 0); \
    1690. 

  1690.       }
    1691. 

  1691.   #endif
    1692. 

  1692. #else
    1693. 

  1693.   #define dotimesW_(countvar_from_dotimesW,count_from_dotimesW,statement_from_dotimesW)  \
    1694. 

  1694.     { countvar_from_dotimesW = (count_from_dotimesW);         \
    1695. 

  1695.       while (countvar_from_dotimesW != 0)                       \
    1696. 

  1696.         {statement_from_dotimesW; countvar_from_dotimesW--; } \
    1697. 

  1697.     }
    1698. 

  1698.   #define dotimespW_(countvar_from_dotimespW,count_from_dotimespW,statement_from_dotimespW)  \
    1699. 

  1699.     { countvar_from_dotimespW = (count_from_dotimespW);                   \
    1700. 

  1700.       do {statement_from_dotimespW} while (--countvar_from_dotimespW != 0); \
    1701. 

  1701.     }
    1702. 

  1702. #endif
    1703. 

  1703. #if defined(GNU) && defined(MC680X0) && !defined(HPUX_ASSEMBLER)
    1704. 

  1704.   /* GNU-C on a 680X0 can be 'persuaded' to use the DBRA-instruction
    1705. 

  1705.    in an intelligent manner: */
    1706. 

  1706.   #define fast_dotimesL
    1707. 

  1707.   #define dotimesL_(countvar_from_dotimesL,count_from_dotimesL,statement_from_dotimesL)  \
    1708. 

  1708.     { countvar_from_dotimesL = (count_from_dotimesL);           \
    1709. 

  1709.       if (!(countvar_from_dotimesL==0))                         \
    1710. 

  1710.         { countvar_from_dotimesL--;                             \
    1711. 

  1711.           do {statement_from_dotimesL}                          \
    1712. 

  1712.           while ((sintL)(--countvar_from_dotimesL)  !=  -1);    \
    1713. 

  1713.     }   }
    1714. 

  1714.   #define dotimespL_(countvar_from_dotimespL,count_from_dotimespL,statement_from_dotimespL)  \
    1715. 

  1715.     { countvar_from_dotimespL = (count_from_dotimespL)-1;                             \
    1716. 

  1716.       do {statement_from_dotimespL} while ((sintL)(--countvar_from_dotimespL)  !=  -1); \
    1717. 

  1717.     }
    1718. 

  1718. #endif
    1719. 

  1719. #ifndef dotimesL_
    1720. 

  1720.   #define dotimesL_(countvar_from_dotimesL,count_from_dotimesL,statement_from_dotimesL)  \
    1721. 

  1721.     { countvar_from_dotimesL = (count_from_dotimesL);         \
    1722. 

  1722.       while (countvar_from_dotimesL != 0)                       \
    1723. 

  1723.         {statement_from_dotimesL; countvar_from_dotimesL--; } \
    1724. 

  1724.     }
    1725. 

  1725.   #define dotimespL_(countvar_from_dotimespL,count_from_dotimespL,statement_from_dotimespL)  \
    1726. 

  1726.     { countvar_from_dotimespL = (count_from_dotimespL);                   \
    1727. 

  1727.       do {statement_from_dotimespL} while (--countvar_from_dotimespL != 0); \
    1728. 

  1728.     }
    1729. 

  1729. #endif
    1730. 

  1730. #if defined(GNU) && defined(__OPTIMIZE__)
    1731. 

  1731.   /* It happened twice to me that I used dotimesL on a
    1732. 

  1732.    variable of type uintC. I check for that now, so that
    1733. 

  1733.    Joerg and Marcus won't have to search for that anymore.
    1734. 

  1734.    The GCC will optimize the dummy-call away, if things go by plan.
    1735. 

  1735.    If not, you'll see a linker error. */
    1736. 

  1736.   #define dotimes_check_sizeof(countvar,type)  \
    1737. 

  1737.     if (!(sizeof(countvar)==sizeof(type))) { dotimes_called_with_count_of_wrong_size(); }
    1738. 

  1738.   extern void dotimes_called_with_count_of_wrong_size (void); /* non-existing function */
    1739. 

  1739. #else
    1740. 

  1740.   #define dotimes_check_sizeof(countvar,type)
    1741. 

  1741. #endif
    1742. 

  1742. #define dotimesW(countvar_from_dotimesW,count_from_dotimesW,statement_from_dotimesW) \
    1743. 

  1743.   do { dotimes_check_sizeof(countvar_from_dotimesW,uintW); \
    1744. 

  1744.     dotimesW_(countvar_from_dotimesW,count_from_dotimesW,statement_from_dotimesW); \
    1745. 

  1745.   } while(0)
    1746. 

  1746. #define dotimespW(countvar_from_dotimespW,count_from_dotimespW,statement_from_dotimespW) \
    1747. 

  1747.   do { dotimes_check_sizeof(countvar_from_dotimespW,uintW); \
    1748. 

  1748.     dotimespW_(countvar_from_dotimespW,count_from_dotimespW,statement_from_dotimespW); \
    1749. 

  1749.   } while(0)
    1750. 

  1750. #define dotimesL(countvar_from_dotimesL,count_from_dotimesL,statement_from_dotimesL) \
    1751. 

  1751.   do { dotimes_check_sizeof(countvar_from_dotimesL,uintL); \
    1752. 

  1752.     dotimesL_(countvar_from_dotimesL,count_from_dotimesL,statement_from_dotimesL); \
    1753. 

  1753.   } while(0)
    1754. 

  1754. #define dotimespL(countvar_from_dotimespL,count_from_dotimespL,statement_from_dotimespL) \
    1755. 

  1755.   do { dotimes_check_sizeof(countvar_from_dotimespL,uintL); \
    1756. 

  1756.     dotimespL_(countvar_from_dotimespL,count_from_dotimespL,statement_from_dotimespL); \
    1757. 

  1757.   } while(0)
    1758. 

  1758. #define dotimesV(countvar_from_dotimesV,count_from_dotimesV,statement_from_dotimesV) \
    1759. 

  1759.   do { dotimes_check_sizeof(countvar_from_dotimesV,uintV); \
    1760. 

  1760.     dotimesL_(countvar_from_dotimesV,count_from_dotimesV,statement_from_dotimesV); \
    1761. 

  1761.   } while(0)
    1762. 

  1762. #define dotimespV(countvar_from_dotimespV,count_from_dotimespV,statement_from_dotimespV) \
    1763. 

  1763.   do { dotimes_check_sizeof(countvar_from_dotimespV,uintV); \
    1764. 

  1764.     dotimespL_(countvar_from_dotimespV,count_from_dotimespV,statement_from_dotimespV); \
    1765. 

  1765.   } while(0)
    1766. 

  1766. /* doconsttimes(count,statement);
    1767. 

  1767.  executes a statement count times (count times the code!),
    1768. 

  1768.  where count is a constant-expression >=0, <=8. */
    1769. 

  1769. #define doconsttimes(count_from_doconsttimes,statement_from_doconsttimes) \
    1770. 

  1770.  do { if (0 < (count_from_doconsttimes)) { statement_from_doconsttimes; } \
    1771. 

  1771.       if (1 < (count_from_doconsttimes)) { statement_from_doconsttimes; } \
    1772. 

  1772.       if (2 < (count_from_doconsttimes)) { statement_from_doconsttimes; } \
    1773. 

  1773.       if (3 < (count_from_doconsttimes)) { statement_from_doconsttimes; } \
    1774. 

  1774.       if (4 < (count_from_doconsttimes)) { statement_from_doconsttimes; } \
    1775. 

  1775.       if (5 < (count_from_doconsttimes)) { statement_from_doconsttimes; } \
    1776. 

  1776.       if (6 < (count_from_doconsttimes)) { statement_from_doconsttimes; } \
    1777. 

  1777.       if (7 < (count_from_doconsttimes)) { statement_from_doconsttimes; } \
    1778. 

  1778.  } while(0)
    1779. 

  1779. /* DOCONSTTIMES(count,macroname);
    1780. 

  1780.  calls the macro macroname count times (count times the code!),
    1781. 

  1781.  where count is a constant-expression >=0, <=8.
    1782. 

  1782.  And macroname will get the values 0,...,count-1 in sequence. */
    1783. 

  1783. #define DOCONSTTIMES(count_from_DOCONSTTIMES,macroname_from_DOCONSTTIMES)  \
    1784. 

  1784.  do { if (0 < (count_from_DOCONSTTIMES)) { macroname_from_DOCONSTTIMES((0 < (count_from_DOCONSTTIMES) ? 0 : 0)); } \
    1785. 

  1785.       if (1 < (count_from_DOCONSTTIMES)) { macroname_from_DOCONSTTIMES((1 < (count_from_DOCONSTTIMES) ? 1 : 0)); } \
    1786. 

  1786.       if (2 < (count_from_DOCONSTTIMES)) { macroname_from_DOCONSTTIMES((2 < (count_from_DOCONSTTIMES) ? 2 : 0)); } \
    1787. 

  1787.       if (3 < (count_from_DOCONSTTIMES)) { macroname_from_DOCONSTTIMES((3 < (count_from_DOCONSTTIMES) ? 3 : 0)); } \
    1788. 

  1788.       if (4 < (count_from_DOCONSTTIMES)) { macroname_from_DOCONSTTIMES((4 < (count_from_DOCONSTTIMES) ? 4 : 0)); } \
    1789. 

  1789.       if (5 < (count_from_DOCONSTTIMES)) { macroname_from_DOCONSTTIMES((5 < (count_from_DOCONSTTIMES) ? 5 : 0)); } \
    1790. 

  1790.       if (6 < (count_from_DOCONSTTIMES)) { macroname_from_DOCONSTTIMES((6 < (count_from_DOCONSTTIMES) ? 6 : 0)); } \
    1791. 

  1791.       if (7 < (count_from_DOCONSTTIMES)) { macroname_from_DOCONSTTIMES((7 < (count_from_DOCONSTTIMES) ? 7 : 0)); } \
    1792. 

  1792.  } while(0)
    1793. 

  1793. 

  1794. /* From here on  uintC means an unsigned integer type, that'll allow
    1795. 

  1795.  easy counting. Subset relation: uintW <= uintC <= uintL. */
    1796. 

  1796. #define intCsize intWLsize
    1797. 

  1797. #define uintC uintWL
    1798. 

  1798. #define sintC sintWL
    1799. 

  1799. #if (intCsize==intWsize)
    1800. 

  1800.   #define dotimesC dotimesW
    1801. 

  1801.   #define dotimespC dotimespW
    1802. 

  1802. #endif
    1803. 

  1803. #if (intCsize==intLsize)
    1804. 

  1804.   #define dotimesC dotimesL
    1805. 

  1805.   #define dotimespC dotimespL
    1806. 

  1806. #endif
    1807. 

  1807. /* Use 'uintC' for counters, which are small most of the time. */
    1808. 

  1808. %% export_def(uintC);
    1809. 

  1809. %% #if notused
    1810. 

  1810. %% export_def(sintC);
    1811. 

  1811. %% #endif
    1812. 

  1812. 

  1813. /* The arithmetics use "digit sequences" of "digits".
    1814. 

  1814.  They are unsigned ints with intDsize bits (should be =8 or =16 or =32).
    1815. 

  1815.  If  HAVE_DD: "double-digits" are unsigned ints with 2*intDsize<=32 bits. */
    1816. 

  1816. #if defined(MC680X0) && !defined(MC680Y0)
    1817. 

  1817.   #define intDsize 16
    1818. 

  1818.   #define intDDsize 32  /* = 2*intDsize */
    1819. 

  1819.   #define log2_intDsize  4  /* = log2(intDsize) */
    1820. 

  1820. #elif defined(MC680Y0) || defined(I80386) || defined(SPARC) || defined(HPPA) || defined(MIPS) || defined(M88000) || defined(POWERPC) || defined(VAX) || defined(ARM) || defined(DECALPHA) || defined(IA64) || defined(AMD64) || defined(S390)
    1821. 

  1821.   #define intDsize 32
    1822. 

  1822.   #define intDDsize 64  /* = 2*intDsize */
    1823. 

  1823.   #define log2_intDsize  5  /* = log2(intDsize) */
    1824. 

  1824. #else
    1825. 

  1825.   #error "Preferred digit size depends on CPU -- readjust intDsize!"
    1826. 

  1826. #endif
    1827. 

  1827. typedef unsigned_int_with_n_bits(intDsize)  uintD;
    1828. 

  1828. typedef signed_int_with_n_bits(intDsize)    sintD;
    1829. 

  1829. #if (intDDsize<=32) || ((intDDsize<=64) && (defined(DECALPHA) || defined(MIPS64) || defined(SPARC64) || defined(IA64) || defined(AMD64)))
    1830. 

  1830.   #define HAVE_DD 1
    1831. 

  1831.   typedef unsigned_int_with_n_bits(intDDsize)  uintDD;
    1832. 

  1832.   typedef signed_int_with_n_bits(intDDsize)    sintDD;
    1833. 

  1833. #else
    1834. 

  1834.   #define HAVE_DD 0
    1835. 

  1835. #endif
    1836. 

  1836. %% #if notused
    1837. 

  1837. %% sprintf(buf,"sint%d",intDsize); emit_typedef(buf,"sintD");
    1838. 

  1838. %% #endif
    1839. 

  1839. %% sprintf(buf,"uint%d",intDsize); emit_typedef(buf,"uintD");
    1840. 

  1840. 

  1841. /* Other acronyms like 'oint', 'tint', 'aint', 'cint' will be used
    1842. 

  1842.    for the corresponding integer types:
    1843. 

  1843.    Integer type      contains information equivalent to
    1844. 

  1844.       oint           LISP object
    1845. 

  1845.       tint           type code of a LISP object
    1846. 

  1846.       aint           address of a LISP object
    1847. 

  1847.       cint           LISP character
    1848. 

    1849. 

  1849.  Usually sizeof(oint) = sizeof(aint) = sizeof(uintL) = 32 Bit.
    1850. 

  1850.  Under the model WIDE sizeof(oint) is > sizeof(uintL).
    1851. 

  1851.  Model WIDE_HARD stands for sizeof(aint) > sizeof(uintL).
    1852. 

  1852.    This model is to be chosen if the following holds true:
    1853. 

  1853.    sizeof(void*) > sizeof(uintL) = 32 bit. It also requires that
    1854. 

  1854.    sizeof(long) = sizeof(void*) = 64 bit, because some 64-bit numbers
    1855. 

  1855.    appear as pre-processor constants.
    1856. 

  1856.  Model WIDE_SOFT stands for sizeof(oint) = 64 bit and sizeof(aint) = 32 bit.
    1857. 

  1857.    This model can be chosen on any 32-Bit-Machine, if the
    1858. 

  1858.    compiler has 64-bit numbers (in software or hardware).
    1859. 

  1859.    You will also need to choose it, if there would not be enough space
    1860. 

  1860.    for the type-bits in a 32-bit pointer.
    1861. 

  1861.  Model HEAPCODES stands for sizeof(oint) = sizeof(aint), and only minimal
    1862. 

  1862.    type information is stored in a pointer. All heap allocated objects
    1863. 

  1863.    (except conses) must contain the complete type and a length field in the
    1864. 

  1864.    first word. The heap gets somewhat bigger by this, and type tests require
    1865. 

  1865.    more memory accesses on average, but this model is portable even to
    1866. 

  1866.    systems whose memory map looks like Swiss Cheese. */
    1867. 

  1867. 

  1868. %% #if notused
    1869. 

  1869. %% #ifdef WIDE_HARD
    1870. 

  1870. %%   puts("#define WIDE_HARD");
    1871. 

  1871. %% #endif
    1872. 

  1872. %% #ifdef WIDE_SOFT
    1873. 

  1873. %%   puts("#define WIDE_SOFT");
    1874. 

  1874. %% #endif
    1875. 

  1875. %% #ifdef WIDE_AUXI
    1876. 

  1876. %%   puts("#define WIDE_AUXI");
    1877. 

  1877. %% #endif
    1878. 

  1878. %% #ifdef WIDE
    1879. 

  1879. %%   puts("#define WIDE");
    1880. 

  1880. %% #endif
    1881. 

  1881. %% #endif
    1882. 

  1882. 

  1883. #if defined(STANDARD_HEAPCODES) || defined(LINUX_NOEXEC_HEAPCODES)
    1884. 

  1884.   #define HEAPCODES
    1885. 

  1885. #endif
    1886. 

  1886. 

  1887. #if defined(WIDE_SOFT) && defined(HEAPCODES)
    1888. 

  1888.   #error "WIDE_SOFT and HEAPCODES make no sense together, no need for WIDE_SOFT"
    1889. 

  1889. #endif
    1890. 

  1890. 

  1891. #if defined(TYPECODES) && defined(HEAPCODES)
    1892. 

  1892.   #error "TYPECODES and HEAPCODES make no sense together"
    1893. 

  1893. #endif
    1894. 

  1894. 

  1895. #if !(defined(TYPECODES) || defined(HEAPCODES))
    1896. 

  1896.   /* Choose typecodes on 64-bit machines (because there's enough room for type
    1897. 

  1897.    bits), but not on 32-bit machines (because a 16 MB limit is ridiculous
    1898. 

  1898.    today), except if the CPU cannot address more than 16 MB anyway.
    1899. 

  1899.    HEAPCODES will normally not work if alignof(subr_t) = alignof(long) < 4,
    1900. 

  1900.    but with egcs-1.1 or newer we can force alignof(subr_t) = 4. */
    1901. 

  1901.   #if defined(WIDE_HARD) || defined(WIDE_SOFT) || defined(MC68000) || ((alignment_long < 4) && !defined(GNU))
    1902. 

  1902.     #define TYPECODES
    1903. 

  1903.   #else
    1904. 

  1904.     #define HEAPCODES
    1905. 

  1905.   #endif
    1906. 

  1906. #endif
    1907. 

  1907. %% #ifdef HEAPCODES
    1908. 

  1908. %%   puts("#define HEAPCODES");
    1909. 

  1909. %% #endif
    1910. 

  1910. 

  1911. #ifdef WIDE_SOFT
    1912. 

  1912.   #if defined(GNU) && !defined(WIDE_SOFT_LARGEFIXNUM)
    1913. 

  1913.     /* Use the GNU-C extensions, to regard the wide oints as structs. */
    1914. 

  1914.     #define WIDE_STRUCT
    1915. 

  1915.   #endif
    1916. 

  1916.   /* defines the arrangement of an oint's elements: */
    1917. 

  1917.   #define WIDE_ENDIANNESS true  /* more efficient this way */
    1918. 

  1918. #endif
    1919. 

  1919. 

  1920. #if defined(GNU) && (SAFETY >= 3)
    1921. 

  1921.   #if (__GNUC__ >= 2)
    1922. 

  1922.     #if (__GNUC__ > 2) || (__GNUC_MINOR__ >= 7) /* circumvent gcc-2.6.3 bug */
    1923. 

  1923.       /* Typechecking by the C-compiler */
    1924. 

  1924.       #define OBJECT_STRUCT
    1925. 

  1925.       #if !(defined(MC680X0) || defined(ARM)) && !(defined(__GNUG__) && (__GNUC__ == 3) && (__GNUC_MINOR__ == 3)) /* only if struct_alignment==1, and not with g++ 3.3 */
    1926. 

  1926.         #define CHART_STRUCT
    1927. 

  1927.       #endif
    1928. 

  1928.     #endif
    1929. 

  1929.   #endif
    1930. 

  1930. #endif
    1931. 

  1931. 

  1932. 

  1933. /* ###################### OS-related routines  #################### */
    1934. 

  1934. 

  1935. /* general standard constants for control chars: */
    1936. 

  1936. #define BS    8  /*  #\Backspace     Backspace */
    1937. 

  1937. #define TAB   9  /*  #\Tab           Tabulator */
    1938. 

  1938. #define LF   10  /*  #\Linefeed      linefeed */
    1939. 

  1939. #define CR   13  /*  #\Return        carriage return */
    1940. 

  1940. #define PG   12  /*  #\Page          form feed, new page */
    1941. 

  1941. 

  1942. /* Desired reaction when an I/O operation cannot be completed immediately. */
    1943. 

  1943. typedef enum {
    1944. 

  1944.   persev_full,      /* Continue the I/O operation until the whole buffer is
    1945. 

  1945.                        handled or EOF or an error occurred. May hang. */
    1946. 

  1946.   persev_partial,   /* Continue the I/O operation until some (non-empty) part
    1947. 

  1947.                        of the buffer is handled or EOF or an error occurred.
    1948. 

  1948.                        May hang. */
    1949. 

  1949.   persev_immediate, /* Act immediately. Perform I/O only if we know in advance
    1950. 

  1950.                        that it will not block. In case of doubt, perform it
    1951. 

  1951.                        anyway. May return with 0 bytes handled. Does usually
    1952. 

  1952.                        not hang. */
    1953. 

  1953.   persev_bonus      /* Act immediately. Perform I/O only if we know in advance
    1954. 

  1954.                        that it will not block. In case of doubt, don't perform
    1955. 

  1955.                        it. May return with 0 bytes handled. Does not hang. */
    1956. 

  1956. } perseverance_t;
    1957. 

  1957. %% 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);
    1958. 

  1958. 

  1959. #if defined(UNIX) || defined(WIN32)
    1960. 

  1960. 

  1961. #ifdef UNIX
    1962. 

  1962.   #include "unix.c"
    1963. 

  1963. #endif
    1964. 

  1964. #ifdef WIN32_NATIVE
    1965. 

  1965.   #include "win32.c"
    1966. 

  1966. #endif
    1967. 

  1967. %% puts("#include <stdlib.h>");
    1968. 

  1968. %% puts("#include <sys/types.h>");
    1969. 

  1969. %% #if defined(UNIX)
    1970. 

  1970. %%   emit_typedef("int","Handle");
    1971. 

  1971. %%   emit_typedef("int","SOCKET");
    1972. 

  1972. %%   #ifdef UNIX_CYGWIN32
    1973. 

  1973. %%     puts("#include <windows.h>");
    1974. 

  1974. %%     puts("#undef WIN32");
    1975. 

  1975. %%     puts("extern long time_t_from_filetime (const FILETIME * ptr);");
    1976. 

  1976. %%     puts("extern void time_t_to_filetime (time_t time_in, FILETIME * out);");
    1977. 

  1977. %%   #endif
    1978. 

  1978. %% #elif defined(WIN32_NATIVE)
    1979. 

  1979. %%   puts("#include <windows.h>");
    1980. 

  1980. %%   export_def(Handle);
    1981. 

  1981. %%   puts("#include <winsock2.h>"); /* defines SOCKET */
    1982. 

  1982. %% #else
    1983. 

  1983. %%   puts("#error \"what is Handle on your platform?!\"");
    1984. 

  1984. %% #endif
    1985. 

  1985. %% #if defined(UNIX)
    1986. 

  1986. %%   puts("extern ssize_t fd_read (int fd, void* buf, size_t nbyte, perseverance_t persev);");
    1987. 

  1987. %%   puts("extern ssize_t fd_write (int fd, const void* buf, size_t nbyte, perseverance_t persev);");
    1988. 

  1988. %% #elif defined(WIN32_NATIVE)
    1989. 

  1989. %%   puts("extern ssize_t fd_read (Handle fd, void* buf, size_t nbyte, perseverance_t persev);");
    1990. 

  1990. %%   puts("extern ssize_t fd_write (Handle fd, const void* buf, size_t nbyte, perseverance_t persev);");
    1991. 

  1991. %% #endif
    1992. 

  1992. 

  1993. /* execute statement on interrupt:
    1994. 

  1994.  interruptp(statement); */
    1995. 

  1995. #if defined(UNIX) || defined(WIN32_NATIVE)
    1996. 

  1996.   /* A keyboard interrupt (signal SIGINT, generated by Ctrl-C)
    1997. 

  1997.    is pending for one second. It can be treated with 'interruptp' in
    1998. 

  1998.    a continuing manner in that time. After this time has passed, the
    1999. 

  1999.    program will be interrupted and can't be continued.. */
    2000. 

  2000.   #define PENDING_INTERRUPTS
    2001. 

  2001.   extern uintB interrupt_pending;
    2002. 

  2002.   #define interruptp(statement)  if (interrupt_pending) { statement; }
    2003. 

  2003. #endif
    2004. 

  2004. /* used by EVAL, IO, SPVW, STREAM */
    2005. 

  2005. 

  2006. #endif /* UNIX || WIN32 */
    2007. 

  2007. 

  2008. #if (defined(UNIX) || defined(WIN32_NATIVE)) && !defined(NO_SIGSEGV)
    2009. 

  2009.   /* Support for fault handling. */
    2010. 

  2010.   #include <sigsegv.h>
    2011. 

  2011.   #if defined(UNIX_CYGWIN32)
    2012. 

  2012.     /* <sigsegv.h> includes <windows.h> */
    2013. 

  2013.     #undef WIN32
    2014. 

  2014.   #endif
    2015. 

  2015. #endif
    2016. 

  2016. 

  2017. /* Ignoring of a value (instead of assigning it to a variable)
    2018. 

  2018.  unused ...
    2019. 

  2019.  <sigsegv.h> includes <windows.h> which uses unused! */
    2020. 

  2020. #ifndef unused                  /* win32.d defines unused */
    2021. 

  2021.  #ifdef GNU     /* to prevent a gcc-warning "statement with no effect" */
    2022. 

  2022.   #define unused  (void)
    2023. 

  2023.  #else
    2024. 

  2024.   #define unused
    2025. 

  2025.  #endif
    2026. 

  2026. #endif
    2027. 

  2027. %% export_def(unused);
    2028. 

  2028. 

  2029. /* Consensys and Solaris: "#define DS 3", "#define SP ESP", "#define EAX 11".
    2030. 

  2030.  Grr... */
    2031. 

  2031. #undef DS
    2032. 

  2032. #undef SP
    2033. 

  2033. #undef EAX
    2034. 

  2034. /* 386BSD does "#define CBLOCK 64". Grr... */
    2035. 

  2035. #undef CBLOCK
    2036. 

  2036. /* AIX 3.2.5 does "#define hz 100". Grr... */
    2037. 

  2037. #undef hz
    2038. 

  2038. /* MacOS X does "#define TIME_ABSOLUTE 0x00" and "#define TIME_RELATIVE 0x01".
    2039. 

  2039.  Grr... */
    2040. 

  2040. #undef TIME_ABSOLUTE
    2041. 

  2041. #undef TIME_RELATIVE
    2042. 

  2042. 

  2043. #ifdef UNIX
    2044. 

  2044.   /* Handling of UNIX errors
    2045. 

  2045.    OS_error();
    2046. 

  2046.    > int errno: error code */
    2047. 

  2047.     nonreturning_function(extern, OS_error, (void));
    2048. 

  2048.   /* used by SPVW, STREAM, PATHNAME, GRAPH */
    2049. 

  2049. #endif
    2050. 

  2050. #if defined(WIN32_NATIVE)
    2051. 

  2051.   /* Handling of Win32 errors
    2052. 

  2052.    OS_error();
    2053. 

  2053.    > GetLastError(): error code */
    2054. 

  2054.     nonreturning_function(extern, OS_error, (void));
    2055. 

  2055.   /* Handling of Winsock errors
    2056. 

  2056.    SOCK_error();
    2057. 

  2057.    > WSAGetLastError(): error code */
    2058. 

  2058.     nonreturning_function(extern, SOCK_error, (void));
    2059. 

  2059. #endif
    2060. 

  2060. #if defined(DEBUG_OS_ERROR)
    2061. 

  2061.   /* Show the file and line number of the caller of OS_error(). For debugging. */
    2062. 

  2062.   #define OS_error()  \
    2063. 

  2063.     (fprintf(stderr,"\n[%s:%d] ",__FILE__,__LINE__), (OS_error)())
    2064. 

  2064. #endif
    2065. 

  2065. %% puts("nonreturning_function(extern, OS_error, (void));");
    2066. 

  2066. 

  2067. /* Handling of ANSI C errors
    2068. 

  2068.  ANSIC_error();
    2069. 

  2069.  > int errno: error code */
    2070. 

  2070. #ifdef UNIX
    2071. 

  2071.   #define ANSIC_error OS_error
    2072. 

  2072. #else
    2073. 

  2073.   nonreturning_function(extern, ANSIC_error, (void));
    2074. 

  2074. #endif
    2075. 

  2075. /* used by SPVW, STREAM */
    2076. 

  2076. 

  2077. #ifdef MULTITHREAD
    2078. 

  2078. 

  2079. #include "xthread.c"
    2080. 

  2080. 

  2081. #if !(defined(HAVE_MMAP_ANON) || defined(HAVE_MMAP_DEVZERO) || defined(HAVE_MACH_VM) || defined(HAVE_WIN32_VM))
    2082. 

  2082.   #error "Multithreading requires memory mapping facilities!"
    2083. 

  2083. #endif
    2084. 

  2084. 

  2085. #endif
    2086. 

  2086. 

  2087. /* ##################### Further system-dependencies #################### */
    2088. 

  2088. 

  2089. /* At first dependencies that are visible to the LISP-level: */
    2090. 

  2090. 

  2091. /* setting of the table of character-names: */
    2092. 

  2092. #ifdef WIN32
    2093. 

  2093.   #define WIN32_CHARNAMES
    2094. 

  2094. #endif
    2095. 

  2095. #ifdef UNIX
    2096. 

  2096.   #define UNIX_CHARNAMES
    2097. 

  2097. #endif
    2098. 

  2098. /* When changed: extend CONSTOBJ, CHARSTRG, FORMAT.LISP. */
    2099. 

  2099. 

  2100. /* Whether to use the GNU gettext library for internationalization: */
    2101. 

  2101. #if defined(ENABLE_NLS) && !defined(NO_GETTEXT)
    2102. 

  2102.   #define GNU_GETTEXT
    2103. 

  2103. #endif
    2104. 

  2104. 

  2105. /* Whether to create a stream *KEYBOARD-INPUT*
    2106. 

  2106.  and whether it will be used for the stream *TERMINAL-IO*: */
    2107. 

  2107. #if (defined(UNIX) && !defined(NO_TERMCAP_NCURSES)) || defined(WIN32_NATIVE)
    2108. 

  2108.   #define KEYBOARD
    2109. 

  2109.   #if 0
    2110. 

  2110.     #define TERMINAL_USES_KEYBOARD
    2111. 

  2111.   #endif
    2112. 

  2112. #endif
    2113. 

  2113. /* When changed: extend stream.d, keyboard.lisp */
    2114. 

  2114. 

  2115. /* Whether to use the GNU readline library for *TERMINAL-IO*: */
    2116. 

  2116. #if defined(HAVE_READLINE) && !defined(NO_READLINE)
    2117. 

  2117.   #define GNU_READLINE
    2118. 

  2118. #endif
    2119. 

  2119. 

  2120. /* Whether there are Window-streams and a package SCREEN: */
    2121. 

  2121. #if (defined(UNIX) && !defined(NO_TERMCAP_NCURSES)) || defined(WIN32_NATIVE)
    2122. 

  2122.   #define SCREEN
    2123. 

  2123. #endif
    2124. 

  2124. /* When changed: extend stream.d (loads of work!). */
    2125. 

  2125. 

  2126. /* Whether there are Pipe-streams: */
    2127. 

  2127. #if defined(UNIX) || defined(WIN32_NATIVE)
    2128. 

  2128.   #define PIPES
    2129. 

  2129.   #if defined(UNIX) || defined(WIN32_NATIVE)
    2130. 

  2130.     #define PIPES2  /* bidirectional pipes */
    2131. 

  2131.   #endif
    2132. 

  2132. #endif
    2133. 

  2133. /* When changed: extend stream.d and runprog.lisp. */
    2134. 

  2134. 

  2135. /* If the system has sockets, we support socket streams:
    2136. 

  2136.  We assume that if we have gethostbyname(), we have a networking OS
    2137. 

  2137.  (Unix or Win32). Then we decide independently about UNIX domain connections
    2138. 

  2138.  and TCP/IP connections. */
    2139. 

  2139. #if defined(HAVE_GETHOSTBYNAME) /* ==> defined(UNIX) || defined(WIN32_NATIVE) */
    2140. 

  2140.   #ifdef HAVE_SYS_UN_H  /* have <sys/un.h> and Unix domain sockets? */
    2141. 

  2141.     #define UNIXCONN  /* use Unix domain sockets */
    2142. 

  2142.   #endif
    2143. 

  2143.   #if defined(HAVE_NETINET_IN_H) || defined(WIN32_NATIVE)  /* have <netinet/in.h> ? */
    2144. 

  2144.     #define TCPCONN  /* use TCP/IP sockets */
    2145. 

  2145.   #endif
    2146. 

  2146.   /* Now, which kinds of socket streams: */
    2147. 

  2147.   #define X11SOCKETS  /* works even without TCPCONN (very young Linux) */
    2148. 

  2148.   #ifdef TCPCONN
    2149. 

  2149.     #define SOCKET_STREAMS
    2150. 

  2150.   #endif
    2151. 

  2151. #endif
    2152. 

  2152. /* When changed: extend stream.d, socket.d */
    2153. 

  2153. 

  2154. /* Whether there are generic streams: */
    2155. 

  2155. #if 1
    2156. 

  2156.   #define GENERIC_STREAMS
    2157. 

  2157. #endif
    2158. 

  2158. /* When changed: do nothing */
    2159. 

  2159. 

  2160. /* Whether the OS provides the required information for the
    2161. 

  2161.  functions  MACHINE-TYPE, MACHINE-VERSION, MACHINE-INSTANCE */
    2162. 

  2162. #if defined(UNIX) || defined(WIN32_NATIVE)
    2163. 

  2163.   #define MACHINE_KNOWN
    2164. 

  2164. #endif
    2165. 

  2165. /* When changed: extend misc.d, socket.d */
    2166. 

  2166. 

  2167. /* Whether there are LOGICAL-PATHNAMEs: */
    2168. 

  2168. #if 1
    2169. 

  2169.   #define LOGICAL_PATHNAMES
    2170. 

  2170. #endif
    2171. 

  2171. /* When changed: do nothing */
    2172. 

  2172. 

  2173. /* Whether the function USER-HOMEDIR-PATHNAME exists: */
    2174. 

  2174. #if defined(UNIX) || defined(WIN32)
    2175. 

  2175.   #define USER_HOMEDIR
    2176. 

  2176. #endif
    2177. 

  2177. /* When changed: extend pathname.d */
    2178. 

  2178. 

  2179. /* Whether the operating system manages an environment that associates Strings
    2180. 

  2180.  with Strings */
    2181. 

  2181. #if defined(UNIX) || defined(WIN32)
    2182. 

  2182.   #define HAVE_ENVIRONMENT
    2183. 

  2183. #endif
    2184. 

  2184. /* When changed: do nothing */
    2185. 

  2185. 

  2186. /* Whether the operating system has a preferred command-interpreter: */
    2187. 

  2187. #if defined(UNIX) || defined(WIN32_NATIVE)
    2188. 

  2188.   #define HAVE_SHELL
    2189. 

  2189. #endif
    2190. 

  2190. /* When changed: extend pathname.d */
    2191. 

  2191. 

  2192. /* Whether a foreign function interface is provided: */
    2193. 

  2193. #if (defined(UNIX) && !defined(UNIX_BINARY_DISTRIB)) || defined(DYNAMIC_FFI)
    2194. 

  2194.   #define HAVE_FFI
    2195. 

  2195. #endif
    2196. 

  2196. /* When changed: ?? */
    2197. 

  2197. 

  2198. /* Now the ones that are only relevant internally: */
    2199. 

  2199. 

  2200. /* Whether the GC closes files that aren't referenced any longer: */
    2201. 

  2201. #if defined(UNIX) || defined(WIN32)
    2202. 

  2202.   #define GC_CLOSES_FILES
    2203. 

  2203. #endif
    2204. 

  2204. /* When changed: do nothing */
    2205. 

  2205. 

  2206. /* How time is measured: */
    2207. 

  2207. #ifdef UNIX
    2208. 

  2208.   #if defined(HAVE_GETTIMEOFDAY) || defined(HAVE_FTIME)
    2209. 

  2209.     #define TIME_UNIX
    2210. 

  2210.   #elif defined(HAVE_TIMES_CLOCK)
    2211. 

  2211.     #define TIME_UNIX_TIMES
    2212. 

  2212.   #endif
    2213. 

  2213. #endif
    2214. 

  2214. #ifdef WIN32_NATIVE
    2215. 

  2215.   #define TIME_WIN32
    2216. 

  2216. #endif
    2217. 

  2217. #if defined(TIME_UNIX_TIMES)
    2218. 

  2218.   /* There's only a medium time resolution, so you can use 32-bit numbers
    2219. 

  2219.    to store the time-differences without any problems. */
    2220. 

  2220.   #define TIME_METHOD 1
    2221. 

  2221.   /* We fetch the time once on system sart. All further times are taken
    2222. 

  2222.    relatively to that one. */
    2223. 

  2223.   #define TIME_RELATIVE
    2224. 

  2224. #elif defined(TIME_UNIX) || defined(TIME_WIN32)
    2225. 

  2225.   /* The time resolution is so high that you need two 32-bit numbers to
    2226. 

  2226.    measure time differences: seconds and and fractions of seconds. */
    2227. 

  2227.   #define TIME_METHOD 2
    2228. 

  2228.   /* In this case we can use absolute and relative times for measurements. */
    2229. 

  2229.   #define TIME_ABSOLUTE
    2230. 

  2230. #else
    2231. 

  2231.   #error TIME_METHOD is not defined
    2232. 

  2232. #endif
    2233. 

  2233. /* When changed: extend time.d */
    2234. 

  2234. 

  2235. /* Whether the operating system can give us the run-time, or whether we'll have
    2236. 

  2236.  to accumulate it ourselves: */
    2237. 

  2237. #if defined(UNIX) || defined(WIN32_NATIVE)
    2238. 

  2238.   #define HAVE_RUN_TIME
    2239. 

  2239. #endif
    2240. 

  2240. /* When changed: extend time.d */
    2241. 

  2241. 

  2242. /* Whether the operating system provides virtual memory. */
    2243. 

  2243. #if (defined(UNIX) || defined(WIN32)) && !defined(NO_VIRTUAL_MEMORY)
    2244. 

  2244.   #define VIRTUAL_MEMORY
    2245. 

  2245. #endif
    2246. 

  2246. /* When changed: do nothing */
    2247. 

  2247. 

  2248. /* Whether the operating system allocates memory (via mmap or malloc) at
    2249. 

  2249.  randomized locations. */
    2250. 

  2250. #if defined(UNIX_OPENBSD)
    2251. 

  2251.   #define ADDRESS_RANGE_RANDOMIZED
    2252. 

  2252. #endif
    2253. 

  2253. /* When changed: do nothing */
    2254. 

  2254. 

  2255. /* Whether the operating system is capable of sending interruptions
    2256. 

  2256.  (Ctrl-C and others) as signal: */
    2257. 

  2257. #if defined(UNIX)
    2258. 

  2258.   #define HAVE_SIGNALS
    2259. 

  2259. #endif
    2260. 

  2260. /* pass on for clx/new-clx */
    2261. 

  2261. %% #ifdef HAVE_SIGNALS
    2262. 

  2262. %%   puts("#define HAVE_SIGNALS");
    2263. 

  2263. %% #endif
    2264. 

  2264. /* Whether we can even react to asynchronous signals:
    2265. 

  2265.  (If WIDE && !WIDE_HARD, writing a pointer is usually no elementary
    2266. 

  2266.  operation anymore!) */
    2267. 

  2267. #if (defined(WIDE) && !defined(WIDE_HARD)) && !(defined(GNU) && defined(SPARC))
    2268. 

  2268.   #define NO_ASYNC_INTERRUPTS
    2269. 

  2269. #endif
    2270. 

  2270. #if defined(NO_ASYNC_INTERRUPTS) && defined(MULTITHREAD)
    2271. 

  2271.   #error "No multithreading possible with this memory model!"
    2272. 

  2272. #endif
    2273. 

  2273. /* When changed: extend SPVW, write a interruptp(). */
    2274. 

  2274. 

  2275. /* Flavors of Pathname-management: */
    2276. 

  2276. #ifdef UNIX
    2277. 

  2277.   #define PATHNAME_UNIX
    2278. 

  2278. #endif
    2279. 

  2279. #ifdef WIN32
    2280. 

  2280.   #define PATHNAME_WIN32
    2281. 

  2281. #endif
    2282. 

  2282. /* Components of pathnames: */
    2283. 

  2283. #ifdef PATHNAME_WIN32
    2284. 

  2284.   #define HAS_HOST      1
    2285. 

  2285.   #define HAS_DEVICE    1
    2286. 

  2286. #endif
    2287. 

  2287. #ifdef PATHNAME_UNIX
    2288. 

  2288.   #define HAS_HOST      0
    2289. 

  2289.   #define HAS_DEVICE    0
    2290. 

  2290. #endif
    2291. 

  2291. /* Handling of the file "extension" (pathname-type): */
    2292. 

  2292. #if 0
    2293. 

  2293.   #define PATHNAME_EXT  /* Name and Type are separated, so no limitation of the length */
    2294. 

  2294. #endif
    2295. 

  2295. #if defined(PATHNAME_UNIX) || defined(PATHNAME_WIN32)
    2296. 

  2296.   #define PATHNAME_NOEXT  /* no explicit extension. */
    2297. 

  2297. #endif
    2298. 

  2298. /* Whether "//" at the beginning of a pathname has to remain (and not to be shortened to "/"): */
    2299. 

  2299. #ifdef UNIX_CYGWIN32
    2300. 

  2300.   #define PATHNAME_UNIX_UNC
    2301. 

  2301. #endif
    2302. 

  2302. /* When changed: extend pathname.d */
    2303. 

  2303. 

  2304. /* Whether there is a type FOREIGN (a wrapper for various kinds of pointers): */
    2305. 

  2305. #if defined(UNIX) || defined(DYNAMIC_FFI) || defined(WIN32_NATIVE)
    2306. 

  2306.   /* (Used by FFI and by CLX.) */
    2307. 

  2307.   #define FOREIGN  void*
    2308. 

  2308. #endif
    2309. 

  2309. /* When changed: do nothing */
    2310. 

  2310. %% #ifdef FOREIGN
    2311. 

  2311. %%   export_def(FOREIGN);
    2312. 

  2312. %% #endif
    2313. 

  2313. 

  2314. /* Whether the STACK is checked at certain key points: */
    2315. 

  2315. #define STACKCHECKS  (SAFETY >= 1) /* when SUBRs and FSUBRs are called */
    2316. 

  2316. #define STACKCHECKC  (SAFETY >= 1) /* when compiled closures are interpreted */
    2317. 

  2317. #define STACKCHECKR  (SAFETY >= 1) /* in the reader */
    2318. 

  2318. #define STACKCHECKP  (SAFETY >= 1) /* in the printer */
    2319. 

  2319. #define STACKCHECKB  (SAFETY >= 1) /* in the bindings */
    2320. 

  2320. /* When changed: do nothing */
    2321. 

  2321. 

  2322. 

  2323. /* Feature dependent include files. */
    2324. 

  2324. 

  2325. #ifdef HAVE_ICONV
    2326. 

  2326.   #include <stdlib.h>
    2327. 

  2327.   #include <iconv.h>
    2328. 

  2328.   #if _LIBICONV_VERSION
    2329. 

  2329.     /* We use GNU libiconv. */
    2330. 

  2330.     #define GNU_LIBICONV
    2331. 

  2331.     #define HAVE_GOOD_ICONV
    2332. 

  2332.   #elif (__GLIBC__ > 2 || (__GLIBC__ == 2 && __GLIBC_MINOR__ >= 2))
    2333. 

  2333.     /* glibc-2.2 iconv is also very reliable. Use it. */
    2334. 

  2334.     #define HAVE_GOOD_ICONV
    2335. 

  2335.   #else
    2336. 

  2336.     /* Other iconv implementations are too unreliable.
    2337. 

  2337.      Don't define HAVE_GOOD_ICONV. */
    2338. 

  2338.   #endif
    2339. 

  2339. #endif
    2340. 

  2340. 

  2341. 

  2342. /* ############### List of implemented CLtL2-features ############### */
    2343. 

  2343. 

  2344. #define X3J13_005  /* 18.5.1993 */
    2345. 

  2345. #define X3J13_014  /* 22.1.1995 */
    2346. 

  2346. #define X3J13_149  /* 22.7.1993 */
    2347. 

  2347. #define X3J13_175  /* 25.7.1993 */
    2348. 

  2348. 

  2349. 

  2350. /* ##################### Memory representation of objects ###################
    2351. 

    2352. 

  2352. Memory Representation and the Type Code of the various data types
    2353. 

  2353. =================================================================
    2354. 

    2355. 

  2355. 1. The type code
    2356. 

  2356. ----------------
    2357. 

    2358. 

  2358. An object consists of - in the same word - some type information and, for
    2359. 

  2359. immediate types, a couple of data bits, or, for heap allocated types,
    2360. 

  2360. a pointer to memory. There are many models of mixing type and pointer.
    2361. 

  2361. In the standard model, 6 to 8 bits (the word's high bits) are used for the
    2362. 

  2362. type. In the WIDE_HARD and WIDE_SOFT models, type and pointer are each 32
    2363. 

  2363. bits. In the HEAPCODES model, there are only 2 to 6 bits.
    2364. 

    2365. 

  2365. One bit (normally bit 31) is used as mark bit by the garbage collector.
    2366. 

  2366. Outside of GC, it is always cleared. (Except for the get_circularities and
    2367. 

  2367. subst_circ routines, and in the STACK, the GC bit is used for marking frames.)
    2368. 

    2369. 

  2369. 2. Memory formats
    2370. 

  2370. -----------------
    2371. 

    2372. 

  2372. 2.1. Immediate objects
    2373. 

    2374. 

  2374. 2.1.1. Machine pointers
    2375. 

    2376. 

  2376. Machine pointers are immediate objects. They may point to the code area
    2377. 

  2377. (.text segment), to data areas (.bss, .data segments, malloc'ed areas).
    2378. 

  2378. Other values (e.g. pointers to text/data in shared libraries) are not
    2379. 

  2379. allowed, because they may contain bits which are interpreted as a type code.
    2380. 

  2380. To use such machine addresses, you must wrap them in foreign-pointers or
    2381. 

  2381. simple-bit-vectors.
    2382. 

    2383. 

  2383. 2.1.2. Other immediate objects
    2384. 

    2385. 

  2385. Character, Fixnum, Short-Float, and, if IMMEDIATE_FFLOAT, Single-Float.
    2386. 

  2386. Furthermore: Frame-Pointer, Small-Read-Label, System. (System means some
    2387. 

  2387. finite number of special values, such as #<UNBOUND>.)
    2388. 

    2389. 

  2389. 2.2. SUBRs
    2390. 

    2391. 

  2391. They are immediate in the sense that they do not move (they do not need to,
    2392. 

  2392. because they are allocated statically), but they have to be traversed by GC.
    2393. 

    2394. 

  2394. 2.3. Pairs
    2395. 

    2396. 

  2396. These are heap objects containing just two pointers: Cons and, if SPVW_PURE,
    2397. 

  2397. Ratio and Complex.
    2398. 

    2399. 

  2399. 2.4. Varobjects
    2400. 

    2401. 

  2401. These are heap objects of varying size. GC needs a header word at the
    2402. 

  2402. beginning of the object.
    2403. 

    2404. 

  2404. 2.4.1. Records
    2405. 

    2406. 

  2406. These are varobjects which have additional type information and flags
    2407. 

  2407. in the second header word. Closure, Structure, Stream, Instance are always
    2408. 

  2408. records. Depending on the memory model, arrays, symbols etc. may or may
    2409. 

  2409. not be records.
    2410. 

    2411. 

  2411. 2.4.2. Arrays
    2412. 

    2413. 

  2413. Simple-Bit-Vector, Simple-String, Simple-Vector are the "simple" arrays.
    2414. 

  2414. The non-simple ones are represented by a Iarray, yet the type code gives
    2415. 

  2415. some information about the rank, the representation and the element type:
    2416. 

    2417. 

  2417.                                 |    "simple"     |  "not simple"  |
    2418. 

  2418.                                 |    Sarray       |     Iarray     |
    2419. 

  2419.   ------------------------------+-----------------+----------------+
    2420. 

  2420.    (vector bit)                 | sbvector_type   | bvector_type   |
    2421. 

  2421.   ------------------------------+-----------------+----------------+
    2422. 

  2422.    (vector (unsigned-byte 2))   | sb2vector_type  | b2vector_type  |
    2423. 

  2423.   ------------------------------+-----------------+----------------+
    2424. 

  2424.    (vector (unsigned-byte 4))   | sb4vector_type  | b4vector_type  |
    2425. 

  2425.   ------------------------------+-----------------+----------------+
    2426. 

  2426.    (vector (unsigned-byte 8))   | sb8vector_type  | b8vector_type  |
    2427. 

  2427.   ------------------------------+-----------------+----------------+
    2428. 

  2428.    (vector (unsigned-byte 16))  | sb16vector_type | b16vector_type |
    2429. 

  2429.   ------------------------------+-----------------+----------------+
    2430. 

  2430.    (vector (unsigned-byte 32))  | sb32vector_type | b32vector_type |
    2431. 

  2431.   ------------------------------+-----------------+----------------+
    2432. 

  2432.    (vector character)           | sstring_type    | string_type    |
    2433. 

  2433.   ------------------------------+-----------------+----------------+
    2434. 

  2434.    (vector t)                   | svector_type    | vector_type    |
    2435. 

  2435.   ------------------------------+-----------------+----------------+
    2436. 

  2436.    array of dimension /= 1      |       --        |  mdarray_type  |
    2437. 

  2437.   ------------------------------+-----------------+----------------+
    2438. 

    2439. 

  2439. 2.4.3. Other varobjects
    2440. 

    2441. 

  2441. Symbol has some special flags (keyword, constant, special) in the header,
    2442. 

  2442. if possible.
    2443. 

    2444. 

  2444. FSUBR, Bignum, Single-Float (unless IMMEDIATE_FFLOAT), Double-Float,
    2445. 

  2445. Long-Float, Ratio and Complex (only if SPVW_MIXED).
    2446. 

    2447. 

  2447.  ######################## LISP-objects in general ######################## */
    2448. 

  2448. 

  2449. #if defined(DEBUG_GCSAFETY)
    2450. 

  2450.   #ifndef __cplusplus
    2451. 

  2451.     #error "DEBUG_GCSAFETY works only with a C++ compiler! Reconfigure with CC=g++."
    2452. 

  2452.   #endif
    2453. 

  2453.   #if defined(WIDE_SOFT) || defined(WIDE_AUXI)
    2454. 

  2454.     #error "DEBUG_GCSAFETY cannot be used together with WIDE_SOFT or WIDE_AUXI (not yet implemented)!"
    2455. 

  2455.   #endif
    2456. 

  2456.   /* The 'gcv_object_t' and 'object' types share the major part of their innards. */
    2457. 

  2457.   #ifndef OBJECT_STRUCT
    2458. 

  2458.     #define OBJECT_STRUCT
    2459. 

  2459.   #endif
    2460. 

  2460. #endif
    2461. 

  2461. 

  2462. /* The type 'object' denotes an object in registers or in memory that is
    2463. 

  2463.  not seen by the GC.
    2464. 

    2465. 

  2465.  The type `gcv_object_t' denotes a GC visible object, i.e. a slot inside
    2466. 

  2466.  a heap-allocated object or a STACK slot. If its value is not an immediate
    2467. 

  2467.  object, any call that can trigger GC can modify the pointer value.
    2468. 

  2468.  NEVER write "var gcv_object_t foo;" - this is forbidden!
    2469. 

  2469.  You can write "var gcunsafe_object_t foo;" instead - but then you must not
    2470. 

  2470.  trigger GC during the entire lifetime of the variable 'foo'! */
    2471. 

  2471. 

  2472. %% #if (defined(WIDE_AUXI) || defined(OBJECT_STRUCT) || defined(WIDE_STRUCT)) && defined(WIDE) && !defined(WIDE_HARD) && defined(GENERATIONAL_GC)
    2473. 

  2473. %%   #define attribute_aligned_object " __attribute__ ((aligned(8)))"
    2474. 

  2474. %% #else
    2475. 

  2475. %%   #define attribute_aligned_object ""
    2476. 

  2476. %% #endif
    2477. 

  2477. 

  2478. #if !defined(WIDE_SOFT)
    2479. 

  2479. 

  2480.   /* An object pointer is an empty pointer to begin with (so you cannot do
    2481. 

  2481.    anything unwanted with it in C): */
    2482. 

  2482.   #if defined(WIDE_AUXI)
    2483. 

  2483.     /* Make room for an auxiliary word in every object.
    2484. 

  2484.      The struct around the union is needed to work around a gcc-2.95 bug. */
    2485. 

  2485.     #if BIG_ENDIAN_P
    2486. 

  2486.       #define INNARDS_OF_GCV_OBJECT  \
    2487. 

  2487.         union {                                         \
    2488. 

  2488.           struct { uintP auxi_ob; uintP one_ob; } both; \
    2489. 

  2489.           oint align_o _attribute_aligned_object_;      \
    2490. 

  2490.         } u _attribute_aligned_object_;
    2491. 

  2491.     #else
    2492. 

  2492.       #define INNARDS_OF_GCV_OBJECT  \
    2493. 

  2493.         union {                                         \
    2494. 

  2494.           struct { uintP one_ob; uintP auxi_ob; } both; \
    2495. 

  2495.           oint align_o _attribute_aligned_object_;      \
    2496. 

  2496.         } u _attribute_aligned_object_;
    2497. 

  2497.     #endif
    2498. 

  2498.     #define one_o  u.both.one_ob
    2499. 

  2499.     #define auxi_o  u.both.auxi_ob
    2500. 

  2500.   #elif defined(OBJECT_STRUCT)
    2501. 

  2501.     #define INNARDS_OF_GCV_OBJECT  \
    2502. 

  2502.       uintP one_o;
    2503. 

  2503.   #else
    2504. 

  2504.     typedef  void *  gcv_object_t;
    2505. 

  2505.   #endif
    2506. 

  2506.   /* But there is an address and type bits in the representation. */
    2507. 

  2507. 

  2508.   /* An (unsigned) Integer of the object's size: */
    2509. 

  2509.   #ifdef WIDE_AUXI
    2510. 

  2510.     typedef  uint64  oint;
    2511. 

  2511.     typedef  sint64  soint;
    2512. 

  2512.   #else
    2513. 

  2513.     typedef  uintP  oint;
    2514. 

  2514.     typedef  sintP  soint;
    2515. 

  2515.   #endif
    2516. 

  2516. 

  2517. #else /* defined(WIDE_SOFT) */
    2518. 

  2518. 

  2519.   /* An object consists of a separated 32 bit address and a 32 bit type info. */
    2520. 

  2520.   typedef  uint64  oint;
    2521. 

  2521.   typedef  sint64  soint;
    2522. 

  2522.   #ifdef WIDE_STRUCT
    2523. 

  2523.     /* The struct around the union is needed to work around a gcc-2.95 bug. */
    2524. 

  2524.     #if BIG_ENDIAN_P==WIDE_ENDIANNESS
    2525. 

  2525.       #define INNARDS_OF_GCV_OBJECT                                      \
    2526. 

  2526.         union {                                                          \
    2527. 

  2527.           struct { /* tint */ uintL type; /* aint */ uintL addr; } both; \
    2528. 

  2528.           oint one_u _attribute_aligned_object_;                         \
    2529. 

  2529.         } u _attribute_aligned_object_;
    2530. 

  2530.     #else
    2531. 

  2531.       #define INNARDS_OF_GCV_OBJECT                                      \
    2532. 

  2532.         union {                                                          \
    2533. 

  2533.           struct { /* aint */ uintL addr; /* tint */ uintL type; } both; \
    2534. 

  2534.           oint one_u _attribute_aligned_object_;                         \
    2535. 

  2535.         } u _attribute_aligned_object_;
    2536. 

  2536.     #endif
    2537. 

  2537.     #define one_o  u.one_u
    2538. 

  2538.   #else
    2539. 

  2539.     typedef  oint  gcv_object_t;
    2540. 

  2540.   #endif
    2541. 

  2541. 

  2542. #endif
    2543. 

  2543. 

  2544. /* sizeof(gcv_object_t) = sizeof(oint) must hold true! */
    2545. 

  2545. 

  2546. %% #if !defined(WIDE_SOFT)
    2547. 

  2547. %%   #if defined(WIDE_AUXI)
    2548. 

  2548. %%     strcpy(buf,"struct { union { struct { ");
    2549. 

  2549. %%     #if BIG_ENDIAN_P
    2550. 

  2550. %%       strcat(buf,"uintP auxi_ob; uintP one_ob;");
    2551. 

  2551. %%     #else
    2552. 

  2552. %%       strcat(buf,"uintP one_ob; uintP auxi_ob;");
    2553. 

  2553. %%     #endif
    2554. 

  2554. %%     strcat(buf," } both; oint align_o");
    2555. 

  2555. %%     strcat(buf,attribute_aligned_object);
    2556. 

  2556. %%     strcat(buf,"; } u");
    2557. 

  2557. %%     strcat(buf,attribute_aligned_object);
    2558. 

  2558. %%     strcat(buf,"; }");
    2559. 

  2559. %%     emit_typedef(buf,"gcv_object_t");
    2560. 

  2560. %%     emit_define("one_o","u.both.one_ob");
    2561. 

  2561. %%     emit_define("auxi_o","u.both.auxi_ob");
    2562. 

  2562. %%   #elif defined(OBJECT_STRUCT)
    2563. 

  2563. %%     #ifdef DEBUG_GCSAFETY
    2564. 

  2564. %%       puts("struct object { uintP one_o; uintL allocstamp; };");
    2565. 

  2565. %%       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 (); };");
    2566. 

  2566. %%     #else
    2567. 

  2567. %%       emit_typedef("struct { uintP one_o; }","gcv_object_t");
    2568. 

  2568. %%     #endif
    2569. 

  2569. %%   #else
    2570. 

  2570. %%     emit_typedef("void *","gcv_object_t");
    2571. 

  2571. %%   #endif
    2572. 

  2572. %%   #ifdef WIDE_AUXI
    2573. 

  2573. %%     emit_typedef("uint64","oint");
    2574. 

  2574. %%     emit_typedef("sint64","soint");
    2575. 

  2575. %%   #else
    2576. 

  2576. %%     emit_typedef("uintP","oint");
    2577. 

  2577. %%     emit_typedef("sintP","soint");
    2578. 

  2578. %%   #endif
    2579. 

  2579. %% #else
    2580. 

  2580. %%   emit_typedef("uint64","oint");
    2581. 

  2581. %%   emit_typedef("sint64","soint");
    2582. 

  2582. %%   #ifdef WIDE_STRUCT
    2583. 

  2583. %%     strcpy(buf,"struct { union {\n");
    2584. 

  2584. %%     #if BIG_ENDIAN_P==WIDE_ENDIANNESS
    2585. 

  2585. %%       strcat(buf,"  struct { /*tint*/ uintL type; /*aint*/ uintL addr; } both;\n");
    2586. 

  2586. %%     #else
    2587. 

  2587. %%       strcat(buf,"  struct { /*aint*/ uintL addr; /*tint*/ uintL type; } both;\n");
    2588. 

  2588. %%     #endif
    2589. 

  2589. %%     strcat(buf,"  oint one_u");
    2590. 

  2590. %%     strcat(buf,attribute_aligned_object);
    2591. 

  2591. %%     strcat(buf,"; } u");
    2592. 

  2592. %%     strcat(buf,attribute_aligned_object);
    2593. 

  2593. %%     strcat(buf,"; }");
    2594. 

  2594. %%     emit_typedef(buf,"gcv_object_t");
    2595. 

  2595. %%     emit_define("one_o","u.one_u");
    2596. 

  2596. %%   #else
    2597. 

  2597. %%     emit_typedef("oint","gcv_object_t");
    2598. 

  2598. %%   #endif
    2599. 

  2599. %% #endif
    2600. 

  2600. 

  2601. /* conversion between gcv_object_t/object and oint:
    2602. 

  2602.  as_oint(expr)   gcv_object_t/object --> oint
    2603. 

  2603.  as_object(x)    oint --> gcv_object_t
    2604. 

  2604.  The conversion  gcv_object_t --> object
    2605. 

  2605.  is implicit. */
    2606. 

  2606. #if defined(WIDE_STRUCT) || defined(OBJECT_STRUCT)
    2607. 

  2607.   #define as_oint(expr)  ((expr).one_o)
    2608. 

  2608.   #if defined(WIDE_STRUCT)
    2609. 

  2609.     #define as_object(o)  ((object){u:{one_u:(o)}INIT_ALLOCSTAMP})
    2610. 

  2610.   #elif defined(OBJECT_STRUCT)
    2611. 

  2611.     #define as_object(o)  ((object){one_o:(o)INIT_ALLOCSTAMP})
    2612. 

  2612.   #else
    2613. 

  2613.     extern __inline__ object as_object (register oint o)
    2614. 

  2614.       { register object obj; obj.one_o = o; return obj; }
    2615. 

  2615.   #endif
    2616. 

  2616. #elif defined(WIDE_AUXI)
    2617. 

  2617.   #define as_oint(expr)  ((expr).u.align_o)
    2618. 

  2618.   /* These could store arbitrary information in auxi_o. */
    2619. 

  2619.   #define as_object_with_auxi(o)  ((object){u:{both:{ one_ob: (o), auxi_ob: 0 }} INIT_ALLOCSTAMP })
    2620. 

  2620.   #define as_object(o)  ((object){u:{align_o:(o)}INIT_ALLOCSTAMP})
    2621. 

  2621. #else
    2622. 

  2622.   #define as_oint(expr)  (oint)(expr)
    2623. 

  2623.   #define as_object(o)  (gcv_object_t)(o)
    2624. 

  2624. #endif
    2625. 

  2625. %% export_def(as_oint(expr));
    2626. 

  2626. %% export_def(as_object(o));
    2627. 

  2627. 

  2628. /* Separation of an oint in type bits and address:
    2629. 

  2629.  oint_type_mask  is always subset  (2^oint_type_len-1)<<oint_type_shift
    2630. 

  2630.  and  oint_addr_mask superset (2^oint_addr_len-1)<<oint_addr_shift . */
    2631. 

  2631. #if !defined(TYPECODES)
    2632. 

  2632.   /* HEAPCODES model:
    2633. 

  2633.    For pointers, the address takes the full word (with type info in the
    2634. 

  2634.    lowest two bits). For immediate objects, we use 24 bits for the data
    2635. 

  2635.    (but exclude the highest available bit, which is the garcol_bit). */
    2636. 

  2636.   #if !(defined(STANDARD_HEAPCODES) || defined(LINUX_NOEXEC_HEAPCODES))
    2637. 

  2637.     /* Choose the appropriate HEAPCODES variant for the machine.
    2638. 

  2638.      On most systems, one of the high bits is suitable as GC bit; here we
    2639. 

  2639.      choose STANDARD_HEAPCODES.
    2640. 

  2640.      On some Linux/x86 systems, starting in 2004, a "no-exec" kernel patch
    2641. 

  2641.      is used that distributes virtual addresses over the entire address
    2642. 

  2642.      space from 0x00000000 to 0xBFFFFFFF (as a function of its access
    2643. 

  2643.      permissions); here we use LINUX_NOEXEC_HEAPCODES.
    2644. 

  2644.      On OpenBSD 3.8 or newer, starting in 2005, the addresses of mmap and
    2645. 

  2645.      malloc results (and hence also of shared libraries) are randomized;
    2646. 

  2646.      only the code address is fixed around 0x1C000000 and the stack address
    2647. 

  2647.      is around 0xCF000000. In this case, we also use LINUX_NOEXEC_HEAPCODES. */
    2648. 

  2648.     #if (defined(I80386) && defined(UNIX_LINUX)) || (defined(I80386) && defined(UNIX_OPENBSD) && defined(ADDRESS_RANGE_RANDOMIZED))
    2649. 

  2649.       #define LINUX_NOEXEC_HEAPCODES
    2650. 

  2650.     #else
    2651. 

  2651.       #define STANDARD_HEAPCODES
    2652. 

  2652.     #endif
    2653. 

  2653.   #endif
    2654. 

  2654.   #ifdef STANDARD_HEAPCODES
    2655. 

  2655.     /* The portable case. Assumes only that the GC bit can be chosen. */
    2656. 

  2656.     #if defined(SPARC) && defined(UNIX_LINUX) && (__GLIBC__ < 2 || (__GLIBC__ == 2 && __GLIBC_MINOR__ < 2))
    2657. 

  2657.       #define LINUX_SPARC_OLD_GLIBC
    2658. 

  2658.     #endif
    2659. 

  2659.     #if defined(WIDE_HARD)
    2660. 

  2660.       #define oint_type_shift 0
    2661. 

  2661.       #define oint_type_len 8
    2662. 

  2662.       #define oint_type_mask 0x000000000000007FUL
    2663. 

  2663.       #define oint_data_shift 7
    2664. 

  2664.       #define oint_data_len 48
    2665. 

  2665.       #define oint_data_mask 0x007FFFFFFFFFFF80UL
    2666. 

  2666.       #define garcol_bit_o 63
    2667. 

  2667.     #elif !((defined(MC680X0) && defined(UNIX_LINUX)) || (defined(I80386) && defined(UNIX_BEOS)) || defined(LINUX_SPARC_OLD_GLIBC))
    2668. 

  2668.       #define oint_type_shift 0
    2669. 

  2669.       #define oint_type_len 8
    2670. 

  2670.       #define oint_type_mask 0x0000007FUL
    2671. 

  2671.       #define oint_data_shift 7
    2672. 

  2672.       #define oint_data_len 24
    2673. 

  2673.       #define oint_data_mask 0x7FFFFF80UL
    2674. 

  2674.       #define garcol_bit_o 31
    2675. 

  2675.     #elif defined(I80386) && defined(UNIX_BEOS)
    2676. 

  2676.       /* On BeOS 5, malloc()ed addresses are of the form 0x80...... Bit 31
    2677. 

  2677.        is therefore part of an address and cannot be used as garcol_bit. */
    2678. 

  2678.       #define oint_type_shift 0
    2679. 

  2679.       #define oint_type_len 8
    2680. 

  2680.       #define oint_type_mask 0x0000003FUL
    2681. 

  2681.       #define oint_data_shift 6
    2682. 

  2682.       #define oint_data_len 24
    2683. 

  2683.       #define oint_data_mask 0x3FFFFFC0UL
    2684. 

  2684.       #define garcol_bit_o 30
    2685. 

  2685.     #elif (defined(MC680X0) && defined(UNIX_LINUX)) || defined(LINUX_SPARC_OLD_GLIBC)
    2686. 

  2686.       /* On Sparc-Linux with glibc 2.1 and older:
    2687. 

  2687.        malloc()ed addresses are of the form 0x0....... or 0xe........
    2688. 

  2688.        Bits 31..29 are therefore part of an address and cannot
    2689. 

  2689.        be used as garcol_bit. We therefore choose bit 28 as garcol_bit.
    2690. 

  2690.        Now, the 24 data bits of an immediate value must not intersect the
    2691. 

  2691.        garcol_bit, so we use bits 27..4 for that (we could use bits 26..3
    2692. 

  2692.        as well).
    2693. 

  2693.        On m68k-Linux, malloc()ed addresses are of the form 0x80...... or
    2694. 

  2694.        0xc0....... Bits 31..30 are therefore part of an address and cannot
    2695. 

  2695.        be used as garcol_bit. We therefore have three choices:
    2696. 

  2696.          data bits: bits 26..3, garcol_bit_o = 28/27
    2697. 

  2697.          data bits: bits 27..4, garcol_bit_o = 28/3
    2698. 

  2698.          data bits: bits 28..5, garcol_bit_o = 4/3 */
    2699. 

  2699.       #define oint_type_shift 0
    2700. 

  2700.       #define oint_type_len 32
    2701. 

  2701.       #define oint_type_mask 0xE000000FUL
    2702. 

  2702.       #define oint_data_shift 4
    2703. 

  2703.       #define oint_data_len 24
    2704. 

  2704.       #define oint_data_mask 0x0FFFFFF0UL
    2705. 

  2705.       #define garcol_bit_o 28
    2706. 

  2706.     #endif
    2707. 

  2707.   #endif /* STANDARD_HEAPCODES */
    2708. 

  2708.   #ifdef LINUX_NOEXEC_HEAPCODES
    2709. 

  2709.     /* The Linux/32-bit case. Assumes 1. that the virtual memory addresses end
    2710. 

  2710.      at 0xC0000000, or at least that we can put a black hole on the range
    2711. 

  2711.      0xC0000000..0xDFFFFFFF, 2. that the compiler and linker can enforce an
    2712. 

  2712.      8-byte alignment of symbol_tab and subr_tab.
    2713. 

  2713.      Only bit 0 or 1 can be used as GC-bit. */
    2714. 

  2714.     #define oint_type_shift 0
    2715. 

  2715.     #define oint_type_len 32
    2716. 

  2716.     #define oint_type_mask 0xE000001FUL
    2717. 

  2717.     #define oint_data_shift 5
    2718. 

  2718.     #define oint_data_len 24
    2719. 

  2719.     #define oint_data_mask 0x1FFFFFE0UL
    2720. 

  2720.     #define garcol_bit_o 0
    2721. 

  2721.   #endif /* LINUX_NOEXEC_HEAPCODES */
    2722. 

  2722.   #if defined(WIDE_HARD)
    2723. 

  2723.     #define oint_addr_shift 0
    2724. 

  2724.     #define oint_addr_len 64
    2725. 

  2725.     #define oint_addr_mask 0xFFFFFFFFFFFFFFFFUL
    2726. 

  2726.   #else
    2727. 

  2727.     #define oint_addr_shift 0
    2728. 

  2728.     #define oint_addr_len 32
    2729. 

  2729.     #define oint_addr_mask 0xFFFFFFFFUL
    2730. 

  2730.   #endif
    2731. 

  2731. /* Now come the platforms with TYPECODES. oint_type_len should be >= 8,
    2732. 

  2732.  and oint_type_mask should have at least 8 bits set and at most one bit in
    2733. 

  2733.  common with oint_addr_mask. */
    2734. 

  2734. #elif defined(WIDE_HARD)
    2735. 

  2735.   #if defined(DECALPHA) && (defined(UNIX_OSF) || defined(UNIX_LINUX) || defined(UNIX_FREEBSD) || defined(UNIX_NETBSD))
    2736. 

  2736.   /* UNIX_OSF:
    2737. 

  2737.      Ordinary pointers are in the range 1*2^32..2*2^32.
    2738. 

  2738.      Code address range:    0x000000012xxxxxxx
    2739. 

  2739.      Malloc address range:  0x000000014xxxxxxx
    2740. 

  2740.      Shared libraries:      0x000003FFCxxxxxxx
    2741. 

  2741.    UNIX_LINUX:
    2742. 

  2742.      Code address range:    0x000000012xxxxxxx
    2743. 

  2743.      Malloc address range:  0x000000012xxxxxxx
    2744. 

  2744.                       and:  0x0000015555xxxxxx
    2745. 

  2745.      Shared libraries:      0x0000015555xxxxxx
    2746. 

  2746.      Virtual address limit: 0x0000040000000000
    2747. 

  2747.    UNIX_FREEBSD
    2748. 

  2748.      Code address range:    0x0000000120000000
    2749. 

  2749.      Malloc address range:  0x0000000120000000
    2750. 

  2750.      Shared libraries:      0x0000000160000000
    2751. 

  2751.      Stack address range:   0x0000000011000000
    2752. 

  2752.    UNIX_NETBSD
    2753. 

  2753.      Code address range:    0x0000000120000000
    2754. 

  2754.      Malloc address range:  0x0000000120000000
    2755. 

  2755.      Shared libraries:      0x0000000160000000
    2756. 

  2756.      Stack address range:   0x00000001FF000000 */
    2757. 

  2757.     /* This is the safest.
    2758. 

  2758.      Bits 63..48 = type code, Bits 47..0 = address */
    2759. 

  2759.     #define oint_type_shift 48
    2760. 

  2760.     #define oint_type_len 16
    2761. 

  2761.     #define oint_type_mask 0xFFFF000000000000UL
    2762. 

  2762.     #define oint_addr_shift 0
    2763. 

  2763.     #define oint_addr_len 48
    2764. 

  2764.     #define oint_addr_mask 0x0000FFFFFFFFFFFFUL
    2765. 

  2765.     #define oint_data_shift oint_addr_shift
    2766. 

  2766.     #define oint_data_len oint_addr_len
    2767. 

  2767.     #define oint_data_mask oint_addr_mask
    2768. 

  2768.   #endif
    2769. 

  2769.   #if defined(MIPS64)
    2770. 

  2770.     /* Bits 63..48 = type code, bits 31..0 = address */
    2771. 

  2771.     #define oint_type_shift 48
    2772. 

  2772.     #define oint_type_len 16
    2773. 

  2773.     #define oint_type_mask 0xFFFF000000000000UL
    2774. 

  2774.     #define oint_addr_shift 0
    2775. 

  2775.     #define oint_addr_len 64
    2776. 

  2776.     #define oint_addr_mask 0x00000000FFFFFFFFUL
    2777. 

  2777.     #define oint_data_shift 0
    2778. 

  2778.     #define oint_data_len 48
    2779. 

  2779.     #define oint_data_mask 0x0000FFFFFFFFFFFFUL
    2780. 

  2780.   #endif
    2781. 

  2781.   #if defined(SPARC64)
    2782. 

  2782.     /* Virtual address limit on some systems: -2^43..2^43.
    2783. 

  2783.      This is the safest.
    2784. 

  2784.      Bits 63..48 = type code, bits 47..0 = address */
    2785. 

  2785.     #define oint_type_shift 48
    2786. 

  2786.     #define oint_type_len 16
    2787. 

  2787.     #define oint_type_mask 0xFFFF000000000000UL
    2788. 

  2788.     #define oint_addr_shift 0
    2789. 

  2789.     #define oint_addr_len 48
    2790. 

  2790.     #define oint_addr_mask 0x0000FFFFFFFFFFFFUL
    2791. 

  2791.     #define oint_data_shift oint_addr_shift
    2792. 

  2792.     #define oint_data_len oint_addr_len
    2793. 

  2793.     #define oint_data_mask oint_addr_mask
    2794. 

  2794.   #endif
    2795. 

  2795.   #if defined(IA64) && defined(UNIX_LINUX)
    2796. 

  2796.     /* Bits 63..61 = region code,
    2797. 

  2797.      bits 60..39 all zero or all one,
    2798. 

  2798.      virtual address limit: R*2^61..R*2^61+2^39, (R+1)*2^61-2^39..(R+1)*2^61.
    2799. 

  2799.      SHLIB_ADDRESS_RANGE  = 0x2000000000000000UL (region 1)
    2800. 

  2800.      CODE_ADDRESS_RANGE   = 0x4000000000000000UL (region 2)
    2801. 

  2801.      MALLOC_ADDRESS_RANGE = 0x6000000000000000UL (region 3)
    2802. 

  2802.      STACK_ADDRESS_RANGE  = 0x9FFFFFFFFF000000UL (region 4)
    2803. 

  2803.      This is the safest.
    2804. 

  2804.      Bits 63..48 = Typcode, Bits 47..0 = address */
    2805. 

  2805.     #define oint_type_shift 48
    2806. 

  2806.     #define oint_type_len 16
    2807. 

  2807.     #define oint_type_mask 0x1FFF000000000000UL
    2808. 

  2808.     #define oint_addr_shift 0
    2809. 

  2809.     #define oint_addr_len 64
    2810. 

  2810.     #define oint_addr_mask 0xE000FFFFFFFFFFFFUL
    2811. 

  2811.     #define oint_data_shift 0
    2812. 

  2812.     #define oint_data_len 48
    2813. 

  2813.     #define oint_data_mask 0x0000FFFFFFFFFFFFUL
    2814. 

  2814.   #endif
    2815. 

  2815.   #if defined(AMD64)
    2816. 

  2816.    /* UNIX_LINUX:
    2817. 

  2817.      CODE_ADDRESS_RANGE     0x0000000000000000UL
    2818. 

  2818.      MALLOC_ADDRESS_RANGE   0x0000000000000000UL
    2819. 

  2819.      SHLIB_ADDRESS_RANGE    0x00000034F5000000UL
    2820. 

  2820.      STACK_ADDRESS_RANGE    0x0000007FBF000000UL
    2821. 

  2821.    UNIX_FREEBSD
    2822. 

  2822.      CODE_ADDRESS_RANGE     0x0000000000000000UL
    2823. 

  2823.      MALLOC_ADDRESS_RANGE   0x0000000000000000UL
    2824. 

  2824.      SHLIB_ADDRESS_RANGE    0x0000000800000000UL
    2825. 

  2825.      STACK_ADDRESS_RANGE    0x00007FFFFF000000UL
    2826. 

  2826.      Bits 63..48 = type code, Bits 47..0 = address */
    2827. 

  2827.     #define oint_type_shift 48
    2828. 

  2828.     #define oint_type_len 16
    2829. 

  2829.     #define oint_type_mask 0xFFFF000000000000UL
    2830. 

  2830.     #define oint_addr_shift 0
    2831. 

  2831.     #define oint_addr_len 48
    2832. 

  2832.     #define oint_addr_mask 0x0000FFFFFFFFFFFFUL
    2833. 

  2833.     #define oint_data_shift oint_addr_shift
    2834. 

  2834.     #define oint_data_len oint_addr_len
    2835. 

  2835.     #define oint_data_mask oint_addr_mask
    2836. 

  2836.   #endif
    2837. 

  2837. #elif defined(WIDE_SOFT)
    2838. 

  2838.   /* separate one 32-bit word for typcode and address. */
    2839. 

  2839.   #if defined(WIDE_SOFT_LARGEFIXNUM)
    2840. 

  2840.     /* Used to test large fixnums on 32-bit platforms.
    2841. 

  2841.      Bits 63..48 = Typcode, Bits 47..32 = zero, Bits 31..0 = address */
    2842. 

  2842.     #define oint_type_shift 48
    2843. 

  2843.     #define oint_type_len 16
    2844. 

  2844.     #define oint_type_mask ULL(0xFFFF000000000000)
    2845. 

  2845.     #define oint_addr_shift 0
    2846. 

  2846.     #define oint_addr_len 48
    2847. 

  2847.     #define oint_addr_mask ULL(0x0000FFFFFFFFFFFF)
    2848. 

  2848.   #elif WIDE_ENDIANNESS
    2849. 

  2849.     /* Bits 63..32 = Typcode, Bits 31..0 = address */
    2850. 

  2850.     #define oint_type_shift 32
    2851. 

  2851.     #define oint_type_len 32
    2852. 

  2852.     #define oint_type_mask ULL(0xFFFFFFFF00000000)
    2853. 

  2853.     #define oint_addr_shift 0
    2854. 

  2854.     #define oint_addr_len 32
    2855. 

  2855.     #define oint_addr_mask ULL(0x00000000FFFFFFFF)
    2856. 

  2856.   #else /* conversely it is a little slower: */
    2857. 

  2857.     /* Bits 63..32 = Adress, Bits 31..0 = Typcode */
    2858. 

  2858.     #define oint_type_shift 0
    2859. 

  2859.     #define oint_type_len 32
    2860. 

  2860.     #define oint_type_mask ULL(0x00000000FFFFFFFF)
    2861. 

  2861.     #define oint_addr_shift 32
    2862. 

  2862.     #define oint_addr_len 32
    2863. 

  2863.     #define oint_addr_mask ULL(0xFFFFFFFF00000000)
    2864. 

  2864.   #endif
    2865. 

  2865. /* Now come the 32-bit platforms with TYPECODES. We need to support it only on
    2866. 

  2866.  MC680X0 platforms without new gcc.
    2867. 

  2867.  It worked on the following platforms in the past, and may still work on:
    2868. 

  2868.    (defined(MC680X0) && !defined(UNIX_AMIX) && !defined(UNIX_NEXTSTEP) && !(defined(UNIX_LINUX) && CODE_ADDRESS_RANGE))
    2869. 

  2869.    (defined(I80386) && !(defined(UNIX_LINUX) && (CODE_ADDRESS_RANGE != 0)) && !defined(UNIX_HURD) && !defined(UNIX_SYSV_UHC_1) && !defined(UNIX_NEXTSTEP) && !defined(UNIX_SYSV_PTX) && !defined(UNIX_SUNOS5) && !defined(UNIX_CYGWIN32) && !defined(WIN32_NATIVE))
    2870. 

  2870.    (defined(SPARC) && !defined(SUN4_29))
    2871. 

  2871.    (defined(MIPS) && !defined(UNIX_IRIX) && !defined(UNIX_DEC_ULTRIX))
    2872. 

  2872.    defined(M88000)
    2873. 

  2873.    (defined(POWERPC) && !defined(UNIX_AIX) && !defined(UNIX_LINUX))
    2874. 

  2874.    defined(VAX) */
    2875. 

  2875. #elif (defined(I80386) && ((defined(UNIX_LINUX) && (CODE_ADDRESS_RANGE != 0)) || (defined(UNIX_FREEBSD) && !defined(UNIX_GNU)))) || (defined(POWERPC) && defined(UNIX_DARWIN)) || defined(TRY_TYPECODES_1)
    2876. 

  2876.   /* You can add more platforms here provided that
    2877. 

  2877.    1. you need it,
    2878. 

  2878.    2. CODE_ADDRESS_RANGE | MALLOC_ADDRESS_RANGE has at most one bit set,
    2879. 

  2879.    3. it works. */
    2880. 

  2880.   #define oint_type_shift 24
    2881. 

  2881.   #define oint_type_len 8
    2882. 

  2882.   #define oint_type_mask (0xFF000000UL & ~(CODE_ADDRESS_RANGE | MALLOC_ADDRESS_RANGE))
    2883. 

  2883.   #define oint_addr_shift 0
    2884. 

  2884.   #define oint_addr_len 24
    2885. 

  2885.   #define oint_addr_mask (0x00FFFFFFUL | CODE_ADDRESS_RANGE | MALLOC_ADDRESS_RANGE)
    2886. 

  2886.   #define oint_data_shift 0
    2887. 

  2887.   #define oint_data_len 24
    2888. 

  2888.   #define oint_data_mask 0x00FFFFFFUL
    2889. 

  2889. #elif 0 || defined(TRY_TYPECODES_2)
    2890. 

  2890.   /* You can add more platforms here provided that
    2891. 

  2891.    1. you need it,
    2892. 

  2892.    2. it works.
    2893. 

  2893.    Bits 31..24 = Typcode, Bits 23..0 = Adress */
    2894. 

  2894.   #define oint_type_shift 24
    2895. 

  2895.   #define oint_type_len 8
    2896. 

  2896.   #define oint_type_mask 0xFF000000UL
    2897. 

  2897.   #define oint_addr_shift 0
    2898. 

  2898.   #define oint_addr_len 24
    2899. 

  2899.   #define oint_addr_mask 0x00FFFFFFUL
    2900. 

  2900. #else
    2901. 

  2901.   #error "TYPECODES maybe not supported any more on this platform. Try defining TRY_TYPECODES_1 or TRY_TYPECODES_2, or use -DHEAPCODES."
    2902. 

  2902. #endif
    2903. 

  2903. %% #if notused
    2904. 

  2904. %%  export_def(oint_type_shift);
    2905. 

  2905. %%  export_def(oint_type_len);
    2906. 

  2906. %%  export_def(oint_type_mask);
    2907. 

  2907. %%  export_def(oint_addr_shift);
    2908. 

  2908. %%  export_def(oint_addr_len);
    2909. 

  2909. %%  export_def(oint_addr_mask);
    2910. 

  2910. %% #endif
    2911. 

  2911. #ifndef oint_type_len
    2912. 

  2912. #error "CLISP has not been ported to this platform - oint_type_len undefined"
    2913. 

  2913. #endif
    2914. 

  2914. 

  2915. /* Generally we use all of the space of an address for the data of Fixnums etc.
    2916. 

  2916.  Always     [oint_data_shift..oint_data_shift+oint_data_len-1] is subset of
    2917. 

  2917.             [oint_addr_shift..oint_addr_shift+oint_addr_len-1],
    2918. 

  2918.  thus       oint_data_len <= oint_addr_len. */
    2919. 

  2919. #ifndef oint_data_len
    2920. 

  2920.   #define oint_data_shift oint_addr_shift
    2921. 

  2921.   #define oint_data_len oint_addr_len
    2922. 

  2922.   #define oint_data_mask oint_addr_mask
    2923. 

  2923. #endif
    2924. 

  2924. %% #if notused
    2925. 

  2925. %%  export_def(oint_data_shift);
    2926. 

  2926. %%  export_def(oint_data_len);
    2927. 

  2927. %%  export_def(oint_data_mask);
    2928. 

  2928. %% #endif
    2929. 

  2929. 

  2930. /* Integer type for typebits: */
    2931. 

  2931. typedef unsigned_int_with_n_bits(oint_type_len)  tint;
    2932. 

  2932. %% sprintf(buf,"uint%d",oint_type_len); emit_typedef(buf,"tint");
    2933. 

  2933. 

  2934. /* Integer type for addresses: */
    2935. 

  2935. typedef unsigned_int_with_n_bits(oint_addr_len)  aint;
    2936. 

  2936. typedef signed_int_with_n_bits(oint_addr_len)  saint;
    2937. 

  2937. %% sprintf(buf,"uint%d",oint_addr_len); emit_typedef(buf,"aint");
    2938. 

  2938. %% #if notused
    2939. 

  2939. %% sprintf(buf,"sint%d",oint_addr_len); emit_typedef(buf,"saint");
    2940. 

  2940. %% #endif
    2941. 

  2941. 

  2942. /* Integer type for immediate values:
    2943. 

  2943.  Always 32 = intLsize <= intVsize <= 64. */
    2944. 

  2944. #if (oint_data_len <= 32)
    2945. 

  2945.   #define intVsize 32
    2946. 

  2946. #else
    2947. 

  2947.   #define intVsize 64
    2948. 

  2948. #endif
    2949. 

  2949. typedef unsigned_int_with_n_bits(intVsize)  uintV;
    2950. 

  2950. typedef signed_int_with_n_bits(intVsize)  sintV;
    2951. 

  2951. %% sprintf(buf,"uint%d",intVsize); emit_typedef(buf,"uintV");
    2952. 

  2952. %% sprintf(buf,"sint%d",intVsize); emit_typedef(buf,"sintV");
    2953. 

  2953. 

  2954. /* Integer type used to represent an amount of memory:
    2955. 

  2955.  (This may be larger than size_t or ptrdiff_t: size_t is required by ISO C to
    2956. 

  2956.  be enough for the size of a single memory block; ptrdiff_t is required by
    2957. 

  2957.  ISO C to be enough for the size of a single memory block plus room for a sign
    2958. 

  2958.  bit. But on segmented architectures which allow many medium-sized memory
    2959. 

  2959.  blocks, like the 80286 was, the total available memory size may be bigger.
    2960. 

  2960.  Also, we avoid size_t because it's likely to be wrong on 64-bit Woe32.) */
    2961. 

  2961. #if !defined(WIDE_HARD) || ((oint_addr_mask & ~0xFFFFFFFFUL) == 0)
    2962. 

  2962.   /* A 32-bit integer is sufficient. */
    2963. 

  2963.   #define intMsize  intLsize
    2964. 

  2964.   typedef uintL uintM;
    2965. 

  2965.   typedef sintL sintM;
    2966. 

  2966. #else
    2967. 

  2967.   /* An integer as wide as a pointer may be required. */
    2968. 

  2968.   #define intMsize  pointer_bitsize
    2969. 

  2969.   typedef uintP uintM;
    2970. 

  2970.   typedef sintP sintM;
    2971. 

  2971. #endif
    2972. 

  2972. 

  2973. /* Number of bits by which an address is finally being shifted: */
    2974. 

  2974. #ifndef addr_shift
    2975. 

  2975.   #define addr_shift 0
    2976. 

  2976. #endif
    2977. 

  2977. %% #if notused
    2978. 

  2978. %%  export_def(addr_shift);
    2979. 

  2979. %% #endif
    2980. 

  2980. 

  2981. /* Verify the values w.r.t. the autoconfigured CODE_ADDRESS_RANGE and
    2982. 

  2982.  MALLOC_ADDRESS_RANGE values. */
    2983. 

  2983. #if !defined(WIDE_SOFT)
    2984. 

  2984.   #if (CODE_ADDRESS_RANGE >> addr_shift) & ~(oint_addr_mask >> oint_addr_shift)
    2985. 

  2985.      #error "oint_addr_mask doesn't cover CODE_ADDRESS_RANGE !!"
    2986. 

  2986.   #endif
    2987. 

  2987.   #if (MALLOC_ADDRESS_RANGE >> addr_shift) & ~(oint_addr_mask >> oint_addr_shift)
    2988. 

  2988.      #error "oint_addr_mask doesn't cover MALLOC_ADDRESS_RANGE !!"
    2989. 

  2989.   #endif
    2990. 

  2990. #endif
    2991. 

  2991. 

  2992. 

  2993. #if (oint_addr_shift == 0) && (addr_shift == 0) && defined(TYPECODES) && !defined(WIDE_SOFT) && !(defined(SUN3) && !defined(UNIX_SUNOS4) && !defined(WIDE_SOFT)) && !(defined(AMD64) && defined(UNIX_LINUX))
    2994. 

  2994. /* If the address bits are the lower ones and not WIDE_SOFT,
    2995. 

  2995.  memory mapping may be possible. */
    2996. 

  2996. 

  2997.   #if (defined(HAVE_MMAP_ANON) || defined(HAVE_MMAP_DEVZERO) || defined(HAVE_MACH_VM) || defined(HAVE_WIN32_VM)) && !defined(MULTIMAP_MEMORY) && !(defined(UNIX_SINIX) || defined(UNIX_AIX)) && !defined(NO_SINGLEMAP)
    2998. 

  2998.     /* Access to LISP-objects is made easier by putting each LISP-object
    2999. 

  2999.      to an address that already contains its type information.
    3000. 

  3000.      But this does not work on SINIX and AIX. */
    3001. 

  3001.       #define SINGLEMAP_MEMORY
    3002. 

  3002.   #endif
    3003. 

  3003. 

  3004.   #if defined(UNIX_SUNOS4) && !defined(MULTIMAP_MEMORY) && !defined(SINGLEMAP_MEMORY) && !defined(NO_MULTIMAP_FILE)
    3005. 

  3005.     /* Access to Lisp-objects is done through memory-mapping: Each
    3006. 

  3006.      memory page can be accessed at several addresses. */
    3007. 

  3007.       #define MULTIMAP_MEMORY
    3008. 

  3008.       #define MULTIMAP_MEMORY_VIA_FILE
    3009. 

  3009.   #endif
    3010. 

  3010. 

  3011.   #if defined(HAVE_SHM) && !defined(MULTIMAP_MEMORY) && !defined(SINGLEMAP_MEMORY) && !defined(NO_MULTIMAP_SHM)
    3012. 

  3012.     /* Access to Lisp-objects is done through memory-mapping: Each
    3013. 

  3013.      memory page can be accessed at several addresses. */
    3014. 

  3014.       #define MULTIMAP_MEMORY
    3015. 

  3015.       #define MULTIMAP_MEMORY_VIA_SHM
    3016. 

  3016.   #endif
    3017. 

  3017. 

  3018.   #if (defined(UNIX_LINUX) || defined(UNIX_FREEBSD)) && !defined(MULTIMAP_MEMORY) && !defined(SINGLEMAP_MEMORY) && !defined(NO_MULTIMAP_FILE)
    3019. 

  3019.      /* Access to Lisp-objects is done through memory-mapping: Each
    3020. 

  3020.       memory page can be accessed at several addresses. */
    3021. 

  3021.       #define MULTIMAP_MEMORY
    3022. 

  3022.       #define MULTIMAP_MEMORY_VIA_FILE
    3023. 

  3023.   #endif
    3024. 

  3024. 

  3025. #endif
    3026. 

  3026. 

  3027. #if defined(MULTIMAP_MEMORY) || defined(SINGLEMAP_MEMORY)
    3028. 

  3028.   #define MAP_MEMORY
    3029. 

  3029. #endif
    3030. 

  3030. 

  3031. #if (defined(HAVE_MMAP_ANON) || defined(HAVE_MMAP_DEVZERO) || defined(HAVE_MACH_VM) || defined(HAVE_WIN32_VM)) && !defined(MAP_MEMORY) && !(defined(UNIX_HPUX) || defined(UNIX_AIX) || defined(ADDRESS_RANGE_RANDOMIZED)) && !defined(NO_TRIVIALMAP)
    3032. 

  3032.   /* mmap() allows for a more flexible way of memory management than malloc().
    3033. 

  3033.    It's not really memory-mapping, but a more comfortable way to
    3034. 

  3034.    manage two large memory blocks.
    3035. 

  3035.    But it doesn't work on HP-UX 9 and AIX.
    3036. 

  3036.    Also it does not work reliably when address space layout randomization
    3037. 

  3037.    is in effect: TRIVIALMAP_MEMORY assumes that one can increase existing a
    3038. 

  3038.    memory region by mmapping the pages after it; but this might overwrite
    3039. 

  3039.    some small malloc regions that have been put there by the system. */
    3040. 

  3040.   #define TRIVIALMAP_MEMORY
    3041. 

  3041. #endif
    3042. 

  3042. 

  3043. 

  3044. /* Flavor of the garbage collection: normal or generational. */
    3045. 

  3045. #if defined(VIRTUAL_MEMORY) && (defined(SINGLEMAP_MEMORY) || defined(TRIVIALMAP_MEMORY) || (defined(MULTIMAP_MEMORY) && (defined(UNIX_LINUX) || defined(UNIX_FREEBSD)))) && defined(HAVE_WORKING_MPROTECT) && defined(HAVE_SIGSEGV_RECOVERY) && !defined(UNIX_IRIX) && !defined(WIDE_SOFT_LARGEFIXNUM) && (SAFETY < 3) && !defined(NO_GENERATIONAL_GC)
    3046. 

  3046.   /* "generational garbage collection" has some requirements.
    3047. 

  3047.    With Linux, it will only work with 1.1.52, and higher, which will be checked in makemake.
    3048. 

  3048.    On IRIX 6, it worked in the past, but leads to core dumps now. Reason unknown. FIXME! */
    3049. 

  3049.   #define GENERATIONAL_GC
    3050. 

  3050. #endif
    3051. 

  3051. 

  3052. 

  3053. #ifdef MAP_MEMORY
    3054. 

  3054.   /* Some type-bit combinations might not be allowed */
    3055. 

  3055.   #ifdef vm_addr_mask
    3056. 

  3056.     #define tint_allowed_type_mask  ((oint_type_mask & vm_addr_mask) >> oint_type_shift)
    3057. 

  3057.   #endif
    3058. 

  3058. #endif
    3059. 

  3059. 

  3060. 

  3061. /* Complete the definition of the type 'gcv_object_t'. */
    3062. 

  3062. #if defined(WIDE_AUXI) || defined(OBJECT_STRUCT) || defined(WIDE_STRUCT)
    3063. 

  3063.   #if defined(WIDE) && !defined(WIDE_HARD)
    3064. 

  3064.     #ifdef GENERATIONAL_GC
    3065. 

  3065.       /* The generational GC can't deal with an object-pointer that points
    3066. 

  3066.        towards two memory pages.
    3067. 

  3067.        Thus we enforce alignof(gcv_object_t) = sizeof(gcv_object_t). */
    3068. 

  3068.       #define _attribute_aligned_object_  __attribute__ ((aligned(8)))
    3069. 

  3069.     #else
    3070. 

  3070.       #define _attribute_aligned_object_
    3071. 

  3071.     #endif
    3072. 

  3072.   #endif
    3073. 

  3073.   #ifdef DEBUG_GCSAFETY
    3074. 

  3074.     struct object;
    3075. 

  3075.     struct gcv_object_t {
    3076. 

  3076.       INNARDS_OF_GCV_OBJECT
    3077. 

  3077.       /* Conversion to object. */
    3078. 

  3078.       operator object () const;
    3079. 

  3079.       /* Conversion from object. */
    3080. 

  3080.       gcv_object_t (object obj);
    3081. 

  3081.       /* Conversion from fake_gcv_object. */
    3082. 

  3082.       gcv_object_t (struct fake_gcv_object obj);
    3083. 

  3083.       /* Uninitialized object. */
    3084. 

  3084.       gcv_object_t ();
    3085. 

  3085.     };
    3086. 

  3086.   #else
    3087. 

  3087.     typedef struct { INNARDS_OF_GCV_OBJECT } gcv_object_t;
    3088. 

  3088.   #endif
    3089. 

  3089. #endif
    3090. 

  3090. #ifndef _attribute_aligned_object_
    3091. 

  3091.   #define _attribute_aligned_object_
    3092. 

  3092. #endif
    3093. 

  3093. 

  3094. 

  3095. /* Define the type 'object'. */
    3096. 

  3096. #ifdef DEBUG_GCSAFETY
    3097. 

  3097.   /* A counter that is incremented each time an allocation occurs that could
    3098. 

  3098.    trigger GC. */
    3099. 

  3099.   extern uintL alloccount;
    3100. 

  3100. 

  3101.   /* A register-allocated object contains, if not GC-invariant, the timestamp
    3102. 

  3102.    of when it was fetched from a GC-visible location. */
    3103. 

  3103.   struct object {
    3104. 

  3104.     INNARDS_OF_GCV_OBJECT
    3105. 

  3105.     uintL allocstamp;
    3106. 

  3106.   };
    3107. 

  3107.   /* Always initialize allocstamp with the current(!) value of alloccount. */
    3108. 

  3108.   #define INIT_ALLOCSTAMP  , allocstamp: alloccount
    3109. 

  3109. #else
    3110. 

  3110.   typedef gcv_object_t object;
    3111. 

  3111.   #define INIT_ALLOCSTAMP
    3112. 

  3112. #endif
    3113. 

  3113. %% #ifdef DEBUG_GCSAFETY
    3114. 

  3114. %%   puts("extern uintL alloccount;");
    3115. 

  3115. %% #else
    3116. 

  3116. %%   emit_typedef("gcv_object_t","object");
    3117. 

  3117. %% #endif
    3118. 

  3118. 

  3119. /* fake_gcv_object(value)
    3120. 

  3120.  creates a gcv_object that is actually not seen by GC,
    3121. 

  3121.  for use as second word in SKIP2 frames. */
    3122. 

  3122. #ifdef DEBUG_GCSAFETY
    3123. 

  3123.   struct fake_gcv_object {
    3124. 

  3124.     oint fake_value;
    3125. 

  3125.     fake_gcv_object (oint value) : fake_value (value) {}
    3126. 

  3126.   };
    3127. 

  3127. #else
    3128. 

  3128.   #define fake_gcv_object(value)  as_object((oint)(value))
    3129. 

  3129. #endif
    3130. 

  3130. 

  3131. /* Hack for use only in areas where no GC can be triggered. */
    3132. 

  3132. #ifdef DEBUG_GCSAFETY
    3133. 

  3133.   struct gcunsafe_object_t : gcv_object_t {
    3134. 

  3134.     uintL allocstamp;
    3135. 

  3135.     /* Conversion from object. */
    3136. 

  3136.     gcunsafe_object_t (object obj);
    3137. 

  3137.     /* Conversion from gcv_object_t. */
    3138. 

  3138.     gcunsafe_object_t (gcv_object_t obj);
    3139. 

  3139.     /* Verification that no GC has been triggered. */
    3140. 

  3140.     ~gcunsafe_object_t ();
    3141. 

  3141.   };
    3142. 

  3142. #else
    3143. 

  3143.   typedef gcv_object_t gcunsafe_object_t;
    3144. 

  3144. #endif
    3145. 

  3145. 

  3146. 

  3147. /* mask of those bits of a tint, which really belong to the type:
    3148. 

  3148.  tint_type_mask = oint_type_mask >> oint_type_shift
    3149. 

  3149.  (a constant expression, without any 'long long's in it!) */
    3150. 

  3150. #ifdef WIDE_SOFT
    3151. 

  3151.   #define tint_type_mask  (bitm(oint_type_len)-1)
    3152. 

  3152. #else
    3153. 

  3153.   #define tint_type_mask  (oint_type_mask >> oint_type_shift)
    3154. 

  3154. #endif
    3155. 

  3155. %% #if notused
    3156. 

  3156. %% export_def(tint_type_mask);
    3157. 

  3157. %% #endif
    3158. 

  3158. 

  3159. /* To add something to an object/oint:
    3160. 

  3160.  objectplus(obj,offset) */
    3161. 

  3161. #if !(defined(WIDE_SOFT) || defined(WIDE_AUXI) || defined(OBJECT_STRUCT))
    3162. 

  3162.   #define objectplus(obj,offset)  ((object)pointerplus(obj,offset))
    3163. 

  3163. #elif defined(WIDE_AUXI)
    3164. 

  3164.   static inline object objectplus (object obj, saint offset) {
    3165. 

  3165.     return (object){u:{both:{ one_ob: obj.one_o+offset, auxi_ob: obj.auxi_o }}};
    3166. 

  3166.   }
    3167. 

  3167. #else /* defined(WIDE_SOFT) || defined(OBJECT_STRUCT) */
    3168. 

  3168.   #define objectplus(obj,offset)  as_object(as_oint(obj)+(soint)(offset))
    3169. 

  3169. #endif
    3170. 

  3170. %% #if !(defined(WIDE_SOFT) || defined(WIDE_AUXI) || defined(OBJECT_STRUCT))
    3171. 

  3171. %%   emit_define("objectplus(obj,offset)","((object)pointerplus(obj,offset))");
    3172. 

  3172. %% #elif defined(WIDE_AUXI)
    3173. 

  3173. %%   puts("static inline object objectplus (object obj, saint offset) { return (object){u:{both:{ one_ob: obj.one_o+offset, auxi_ob: obj.auxi_o }}}; }");
    3174. 

  3174. %% #else
    3175. 

  3175. %%   emit_define("objectplus(obj,offset)","as_object(as_oint(obj)+(soint)(offset))");
    3176. 

  3176. %% #endif
    3177. 

  3177. 

  3178. /* Bit operations on entities of type uintV:
    3179. 

  3179.  ...vbit... instead of ...bit..., "v" = "value". */
    3180. 

  3180. #if (intVsize > 32)
    3181. 

  3181.   #define vbit(n)  (LL(1)<<(n))
    3182. 

  3182.   #define vbitm(n)  (LL(2)<<((n)-1))
    3183. 

  3183.   #define vbit_test(x,n)  ((x) & vbit(n))
    3184. 

  3184.   #define minus_vbit(n)  (-LL(1)<<(n))
    3185. 

  3185. #else
    3186. 

  3186.   #define vbit  bit
    3187. 

  3187.   #define vbitm  bitm
    3188. 

  3188.   #define vbit_test  bit_test
    3189. 

  3189.   #define minus_vbit  minus_bit
    3190. 

  3190. #endif
    3191. 

  3191. %% #if notused
    3192. 

  3192. %%  export_def(vbit(n));
    3193. 

  3193. %%  export_def(vbitm(n));
    3194. 

  3194. %%  export_def(vbit_test(x,n));
    3195. 

  3195. %%  export_def(minus_vbit(n));
    3196. 

  3196. %% #endif
    3197. 

  3197. 

  3198. /* Bit operations on entities of type oint:
    3199. 

  3199.  ...wbit... instead of ...bit..., "w" = "wide". */
    3200. 

  3200. #if defined(WIDE_SOFT) || defined(WIDE_AUXI)
    3201. 

  3201.   #define wbit(n)  (LL(1)<<(n))
    3202. 

  3202.   #define wbitm(n)  (LL(2)<<((n)-1))
    3203. 

  3203.   #define wbit_test(x,n)  ((x) & wbit(n))
    3204. 

  3204.   #define minus_wbit(n)  (-LL(1)<<(n))
    3205. 

  3205. #else
    3206. 

  3206.   #define wbit  bit
    3207. 

  3207.   #define wbitm  bitm
    3208. 

  3208.   #define wbit_test  bit_test
    3209. 

  3209.   #define minus_wbit  minus_bit
    3210. 

  3210. #endif
    3211. 

  3211. %% export_def(wbit);
    3212. 

  3212. %% #if notused
    3213. 

  3213. %%  export_def(wbitm);
    3214. 

  3214. %% #endif
    3215. 

  3215. %% export_def(wbit_test);
    3216. 

  3216. %% export_def(minus_wbit);
    3217. 

  3217. 

  3218. #ifdef TYPECODES
    3219. 

  3219. 

  3220.   /* Type info:
    3221. 

  3221.    typecode(object) and mtypecode(object) yield the type code of
    3222. 

  3222.    an object obj. For mtypecode it has to be in memory. */
    3223. 

  3223.   #if !(exact_uint_size_p(oint_type_len) && (tint_type_mask == bit(oint_type_len)-1))
    3224. 

  3224.     #define typecode(expr)  \
    3225. 

  3225.       ((tint)(as_oint(expr) >> oint_type_shift) & (oint_type_mask >> oint_type_shift))
    3226. 

  3226.     #define mtypecode(expr)  typecode(expr)
    3227. 

  3227.   #else
    3228. 

  3228.     /* The type 'tint' has exactly oint_type_len bits,
    3229. 

  3229.      and tint_type_mask = 2^oint_type_len-1.
    3230. 

  3230.      So it's not necessary for you to AND.
    3231. 

  3231.      On the other hand on a 68000 a ROL.L #8 is faster,
    3232. 

  3232.      as is a shift on a SPARC. */
    3233. 

  3233.     #define typecode(expr)  ((tint)(as_oint(expr) >> oint_type_shift))
    3234. 

  3234.     #if defined(MC68000) && defined(GNU) && !defined(NO_ASM) && (oint_type_shift==24) && (oint_type_len==8)
    3235. 

  3235.       /* GNU C on a 68000, replace LSR.L #24 with ROL.L #8 : */
    3236. 

  3236.       #undef typecode
    3237. 

  3237.       #define typecode(expr)  \
    3238. 

  3238.         ({var tint __typecode;                                               \
    3239. 

  3239.           __asm__ ("roll #8,%0" : "=d" (__typecode) : "0" (as_oint(expr)) ); \
    3240. 

  3240.           __typecode;                                                        \
    3241. 

  3241.          })
    3242. 

  3242.       #elif defined(SPARC) && !defined(WIDE)
    3243. 

  3243.       #undef typecode
    3244. 

  3244.       #define typecode(expr)  \
    3245. 

  3245.         ((as_oint(expr) << (32-oint_type_len-oint_type_shift)) >> (32-oint_type_len))
    3246. 

  3246.     #elif defined(WIDE) && defined(WIDE_STRUCT)
    3247. 

  3247.       #undef typecode
    3248. 

  3248.       #define typecode(expr)  ((expr).u.both.type)
    3249. 

  3249.     #endif
    3250. 

  3250.     /* Furthermore you can do accesses in memory without shift: */
    3251. 

  3251.     #if !defined(WIDE) && (((oint_type_shift==24) && BIG_ENDIAN_P) || ((oint_type_shift==0) && !BIG_ENDIAN_P))
    3252. 

  3252.       #define mtypecode(expr)  (*(tint*)&(expr))
    3253. 

  3253.       #define fast_mtypecode
    3254. 

  3254.     #elif !defined(WIDE) && (((oint_type_shift==24) && !BIG_ENDIAN_P) || ((oint_type_shift==0) && BIG_ENDIAN_P))
    3255. 

  3255.       #define mtypecode(expr)  (*((tint*)&(expr)+3))
    3256. 

  3256.       #define fast_mtypecode
    3257. 

  3257.     #elif defined(WIDE)
    3258. 

  3258.       #ifdef WIDE_STRUCT
    3259. 

  3259.         #define mtypecode(expr)  ((expr).u.both.type)
    3260. 

  3260.       #elif (oint_type_len==16)
    3261. 

  3261.         #if (oint_type_shift==0) == BIG_ENDIAN_P
    3262. 

  3262.           #define mtypecode(expr)  (*((tint*)&(expr)+3))
    3263. 

  3263.         #else /* (oint_type_shift==48) == BIG_ENDIAN_P */
    3264. 

  3264.           #define mtypecode(expr)  (*(tint*)&(expr))
    3265. 

  3265.         #endif
    3266. 

  3266.       #elif (oint_type_len==32)
    3267. 

  3267.         #if (oint_type_shift==0) == BIG_ENDIAN_P
    3268. 

  3268.           #define mtypecode(expr)  (*((tint*)&(expr)+1))
    3269. 

  3269.         #else /* (oint_type_shift==32) == BIG_ENDIAN_P */
    3270. 

  3270.           #define mtypecode(expr)  (*(tint*)&(expr))
    3271. 

  3271.         #endif
    3272. 

  3272.       #endif
    3273. 

  3273.       #define fast_mtypecode
    3274. 

  3274.     #else /* no optimization is possible */
    3275. 

  3275.       #define mtypecode(expr)  typecode(expr)
    3276. 

  3276.     #endif
    3277. 

  3277.   #endif
    3278. 

  3278. 

  3279.   /* Extraction of the address field without type info.
    3280. 

  3280.    untype(obj) */
    3281. 

  3281.   #if defined(WIDE) && defined(WIDE_STRUCT)
    3282. 

  3282.     #define untype(expr)  ((expr).u.both.addr)
    3283. 

  3283.   #elif !(defined(SPARC) && (oint_addr_len+oint_addr_shift<32))
    3284. 

  3284.     #define untype(expr)    \
    3285. 

  3285.       ((aint)(as_oint(expr) >> oint_addr_shift) & (aint)(oint_addr_mask >> oint_addr_shift))
    3286. 

  3286.   #else
    3287. 

  3287.     /* On a SPARC processor long constants are slower than shifts:
    3288. 

  3288.      Possibly, one does not need to use AND here. */
    3289. 

  3289.     #define untype(expr)  \
    3290. 

  3290.       ((aint)((as_oint(expr) << (32-oint_addr_len-oint_addr_shift)) >> (32-oint_addr_len)))
    3291. 

  3291.   #endif
    3292. 

  3292. 

  3293.   /* Object from type info and address field:
    3294. 

  3294.    type_untype_object(type,address) */
    3295. 

  3295.   #if defined(WIDE) && defined(WIDE_STRUCT)
    3296. 

  3296.     #if BIG_ENDIAN_P==WIDE_ENDIANNESS
    3297. 

  3297.       #define type_untype_object(type,address)  ((object){{(tint)(type),(aint)(address)}INIT_ALLOCSTAMP})
    3298. 

  3298.     #else
    3299. 

  3299.       #define type_untype_object(type,address)  ((object){{(aint)(address),(tint)(type)}INIT_ALLOCSTAMP})
    3300. 

  3300.     #endif
    3301. 

  3301.   #elif !(oint_addr_shift==0)
    3302. 

  3302.     #define type_untype_object(type,address)  \
    3303. 

  3303.       (as_object(  ((oint)(tint)(type) << oint_type_shift) + \
    3304. 

  3304.                    ((oint)(aint)(address) << oint_addr_shift) ))
    3305. 

  3305.   #else /* you don't have to shift if oint_addr_shift=0: */
    3306. 

  3306.     #if defined(WIDE_SOFT)
    3307. 

  3307.       /* Beware: Conversion of  address  to oint by Zero-Extend! */
    3308. 

  3308.       #define type_untype_object(type,address)              \
    3309. 

  3309.         objectplus((oint)(aint)(address),(oint)(tint)(type)<<oint_type_shift)
    3310. 

  3310.     #elif defined(WIDE_AUXI)
    3311. 

  3311.       #define type_untype_object(type,address)              \
    3312. 

  3312.         as_object_with_auxi((aint)pointerplus((address),(aint)(tint)(type)<<oint_type_shift))
    3313. 

  3313.     #elif defined(OBJECT_STRUCT)
    3314. 

  3314.       #define type_untype_object(type,address)              \
    3315. 

  3315.         as_object((oint)pointerplus((address),(oint)(tint)(type)<<oint_type_shift))
    3316. 

  3316.     #else /* normal case */
    3317. 

  3317.       /* In order for this (NIL_IS_CONSTANT) to be a valid initializer
    3318. 

  3318.        under gcc-2.5.8, you must not cast from pointer to oint and then
    3319. 

  3319.        back to pointer, but you'll have to stay in the pointer's range.. */
    3320. 

  3320.       #define type_untype_object(type,address)              \
    3321. 

  3321.         as_object(pointerplus((address),(oint)(tint)(type)<<oint_type_shift))
    3322. 

  3322.     #endif
    3323. 

  3323.   #endif
    3324. 

  3324. 

  3325.   /* Object from type info and direct data (as "address"):
    3326. 

  3326.    type_data_object(type,data) */
    3327. 

  3327.   #if defined(WIDE) && defined(WIDE_STRUCT)
    3328. 

  3328.     #if BIG_ENDIAN_P==WIDE_ENDIANNESS
    3329. 

  3329.       #define type_data_object(type,data)  ((object){{(tint)(type),(aint)(data)}INIT_ALLOCSTAMP})
    3330. 

  3330.     #else
    3331. 

  3331.       #define type_data_object(type,data)  ((object){{(aint)(data),(tint)(type)}INIT_ALLOCSTAMP})
    3332. 

  3332.     #endif
    3333. 

  3333.   #elif !(oint_addr_shift==0)
    3334. 

  3334.     #define type_data_object(type,data)  \
    3335. 

  3335.       (as_object(  ((oint)(tint)(type) << oint_type_shift) + \
    3336. 

  3336.                    ((oint)(aint)(data) << oint_addr_shift) ))
    3337. 

  3337.   #else /* if oint_addr_shift=0, you don't have to shift: */
    3338. 

  3338.     #define type_data_object(type,data)  \
    3339. 

  3339.       (as_object( ((oint)(tint)(type) << oint_type_shift) + (oint)(aint)(data) ))
    3340. 

  3340.   #endif
    3341. 

  3341. 

  3342.   /* Extraction of the address without type info:
    3343. 

  3343.    upointer(obj)
    3344. 

  3344.    (upointer means "untyped pointer".) */
    3345. 

  3345.   #if (addr_shift==0)
    3346. 

  3346.     #define upointer  untype
    3347. 

  3347.   #else
    3348. 

  3348.     #define optimized_upointer(obj)  \
    3349. 

  3349.       ((aint)((as_oint(obj) << (32-oint_addr_len-oint_addr_shift)) >> (32-oint_addr_len-addr_shift)))
    3350. 

  3350.     #define upointer(obj)  (untype(obj)<<addr_shift)
    3351. 

  3351.   #endif
    3352. 

  3352. 

  3353.   /* Object from type info and address:
    3354. 

  3354.    type_pointer_object(type,address) */
    3355. 

  3355.   #if defined(WIDE_SOFT) && !defined(WIDE_STRUCT)
    3356. 

  3356.     /* Cast to uintP, so that conversion of  address  to aint is done by Zero-Extend! */
    3357. 

  3357.     #define type_pointer_object(type,address)  \
    3358. 

  3358.       type_untype_object(type,(aint)(uintP)(address)>>addr_shift)
    3359. 

  3359.   #elif (addr_shift==0)
    3360. 

  3360.     /* (No cast to aint, so NIL can be used to initialize.) */
    3361. 

  3361.     #define type_pointer_object(type,address)  \
    3362. 

  3362.       type_untype_object(type,address)
    3363. 

  3363.   #else /* more efficient, */
    3364. 

  3364.     /* but this requires address to be divisible by 2^addr_shift: */
    3365. 

  3365.     #define type_pointer_object(type,address)  \
    3366. 

  3366.       (as_object(((oint)(tint)(type) << oint_type_shift) + \
    3367. 

  3367.                  ((oint)(aint)(address) << (oint_addr_shift-addr_shift))))
    3368. 

  3368.   #endif
    3369. 

  3369. 

  3370.   /* Object from constant type info and constant address:
    3371. 

  3371.    type_constpointer_object(type,address) */
    3372. 

  3372.   #define type_constpointer_object(type,address)  type_pointer_object(type,address)
    3373. 

  3373. 

  3374.   /* oint from constant type info and address = 0:
    3375. 

  3375.    type_zero_oint(type) */
    3376. 

  3376.   #if defined(WIDE_SOFT) && defined(WIDE_STRUCT)
    3377. 

  3377.     #define type_zero_oint(type)  as_oint(type_untype_object(type,0))
    3378. 

  3378.   #else
    3379. 

  3379.     #define type_zero_oint(type)  ((oint)(tint)(type) << oint_type_shift)
    3380. 

  3380.   #endif
    3381. 

  3381. 

  3382. #else /* HEAPCODES */
    3383. 

  3383. 

  3384.   #ifdef STANDARD_HEAPCODES
    3385. 

  3385. 

  3386.     /* We can assume a general alignment of 4 bytes, and thus have the low 2
    3387. 

  3387.      bits for encoding type. Here's how we divide the address space:
    3388. 

  3388.        machine, frame_pointer  1/4
    3389. 

  3389.        subr                    1/4
    3390. 

  3390.        cons                    1/8
    3391. 

  3391.        varobject               1/4 (not 1/8 because symbol_tab is not 8-aligned)
    3392. 

  3392.        immediate               > 0 (anything >= 7/256 does it).
    3393. 

  3393.      Note that cons and varobject cannot have the same encoding mod 8
    3394. 

  3394.      (otherwise gc_mark:up wouldn't work).
    3395. 

  3395.      So, here are the encodings.
    3396. 

  3396.        machine             ... .00   encodes pointers, offset 0
    3397. 

  3397.        subr                ... .10   encodes pointers, offset 2
    3398. 

  3398.        varobject           ... .01   offset 1, the pointers are == 0 mod 4
    3399. 

  3399.        cons                ... 011   offset 3, the pointers are == 0 mod 8
    3400. 

  3400.        immediate           ... 111
    3401. 

  3401.          fixnum            00s 111   s = sign bit
    3402. 

  3402.          sfloat            01s 111   s = sign bit
    3403. 

  3403.          char              100 111
    3404. 

  3404.          small-read-label  110 111
    3405. 

  3405.          system            111 111
    3406. 

  3406.      Varobjects all start with a word containing the type (1 byte) and a
    3407. 

  3407.      length field (up to 24 bits). */
    3408. 

  3408. 

  3409.     /* These are the biases, mod 8. */
    3410. 

  3410.       #define machine_bias    0UL  /* mod 4 */
    3411. 

  3411.       #define subr_bias       2UL  /* mod 4 */
    3412. 

  3412.       #define varobject_bias  1UL  /* mod 4 */
    3413. 

  3413.       #define cons_bias       3UL  /* mod 8 */
    3414. 

  3414.       #define immediate_bias  7UL  /* mod 8 */
    3415. 

  3415. 

  3416.     /* Immediate objects have a second type field. */
    3417. 

  3417.       #if defined(LINUX_SPARC_OLD_GLIBC)
    3418. 

  3418.         #define imm_type_shift  29
    3419. 

  3419.       #else
    3420. 

  3420.         #define imm_type_shift  3
    3421. 

  3421.       #endif
    3422. 

  3422. 

  3423.     /* The types of immediate objects. */
    3424. 

  3424.       #define fixnum_type            ((0 << imm_type_shift) + immediate_bias)
    3425. 

  3425.       #define sfloat_type            ((2 << imm_type_shift) + immediate_bias)
    3426. 

  3426.       #define char_type              ((4 << imm_type_shift) + immediate_bias)
    3427. 

  3427.       #define small_read_label_type  ((6 << imm_type_shift) + immediate_bias)
    3428. 

  3428.       #define system_type            ((7 << imm_type_shift) + immediate_bias)
    3429. 

  3429. 

  3430.     /* The sign bit, for immediate numbers only. */
    3431. 

  3431.       #define sign_bit_t  (0 + imm_type_shift)
    3432. 

  3432.       #define sign_bit_o  (sign_bit_t+oint_type_shift)
    3433. 

  3433.     /* Distinction between fixnums and bignums. */
    3434. 

  3434.       #define bignum_bit_o  1
    3435. 

  3435.       #define NUMBER_BITS_INVERTED
    3436. 

  3436.     /* Distinction between fixnums, short-floats and other kinds of numbers.
    3437. 

  3437.      (NB: IMMEDIATE_FFLOAT is not defined for HEAPCODES.) */
    3438. 

  3438.       #define number_immediatep(obj)  ((as_oint(obj) & wbit(1)) != 0)
    3439. 

  3439. 

  3440.     /* For masking out the nonimmediate biases.
    3441. 

  3441.      This must be 3, not 7, otherwise gc_mark won't work. */
    3442. 

  3442.       #define nonimmediate_bias_mask  3
    3443. 

  3443.       #define nonimmediate_heapcode_mask  3
    3444. 

  3444. 

  3445.     /* Combine an object from type info and immediate data.
    3446. 

  3446.      type_data_object(type,data) */
    3447. 

  3447.       #define type_data_object(type,data)  \
    3448. 

  3448.           (as_object(  ((oint)(tint)(type) << oint_type_shift) + \
    3449. 

  3449.                        ((oint)(aint)(data) << oint_data_shift) ))
    3450. 

  3450. 

  3451.     /* An oint made up with a given type info, and address = 0.
    3452. 

  3452.      type_zero_oint(type) */
    3453. 

  3453.       #define type_zero_oint(type)  ((oint)(tint)(type) << oint_type_shift)
    3454. 

  3454. 

  3455.     /* The GC bit. Addresses may not have this bit set. */
    3456. 

  3456.       /* define garcol_bit_o  (already defined above)  # only set during garbage collection */
    3457. 

  3457. 

  3458.     /* Test for immediate object.
    3459. 

  3459.      immediate_object_p(obj) */
    3460. 

  3460.       #define immediate_object_p(obj)  ((7 & ~as_oint(obj)) == 0)
    3461. 

  3461. 

  3462.     /* Test for gc-invariant object. (This includes immediate, machine, subr.)
    3463. 

  3463.      gcinvariant_object_p(obj) */
    3464. 

  3464.       #define gcinvariant_object_p(obj)  \
    3465. 

  3465.         (((as_oint(obj) & 1) == 0) || immediate_object_p(obj))
    3466. 

  3466.       #define gcinvariant_oint_p(obj_o)  \
    3467. 

  3467.         ((((obj_o) & 1) == 0) || ((7 & ~(obj_o)) == 0))
    3468. 

  3468. 

  3469.     /* Test for gc-invariant object, given only the bias. */
    3470. 

  3470.       #define gcinvariant_bias_p(bias)  \
    3471. 

  3471.         ((((bias) & 1) == 0) || ((7 & ~(bias)) == 0))
    3472. 

  3472. 

  3473.     /* The heap of a heap allocated object. 0 for varobjects, 1 for conses. */
    3474. 

  3474.       #define nonimmediate_heapnr(obj)  \
    3475. 

  3475.         ((as_oint(obj) >> 1) & 1)
    3476. 

  3476. 

  3477.   #endif /* STANDARD_HEAPCODES */
    3478. 

  3478. 

  3479.   #ifdef LINUX_NOEXEC_HEAPCODES
    3480. 

  3480. 

  3481.     /* We must assume a general alignment of 4 bytes and an enforced alignment
    3482. 

  3482.      of 8 bytes for Lisp objects, and thus have the low 2 to 3 bits for
    3483. 

  3483.      encoding heap and the garcol_bit. Here's how we divide the address space:
    3484. 

  3484.        machine, frame_pointer  1/4 * 3/4
    3485. 

  3485.        immediate               1/4 * 1/4
    3486. 

  3486.        cons                    1/8
    3487. 

  3487.        varobject               1/8
    3488. 

  3488.      Note that cons and varobject cannot have the same encoding mod 8
    3489. 

  3489.      (otherwise gc_mark:up wouldn't work).
    3490. 

  3490.      Immediates look like pointers in the range 0xC0000000..0xFFFFFFFF.
    3491. 

  3491.      We know that the Linux kernel never assigns virtual memory in this area.
    3492. 

  3492.      So, here are the encodings. Bit 0 is used as the garcol_bit.
    3493. 

  3493.        machine                ... ... .00   encodes pointers, offset 0
    3494. 

  3494.        cons                   ... ... 010   offset 2, the pointers are == 0 mod 8
    3495. 

  3495.        varobject              ... ... 110   offset 6, the pointers are == 4 mod 8
    3496. 

  3496.        immediate           11 ... ...  00
    3497. 

  3497.          fixnum            11 ... 00s  00   s = sign bit
    3498. 

  3498.          sfloat            11 ... 01s  00   s = sign bit
    3499. 

  3499.          char              11 ... 100  00
    3500. 

  3500.          small-read-label  11 ... 110  00
    3501. 

  3501.          system            11 ... 111  00
    3502. 

  3502.      Varobjects all start with a word containing the type (1 byte) and a
    3503. 

  3503.      length field (up to 24 bits). */
    3504. 

  3504. 

  3505.     /* These are the biases. */
    3506. 

  3506.       #define machine_bias    0  /* + 0 mod 4 */
    3507. 

  3507.       #define varobject_bias  2  /* + 4 mod 8 */
    3508. 

  3508.       #define cons_bias       2  /* + 0 mod 8 */
    3509. 

  3509.       #define immediate_bias  0xC0000000  /* + 0 mod 4 */
    3510. 

  3510.       #define subr_bias       varobject_bias
    3511. 

  3511. 

  3512.     /* Immediate objects have a second type field. */
    3513. 

  3513.       #define imm_type_shift  2  /* could also be 3, if oint_data_shift == 6 */
    3514. 

  3514. 

  3515.     /* The types of immediate objects. */
    3516. 

  3516.       #define fixnum_type            ((0 << imm_type_shift) + immediate_bias)
    3517. 

  3517.       #define sfloat_type            ((2 << imm_type_shift) + immediate_bias)
    3518. 

  3518.       #define char_type              ((4 << imm_type_shift) + immediate_bias)
    3519. 

  3519.       #define small_read_label_type  ((6 << imm_type_shift) + immediate_bias)
    3520. 

  3520.       #define system_type            ((7 << imm_type_shift) + immediate_bias)
    3521. 

  3521. 

  3522.     /* The sign bit, for immediate numbers only. */
    3523. 

  3523.       #define sign_bit_t  (0 + imm_type_shift)
    3524. 

  3524.       #define sign_bit_o  (sign_bit_t+oint_type_shift)
    3525. 

  3525.     /* Distinction between fixnums and bignums. */
    3526. 

  3526.       #define bignum_bit_o  1
    3527. 

  3527.     /* Distinction between fixnums, short-floats and other kinds of numbers.
    3528. 

  3528.      (NB: IMMEDIATE_FFLOAT is not defined for HEAPCODES.) */
    3529. 

  3529.       #define number_immediatep(obj)  ((as_oint(obj) & wbit(1)) == 0)
    3530. 

  3530. 

  3531.     /* The misalignment of varobjects, modulo varobject_alignment. */
    3532. 

  3532.       #define varobjects_misaligned  4
    3533. 

  3533. 

  3534.     /* For masking out the nonimmediate biases. */
    3535. 

  3535.       #define nonimmediate_bias_mask  3
    3536. 

  3536.       #define nonimmediate_heapcode_mask  7
    3537. 

  3537. 

  3538.     /* Combine an object from type info and immediate data.
    3539. 

  3539.      type_data_object(type,data) */
    3540. 

  3540.       #define type_data_object(type,data)  \
    3541. 

  3541.           (as_object(  ((oint)(tint)(type) << oint_type_shift) + \
    3542. 

  3542.                        ((oint)(aint)(data) << oint_data_shift) ))
    3543. 

  3543. 

  3544.     /* An oint made up with a given type info, and address = 0.
    3545. 

  3545.      type_zero_oint(type) */
    3546. 

  3546.       #define type_zero_oint(type)  ((oint)(tint)(type) << oint_type_shift)
    3547. 

  3547. 

  3548.     /* The GC bit. Addresses may not have this bit set. */
    3549. 

  3549.       /* define garcol_bit_o  (already defined above)  # only set during garbage collection */
    3550. 

  3550. 

  3551.     /* Test for immediate object.
    3552. 

  3552.      immediate_object_p(obj) */
    3553. 

  3553.       #define immediate_object_p(obj)  \
    3554. 

  3554.         ((as_oint(obj) & 0xE0000003) == (immediate_bias & 0xE0000003))
    3555. 

  3555. 

  3556.     /* Test for gc-invariant object. (This includes immediate, machine.)
    3557. 

  3557.      gcinvariant_object_p(obj) */
    3558. 

  3558.       #define gcinvariant_object_p(obj)  \
    3559. 

  3559.         ((as_oint(obj) & bit(1)) == 0)
    3560. 

  3560.       #define gcinvariant_oint_p(obj_o)  \
    3561. 

  3561.         (((obj_o) & bit(1)) == 0)
    3562. 

  3562.     /* NB: Subrs are not included in this test, because subrp(obj) require a
    3563. 

  3563.      memory access. */
    3564. 

  3564. 

  3565.     /* Test for gc-invariant object, given only the bias. */
    3566. 

  3566.       #define gcinvariant_bias_p(bias)  \
    3567. 

  3567.         (((bias) & 2) == 0)
    3568. 

  3568. 

  3569.     /* The heap of a heap allocated object. 0 for varobjects, 1 for conses. */
    3570. 

  3570.       #define nonimmediate_heapnr(obj)  \
    3571. 

  3571.         (1 & ~(as_oint(obj) >> 2))
    3572. 

  3572. 

  3573.   #endif /* LINUX_NOEXEC_HEAPCODES */
    3574. 

  3574. 

  3575. #endif /* TYPECODES */
    3576. 

  3576. %% #ifdef TYPECODES
    3577. 

  3577. %%  export_def(typecode(expr));
    3578. 

  3578. %%  export_def(mtypecode(expr));
    3579. 

  3579. %%  export_def(type_untype_object(type,address));
    3580. 

  3580. %%  export_def(upointer(obj));
    3581. 

  3581. %%  export_def(type_pointer_object(type,address));
    3582. 

  3582. %%  export_def(type_constpointer_object(type,address));
    3583. 

  3583. %% #else
    3584. 

  3584. %%  export_def(number_immediatep(obj));
    3585. 

  3585. %%  export_def(immediate_object_p(obj));
    3586. 

  3586. %%  export_def(gcinvariant_object_p(obj));
    3587. 

  3587. %%  export_def(gcinvariant_oint_p(obj_o));
    3588. 

  3588. %%  export_def(gcinvariant_bias_p(bias));
    3589. 

  3589. %% #endif
    3590. 

  3590. %% export_def(type_data_object(type,address));
    3591. 

  3591. %% export_def(type_zero_oint(obj));
    3592. 

  3592. 

  3593. /* The misalignment of varobjects, modulo varobject_alignment. */
    3594. 

  3594. #ifndef varobjects_misaligned
    3595. 

  3595.   #define varobjects_misaligned  0
    3596. 

  3596. #endif
    3597. 

  3597. #if varobjects_misaligned
    3598. 

  3598.   #define VAROBJECTS_ALIGNMENT_DUMMY_DECL  char alignment_dummy[varobjects_misaligned];
    3599. 

  3599. #else
    3600. 

  3600.   #define VAROBJECTS_ALIGNMENT_DUMMY_DECL
    3601. 

  3601. #endif
    3602. 

  3602. %% export_def(varobjects_misaligned);
    3603. 

  3603. %% export_def(VAROBJECTS_ALIGNMENT_DUMMY_DECL);
    3604. 

  3604. 

  3605. /* The misalignment of conses, modulo 2*sizeof(gcv_object_t). */
    3606. 

  3606. #ifndef conses_misaligned
    3607. 

  3607.   #define conses_misaligned  0
    3608. 

  3608. #endif
    3609. 

  3609. 

  3610. 

  3611. /* Objects with variable length must reside at addresses that are divisable by 2 */
    3612. 

  3612. #if defined(VAX) /* ?? gcc/config/vax/vax.h sagt: Alignment = 4 */
    3613. 

  3613.   #define varobject_alignment  1
    3614. 

  3614. #endif
    3615. 

  3615. #if defined(MC680X0)
    3616. 

  3616.   #if addr_shift!=0
    3617. 

  3617.     #define varobject_alignment  bit(addr_shift)  /* because of the condensed distribution of typecodes */
    3618. 

  3618.   #else
    3619. 

  3619.     #define varobject_alignment  2
    3620. 

  3620.   #endif
    3621. 

  3621. #endif
    3622. 

  3622. #if defined(I80386) || defined(POWERPC) || defined(ARM) || defined(S390)
    3623. 

  3623.   #define varobject_alignment  4
    3624. 

  3624. #endif
    3625. 

  3625. #if defined(SPARC) || defined(HPPA) || defined(MIPS) || defined(M88000) || defined(DECALPHA) || defined(IA64) || defined(AMD64)
    3626. 

  3626.   #define varobject_alignment  8
    3627. 

  3627. #endif
    3628. 

  3628. #if (!defined(TYPECODES) || defined(GENERATIONAL_GC)) && (varobject_alignment < 4)
    3629. 

  3629.   #undef varobject_alignment
    3630. 

  3630.   #define varobject_alignment  4
    3631. 

  3631. #endif
    3632. 

  3632. #if ((defined(GENERATIONAL_GC) && defined(WIDE)) || defined(LINUX_NOEXEC_HEAPCODES)) && (varobject_alignment < 8)
    3633. 

  3633.   #undef varobject_alignment
    3634. 

  3634.   #define varobject_alignment  8
    3635. 

  3635. #endif
    3636. 

  3636. /* varobject_alignment should be defined: */
    3637. 

  3637. #ifndef varobject_alignment
    3638. 

  3638.   #error "varobject_alignment depends on CPU -- readjust varobject_alignment!!"
    3639. 

  3639. #endif
    3640. 

  3640. /* varobject_alignment should be a power of 2: */
    3641. 

  3641. #if !((varobject_alignment & (varobject_alignment-1)) ==0)
    3642. 

  3642.   #error "Bogus varobject_alignment -- readjust varobject_alignment!!"
    3643. 

  3643. #endif
    3644. 

  3644. /* varobject_alignment should be a multiple of 2^addr_shift : */
    3645. 

  3645. #if (varobject_alignment % bit(addr_shift))
    3646. 

  3646.   #error "Bogus varobject_alignment -- readjust varobject_alignment!!"
    3647. 

  3647. #endif
    3648. 

  3648. %% export_def(varobject_alignment);
    3649. 

  3649. 

  3650. 

  3651. #ifdef TYPECODES
    3652. 

  3652. 

  3653. /* Now we'll define the various type bits and type codes. */
    3654. 

  3654. 

  3655. /* Single-floats can be immediate objects, like short-floats, if there are
    3656. 

  3656.  enough bits in a 'gcv_object_t'. */
    3657. 

  3657. #if defined(WIDE_HARD) || defined(WIDE_SOFT)
    3658. 

  3658.   #define IMMEDIATE_FFLOAT
    3659. 

  3659. #endif
    3660. 

  3660. 

  3661. /* Determine whether a type isn't changed by the GC
    3662. 

  3662.  (ie. if it's not a pointer): */
    3663. 

  3663.   #if 0 && (defined(GNU) || defined(INTEL))
    3664. 

  3664.     #define gcinvariant_type_p(type)  \
    3665. 

  3665.       ({var bool _erg;                         \
    3666. 

  3666.         switch (type)                          \
    3667. 

  3667.           { case_machine:                      \
    3668. 

  3668.             case_char: case_subr: case_system: \
    3669. 

  3669.             case_fixnum: case_sfloat:          \
    3670. 

  3670.             /* with WIDE also: case_ffloat: */ \
    3671. 

  3671.               _erg = true; break;              \
    3672. 

  3672.             default: _erg = false; break;      \
    3673. 

  3673.           }                                    \
    3674. 

  3674.         _erg;                                  \
    3675. 

  3675.        })
    3676. 

  3676.   #endif
    3677. 

  3677. 

  3678. #ifndef tint_allowed_type_mask
    3679. 

  3679.   #define tint_allowed_type_mask  tint_type_mask
    3680. 

  3680. #endif
    3681. 

  3681. 

  3682. /* There are 7 to 8 type bits available: TB7, [TB6,] TB5, TB4, ..., TB0.
    3683. 

  3683.  All of them have to be set in tint_allowed_type_mask and thus in tint_type_mask as well
    3684. 

  3684.  We distribute them under the assumption that only one bit is missing in tint_type_mask.
    3685. 

  3685.  TB6 will be set to -1, if it can't be used. */
    3686. 

  3686. #if ((0xFF & ~tint_allowed_type_mask) == 0)
    3687. 

  3687.   #define TB7 7
    3688. 

  3688.   #define TB6 6
    3689. 

  3689.   #define TB5 5
    3690. 

  3690.   #define TB4 4
    3691. 

  3691.   #define TB3 3
    3692. 

  3692.   #define TB2 2
    3693. 

  3693.   #define TB1 1
    3694. 

  3694.   #define TB0 0
    3695. 

  3695. #elif (oint_type_len==7)
    3696. 

  3696.   #define TB7 6
    3697. 

  3697.   #define TB6 -1
    3698. 

  3698.   #define TB5 5
    3699. 

  3699.   #define TB4 4
    3700. 

  3700.   #define TB3 3
    3701. 

  3701.   #define TB2 2
    3702. 

  3702.   #define TB1 1
    3703. 

  3703.   #define TB0 0
    3704. 

  3704. #else
    3705. 

  3705.   /* Some bits have to be avoided */
    3706. 

  3706.   #define tint_avoid  ((bitm(oint_type_len)-1) & ~tint_allowed_type_mask)
    3707. 

  3707.   /* tint_avoid must only contain one bit: */
    3708. 

  3708.   #if (tint_avoid & (tint_avoid-1))
    3709. 

  3709.     #error "Bogus oint_type_mask -- oint_type_mask has more than one extraneous bit!!"
    3710. 

  3710.   #endif
    3711. 

  3711.   /* tint_avoid consists of exactly one bit that has to be avoided. */
    3712. 

  3712.   #if (tint_avoid > bit(0))
    3713. 

  3713.     #define TB0 0
    3714. 

  3714.   #else
    3715. 

  3715.     #define TB0 1
    3716. 

  3716.   #endif
    3717. 

  3717.   #if (tint_avoid > bit(1))
    3718. 

  3718.     #define TB1 1
    3719. 

  3719.   #else
    3720. 

  3720.     #define TB1 2
    3721. 

  3721.   #endif
    3722. 

  3722.   #if (tint_avoid > bit(2))
    3723. 

  3723.     #define TB2 2
    3724. 

  3724.   #else
    3725. 

  3725.     #define TB2 3
    3726. 

  3726.   #endif
    3727. 

  3727.   #if (tint_avoid > bit(3))
    3728. 

  3728.     #define TB3 3
    3729. 

  3729.   #else
    3730. 

  3730.     #define TB3 4
    3731. 

  3731.   #endif
    3732. 

  3732.   #if (tint_avoid > bit(4))
    3733. 

  3733.     #define TB4 4
    3734. 

  3734.   #else
    3735. 

  3735.     #define TB4 5
    3736. 

  3736.   #endif
    3737. 

  3737.   #if (tint_avoid > bit(5))
    3738. 

  3738.     #define TB5 5
    3739. 

  3739.   #else
    3740. 

  3740.     #define TB5 6
    3741. 

  3741.   #endif
    3742. 

  3742.   #if ((tint_allowed_type_mask & ~0xFF) == 0)
    3743. 

  3743.     #define TB6 -1
    3744. 

  3744.     #if (tint_avoid > bit(6))
    3745. 

  3745.       #define TB7 6
    3746. 

  3746.     #else
    3747. 

  3747.       #define TB7 7
    3748. 

  3748.     #endif
    3749. 

  3749.   #else
    3750. 

  3750.     #if (tint_avoid > bit(6))
    3751. 

  3751.       #define TB6 6
    3752. 

  3752.     #else
    3753. 

  3753.       #define TB6 7
    3754. 

  3754.     #endif
    3755. 

  3755.     #if (tint_avoid > bit(7))
    3756. 

  3756.       #define TB7 7
    3757. 

  3757.     #else
    3758. 

  3758.       #define TB7 8
    3759. 

  3759.     #endif
    3760. 

  3760.   #endif
    3761. 

  3761. #endif
    3762. 

  3762. 

  3763. /* bit masks for the type bits: */
    3764. 

  3764.   #define BTB0  bit(TB0)
    3765. 

  3765.   #define BTB1  bit(TB1)
    3766. 

  3766.   #define BTB2  bit(TB2)
    3767. 

  3767.   #define BTB3  bit(TB3)
    3768. 

  3768.   #define BTB4  bit(TB4)
    3769. 

  3769.   #define BTB5  bit(TB5)
    3770. 

  3770.   #define BTB6  bit(TB6)
    3771. 

  3771.   #define BTB7  bit(TB7)
    3772. 

  3772. 

  3773. #define STANDARD_8BIT_TYPECODES
    3774. 

  3774. 

  3775. #ifdef STANDARD_8BIT_TYPECODES
    3776. 

  3776. 

  3777. #if defined(I80386) && defined(UNIX_LINUX) && (CODE_ADDRESS_RANGE == 0)
    3778. 

  3778.   /* At 0x60000000 there are the shared-libraries.
    3779. 

  3779.    At 0x50000000 (Linux 1.2) resp. 0x40000000 (Linux 2.0) there are several
    3780. 

  3780.    mmap-pages,for example ones allocated  by setlocale() or gettext().
    3781. 

  3781.    Therefore we only have to do a few changes to the distribution of the type codes. */
    3782. 

  3782. #endif
    3783. 

  3783. 

  3784. #if defined(I80386) && defined(UNIX_LINUX) && (CODE_ADDRESS_RANGE != 0)
    3785. 

  3785.   /* Code and malloc memory is at 0x08000000.
    3786. 

  3786.    Therefore avoid allocating typecode 0x08 for the moment. */
    3787. 

  3787. #endif
    3788. 

  3788. 

  3789. #if (defined(MC680X0) || (defined(SPARC) && !defined(SUN4_29))) && defined(UNIX_LINUX)
    3790. 

  3790.   /* At 0x50000000 there are shared libraries located.
    3791. 

  3791.    But this doesn't mean we have to change the type code distribution. */
    3792. 

  3792. #endif
    3793. 

  3793. 

  3794. #if (defined(MIPS) || defined(POWERPC)) && defined(UNIX_LINUX)
    3795. 

  3795.   /* At 0x2AAAB000 there are shared libraries located.
    3796. 

  3796.    But this doesn't mean we have to change the type code distribution. */
    3797. 

  3797. #endif
    3798. 

  3798. 

  3799. #if defined(DECALPHA) && defined(UNIX_OSF) && !(defined(NO_SINGLEMAP) || defined(NO_TRIVIALMAP))
    3800. 

  3800. /* mmap() only works with addresses >=0, <2^38, but since ordinary pointers are in the range
    3801. 

  3801.  1*2^32..2*2^32, only the Bits 37..33 remain as type-bits. */
    3802. 

  3802. #endif
    3803. 

  3803. 

  3804. #if defined(SPARC64) && defined(UNIX_LINUX)
    3805. 

  3805.   /* At 0x70000000 there are shared libraries located.
    3806. 

  3806.    But this doesn't mean we have to change the type code distribution. */
    3807. 

  3807. #endif
    3808. 

  3808. 

  3809. /* Type bits:
    3810. 

  3810.  in Typcodes (tint): */
    3811. 

  3811.   #define garcol_bit_t     TB7  /* only set during GC */
    3812. 

  3812.   #if (TB6 >= 0)
    3813. 

  3813.     #define cons_bit_t     TB6  /* only set for CONS */
    3814. 

  3814.   #endif
    3815. 

  3815.   #define number_bit_t     TB5  /* only set for numbers */
    3816. 

  3816.   #define notsimple_bit_t  TB3  /* for arrays: deleted for simple arrays */
    3817. 

  3817.   #define sign_bit_t       TB0  /* Sign for real numbers (set <==> number <0) */
    3818. 

  3818.   #define float_bit_t      TB1
    3819. 

  3819.   #define float1_bit_t     TB3
    3820. 

  3820.   #define float2_bit_t     TB2
    3821. 

  3821.   #define ratio_bit_t      TB3
    3822. 

  3822.   #define bignum_bit_t     TB2
    3823. 

  3823. /* in Objects (oint): */
    3824. 

  3824.   #define garcol_bit_o     (garcol_bit_t+oint_type_shift)    /* only set during the garbage collection! */
    3825. 

  3825.   #if (TB6 >= 0)
    3826. 

  3826.     #define cons_bit_o     (cons_bit_t+oint_type_shift)      /* only set for cons CONS */
    3827. 

  3827.   #endif
    3828. 

  3828.   #define number_bit_o     (number_bit_t+oint_type_shift)    /* only set for numbers */
    3829. 

  3829.   #define notsimple_bit_o  (notsimple_bit_t+oint_type_shift) /* for arrays: deleted for simple arrays */
    3830. 

  3830.   #define sign_bit_o       (sign_bit_t+oint_type_shift)      /* Sign for real numbers */
    3831. 

  3831.   #define float_bit_o      (float_bit_t+oint_type_shift)
    3832. 

  3832.   #define float1_bit_o     (float1_bit_t+oint_type_shift)
    3833. 

  3833.   #define float2_bit_o     (float2_bit_t+oint_type_shift)
    3834. 

  3834.   #define ratio_bit_o      (ratio_bit_t+oint_type_shift)
    3835. 

  3835.   #define bignum_bit_o     (bignum_bit_t+oint_type_shift)
    3836. 

  3836. 

  3837. /* constant type codes: */
    3838. 

  3838.   #define machine_type    (0)                                  /* 0x00  # %00000000  ; machine pointer */
    3839. 

  3839.   #define subr_type       (                              BTB0) /* 0x01  # %00000001  ; SUBR */
    3840. 

  3840.   #define char_type       (                         BTB1     ) /* 0x02  # %00000010  ; character */
    3841. 

  3841.   #define system_type     (                         BTB1|BTB0) /* 0x03  # %00000011  ; frame-pointer, small-read-label, system */
    3842. 

  3842.   #define symbol_type     (                    BTB2          ) /* 0x04  # %000001xx  ; symbol */
    3843. 

  3843.           /* bits for symbols in the GCself pointer: */
    3844. 

  3844.           #define var_bit0_t  TB0  /* set if the symbol is proclaimed SPECIAL or constant */
    3845. 

  3845.           #define var_bit1_t  TB1  /* set if the symbol is a symbol-macro or constant */
    3846. 

  3846.   #if (TB6 < 0)
    3847. 

  3847.   #define cons_type       (               BTB3               ) /* 0x08  # %00001000  ; cons */
    3848. 

  3848.   #endif
    3849. 

  3849.   #define closure_type    (               BTB3          |BTB0) /* 0x09  # %00001001  ; closure */
    3850. 

  3850.   #define structure_type  (               BTB3     |BTB1     ) /* 0x0A  # %00001010  ; structure */
    3851. 

  3851.   #define stream_type     (               BTB3     |BTB1|BTB0) /* 0x0B  # %00001011  ; stream */
    3852. 

  3852.   #define orecord_type    (               BTB3|BTB2          ) /* 0x0C  # %00001100  ; OtherRecord (Package, Byte, ...) */
    3853. 

  3853.   #define instance_type   (               BTB3|BTB2     |BTB0) /* 0x0D  # %00001101  ; CLOS instance */
    3854. 

  3854.   #define lrecord_type    (               BTB3|BTB2|BTB1     ) /* 0x0E  # %00001110  ; LongRecord (WeakList, WeakAlist, ...) */
    3855. 

  3855.   #define mdarray_type    (               BTB3|BTB2|BTB1|BTB0) /* 0x0F  # %00001111  ; other array (rank/=1 or other eltype) */
    3856. 

  3856.   #define sbvector_type   (          BTB4                    ) /* 0x10  # %00010000  ; simple-bit-vector */
    3857. 

  3857.   #define sb2vector_type  (          BTB4               |BTB0) /* 0x11  # %00010001  ; simple (VECTOR (UNSIGNED-BYTE 2)) */
    3858. 

  3858.   #define sb4vector_type  (          BTB4          |BTB1     ) /* 0x12  # %00010010  ; simple (VECTOR (UNSIGNED-BYTE 4)) */
    3859. 

  3859.   #define sb8vector_type  (          BTB4          |BTB1|BTB0) /* 0x13  # %00010011  ; simple (VECTOR (UNSIGNED-BYTE 8)) */
    3860. 

  3860.   #define sb16vector_type (          BTB4     |BTB2          ) /* 0x14  # %00010100  ; simple (VECTOR (UNSIGNED-BYTE 16)) */
    3861. 

  3861.   #define sb32vector_type (          BTB4     |BTB2     |BTB0) /* 0x15  # %00010101  ; simple (VECTOR (UNSIGNED-BYTE 32)) */
    3862. 

  3862.   #define sstring_type    (          BTB4     |BTB2|BTB1     ) /* 0x16  # %00010110  ; simple-string */
    3863. 

  3863.   #define svector_type    (          BTB4     |BTB2|BTB1|BTB0) /* 0x17  # %00010111  ; simple-vector */
    3864. 

  3864.   #define bvector_type    (          BTB4|BTB3               ) /* 0x18  # %00011000  ; non-simple bit-vector */
    3865. 

  3865.   #define b2vector_type   (          BTB4|BTB3          |BTB0) /* 0x19  # %00011001  ; non-simple (VECTOR (UNSIGNED-BYTE 2)) */
    3866. 

  3866.   #define b4vector_type   (          BTB4|BTB3     |BTB1     ) /* 0x1A  # %00011010  ; non-simple (VECTOR (UNSIGNED-BYTE 4)) */
    3867. 

  3867.   #define b8vector_type   (          BTB4|BTB3     |BTB1|BTB0) /* 0x1B  # %00011011  ; non-simple (VECTOR (UNSIGNED-BYTE 8)) */
    3868. 

  3868.   #define b16vector_type  (          BTB4|BTB3|BTB2          ) /* 0x1C  # %00011100  ; non-simple (VECTOR (UNSIGNED-BYTE 16)) */
    3869. 

  3869.   #define b32vector_type  (          BTB4|BTB3|BTB2     |BTB0) /* 0x1D  # %00011101  ; non-simple (VECTOR (UNSIGNED-BYTE 32)) */
    3870. 

  3870.   #define string_type     (          BTB4|BTB3|BTB2|BTB1     ) /* 0x1E  # %00011110  ; non-simple string */
    3871. 

  3871.   #define vector_type     (          BTB4|BTB3|BTB2|BTB1|BTB0) /* 0x1F  # %00011111  ; non-simple (VECTOR T) */
    3872. 

  3872.   #define fixnum_type     (     BTB5                         ) /* 0x20  # %00100000  ; fixnum */
    3873. 

  3873.   #define sfloat_type     (     BTB5               |BTB1     ) /* 0x22  # %00100010  ; short-float */
    3874. 

  3874.   #define bignum_type     (     BTB5          |BTB2          ) /* 0x24  # %00100100  ; bignum */
    3875. 

  3875.   #define ffloat_type     (     BTB5          |BTB2|BTB1     ) /* 0x26  # %00100110  ; single-float */
    3876. 

  3876.   #define ratio_type      (     BTB5     |BTB3               ) /* 0x28  # %00101000  ; ratio */
    3877. 

  3877.   #define dfloat_type     (     BTB5     |BTB3     |BTB1     ) /* 0x2A  # %00101010  ; double-float */
    3878. 

  3878.   #define complex_type    (     BTB5     |BTB3|BTB2          ) /* 0x2C  # %00101100  ; complex */
    3879. 

  3879.   #define lfloat_type     (     BTB5     |BTB3|BTB2|BTB1     ) /* 0x2E  # %00101110  ; long-float */
    3880. 

  3880.   #if (TB6 >= 0)
    3881. 

  3881.   #define cons_type       (BTB6                              ) /* 0x40  # %01000000  ; cons */
    3882. 

  3882.   #endif
    3883. 

  3883. 

  3884. /* Bits for symbols in VAR/FUN-Frames (in LISP-Stack):
    3885. 

  3885.  aren't in the oint_type-part, but in the oint_addr-part. */
    3886. 

  3886.   #define active_bit  0  /* set: binding is active */
    3887. 

  3887.   #define dynam_bit   1  /* set: binding is dynamic */
    3888. 

  3888.   #define svar_bit    2  /* set: next parameter is supplied-p-parameter for this */
    3889. 

  3889. #if (varobject_alignment >= bit(3))
    3890. 

  3890.   #define oint_symbolflags_shift  oint_addr_shift
    3891. 

  3891. #else
    3892. 

  3892.   #define NO_symbolflags /* there's no space in the symbol for active_bit, dynam_bit, svar_bit */
    3893. 

  3893. #endif
    3894. 

  3894. 

  3895. #ifndef IMMEDIATE_FFLOAT
    3896. 

  3896.   /* type is GC-invariant, if
    3897. 

  3897.    type-info-byte >=0, <= system_type or >= fixnum_type, < bignum_type. */
    3898. 

  3898.     #define gcinvariant_type_p(type)  \
    3899. 

  3899.       (((type) & ~(BTB5|BTB1|BTB0)) == 0)
    3900. 

  3900. #else
    3901. 

  3901.   /* type is GC-invariant, if
    3902. 

  3902.    type-info-byte is one of 0x00..0x03,0x20..0x23,0x26..0x27 ist. */
    3903. 

  3903.   #if (TB1==TB0+1) && (TB2==TB0+2) && (TB3==TB0+3) && (TB4==TB0+4) && (TB5==TB0+5)
    3904. 

  3904.     #define gcinvariant_type_p(type)  \
    3905. 

  3905.       ((((type)>>(TB0+1))<0x14) && ((bit((type)>>(TB0+1)) & 0xFFF4FFFCUL) == 0))
    3906. 

  3906.   #else
    3907. 

  3907.     /* Test whether ((type)>>TB1) is one of
    3908. 

  3908.        0, 1, bit(TB5-TB1), bit(TB5-TB1) | 1, bit(TB5-TB1) | bit(TB2-TB1) | 1. */
    3909. 

  3909.     #define gcinvariant_type_p(type)  gcinvariant_type_aux((type)>>TB1)
    3910. 

  3910.     #define gcinvariant_type_sum(type)  \
    3911. 

  3911.       (((type) | ((type)>>(TB5-(TB2+1)))) & (((BTB2<<1)+BTB2+BTB1)>>TB1))
    3912. 

  3912.     #define gcinvariant_type_aux(type)                         \
    3913. 

  3913.       (((type) < ((BTB5+(BTB2<<1))>>TB1))                      \
    3914. 

  3914.        && ((type) & ~((BTB5|BTB2|BTB1)>>TB1)) == 0             \
    3915. 

  3915.        && (bit(gcinvariant_type_sum(type))                     \
    3916. 

  3916.            & (  bit(0)                                         \
    3917. 

  3917.               | bit(1)                                         \
    3918. 

  3918.               | bit(bit(TB2+1-TB1))                            \
    3919. 

  3919.               | bit(bit(TB2+1-TB1) | 1)                        \
    3920. 

  3920.               | bit(bit(TB2+1-TB1) | bit(TB2-TB1) | 1))) != 0)
    3921. 

  3921.   #endif
    3922. 

  3922. #endif
    3923. 

  3923. 

  3924. #endif /* STANDARD_8BIT_TYPECODES */
    3925. 

  3925. 

  3926. #if !(gcinvariant_type_p(ffloat_type) == defined(IMMEDIATE_FFLOAT))
    3927. 

  3927.   #error "gcinvariant_type_p() incorrectly implemented!"
    3928. 

  3928. #endif
    3929. 

  3929. 

  3930. /* Test for gc-invariant object. (This includes immediate, machine, subr.)
    3931. 

  3931.  gcinvariant_object_p(obj) */
    3932. 

  3932.   #define gcinvariant_object_p(obj)  \
    3933. 

  3933.     gcinvariant_type_p(typecode(obj))
    3934. 

  3934.   #define gcinvariant_oint_p(obj_o)  \
    3935. 

  3935.     gcinvariant_type_p((tint)((obj_o) >> oint_type_shift) & (oint_type_mask >> oint_type_shift))
    3936. 

  3936. 

  3937. #else /* no TYPECODES */
    3938. 

  3938. 

  3939. /* Bits for symbols in VAR/FUN-Frames (on LISP-Stack):
    3940. 

  3940.  are not located in the oint_type-part, but in the oint_data-part. */
    3941. 

  3941.   #define active_bit  0  /* set: binding is active */
    3942. 

  3942.   #define dynam_bit   1  /* set: binding is dynamic */
    3943. 

  3943.   #define svar_bit    2  /* set: next parameter is supplied-p-parameter for this one */
    3944. 

  3944. #define NO_symbolflags /* there's no space in the symbol for active_bit, dynam_bit, svar_bit */
    3945. 

  3945. 

  3946. /* Bits for symbols in the flags: */
    3947. 

  3947.   #define var_bit0_f  0  /* set if the symbol is proclaimed SPECIAL or constant */
    3948. 

  3948.   #define var_bit1_f  1  /* set if the symbol is a symbol-macro or constant */
    3949. 

  3949. 

  3950. #endif /* TYPECODES */
    3951. 

  3951. %% #ifdef TYPECODES
    3952. 

  3952. %%  export_def(gcinvariant_type_p(type));
    3953. 

  3953. %%  export_def(gcinvariant_type_sum(type));
    3954. 

  3954. %%  export_def(gcinvariant_type_aux(type));
    3955. 

  3955. %%  export_def(gcinvariant_object_p(obj));
    3956. 

  3956. %%  export_def(gcinvariant_oint_p(obj_o));
    3957. 

  3957. %% #endif
    3958. 

  3958. 

  3959. 

  3960. /* What's really being sent from an address to the address-bus */
    3961. 

  3961. #if defined(MC68000)
    3962. 

  3962.   #define hardware_  0x00FFFFFFUL  /* 68000 drops 8 */
    3963. 

  3963. #elif defined(SUN3) && !defined(UNIX_SUNOS4)
    3964. 

  3964.   #define hardware_addressbus_mask  0x0FFFFFFFUL  /* SUN3 unter SunOS 3.5 wirft 4 Bits weg */
    3965. 

  3965. #else
    3966. 

  3966.   #define hardware_addressbus_mask  ~0UL  /* Default: nothing is dropped */
    3967. 

  3967. #endif
    3968. 

  3968. /* Clever memory-mapping spares us from masking out of certain
    3969. 

  3969.  bits before one accesses the address */
    3970. 

  3970. #define addressbus_mask  hardware_addressbus_mask
    3971. 

  3971. #ifdef MAP_MEMORY
    3972. 

  3972.   #if defined(SUN4_29)
    3973. 

  3973.     /* Memory-mapping makes the bits 28..24 of an address redundant now. */
    3974. 

  3974.     #undef addressbus_mask
    3975. 

  3975.     #define addressbus_mask  0xE0FFFFFFUL
    3976. 

  3976.   #elif defined(DECALPHA) && defined(UNIX_OSF)
    3977. 

  3977.     /* Memory-mapping makes the bits 39..33 of an address redundant now. */
    3978. 

  3978.     #undef addressbus_mask
    3979. 

  3979.     #define addressbus_mask  0xFFFFFF01FFFFFFFFUL
    3980. 

  3980.   #elif !defined(WIDE_SOFT)
    3981. 

  3981.     /* Memory-mapping makes the bits 31..24 of an address redundant now. */
    3982. 

  3982.     #undef addressbus_mask
    3983. 

  3983.     #define addressbus_mask  oint_addr_mask  /* most of the time it's = 0x00FFFFFFUL */
    3984. 

  3984.   #endif
    3985. 

  3985. #endif
    3986. 

  3986. %% #if notused
    3987. 

  3987. %% export_def(addressbus_mask);
    3988. 

  3988. %% #endif
    3989. 

  3989. 

  3990. 

  3991. #ifdef TYPECODES
    3992. 

  3992. 

  3993. /* You have to remove the typebits in order to access the components
    3994. 

  3994.  of an object.
    3995. 

  3995.  pointable(obj) does this, returning a void*.
    3996. 

  3996.  pointable_unchecked(obj) likewise, but without the DEBUG_GCSAFETY check.
    3997. 

  3997.  pointable_address_unchecked(obj_o) likewise, but takes an oint as argument
    3998. 

  3998.                                     and returns an aint. */
    3999. 

  3999.   #if !((oint_addr_shift==0) && (addr_shift==0))
    4000. 

  4000.     #define pointable_unchecked(obj)  ((void*)upointer(obj))
    4001. 

  4001.     #define pointable_address_unchecked(obj_o)  \
    4002. 

  4002.       (((aint)((obj_o) >> oint_addr_shift) & (aint)(oint_addr_mask >> oint_addr_shift)) << addr_shift)
    4003. 

  4003.   #else
    4004. 

  4004.     #define pointable_unchecked(obj)  \
    4005. 

  4005.       ((void*)pointable_address_unchecked(as_oint(obj)))
    4006. 

  4006.     /* If oint_addr_shift=0 and addr_shift=0, you don't have to shift. */
    4007. 

  4007.     #if !((tint_type_mask & (addressbus_mask>>oint_type_shift)) == 0)
    4008. 

  4008.       #define pointable_address_unchecked(obj_o)  \
    4009. 

  4009.         ((aint)(obj_o) & ((aint)oint_addr_mask | ~addressbus_mask))
    4010. 

  4010.     #else
    4011. 

  4011.       /* Moreover if oint_type_mask and addressbus_mask are disjoint
    4012. 

  4012.        (((tint_type_mask<<oint_type_shift) & addressbus_mask) == 0),
    4013. 

  4013.        no typebits are being sent to the address bus anyway.
    4014. 

  4014.        So there's nothing to be done: */
    4015. 

  4015.       #define pointable_address_unchecked(obj_o)  (aint)(obj_o)
    4016. 

  4016.     #endif
    4017. 

  4017.   #endif
    4018. 

  4018.   #ifdef DEBUG_GCSAFETY
    4019. 

  4019.     /* Check that obj has not been held in a GC-unsafe variable while a
    4020. 

  4020.      memory allocation was made. */
    4021. 

  4021.     static inline void* pointable (gcv_object_t obj) {
    4022. 

  4022.       return pointable_unchecked(obj);
    4023. 

  4023.     }
    4024. 

  4024.     static inline void* pointable (object obj) {
    4025. 

  4025.       return pointable_unchecked((gcv_object_t)obj); /* The cast does the check. */
    4026. 

  4026.     }
    4027. 

  4027.   #else
    4028. 

  4028.     #define pointable(obj)  pointable_unchecked(obj)
    4029. 

  4029.   #endif
    4030. 

  4030. 

  4031. /* If you want to access an object with a known type-info whose
    4032. 

  4032.  set typebits are being swallowed by the address bus (the
    4033. 

  4033.  typebits, that are =0 don't matter), you can do without 'untype': */
    4034. 

  4034.   #if defined(DEBUG_GCSAFETY)
    4035. 

  4035.     #define type_pointable(type,obj)  pointable(obj)
    4036. 

  4036.   #elif defined(WIDE_STRUCT)
    4037. 

  4037.     #define type_pointable(type,obj)  ((void*)((obj).u.both.addr))
    4038. 

  4038.   #elif !((oint_addr_shift==0) && (addr_shift==0) && (((tint_type_mask<<oint_type_shift) & addressbus_mask) == 0))
    4039. 

  4039.     #if (addr_shift==0)
    4040. 

  4040.       #define type_pointable(type,obj)  \
    4041. 

  4041.         ((oint_addr_shift==0) && ((type_zero_oint(type) & addressbus_mask) == 0) \
    4042. 

  4042.          ? (void*)(aint)as_oint(obj)                                             \
    4043. 

  4043.          : (void*)(aint)pointable(obj)                                           \
    4044. 

  4044.         )
    4045. 

  4045.     #elif !(addr_shift==0)
    4046. 

  4046.       /* Analogous, but here the macro 'optimized_upointer'
    4047. 

  4047.        assumes the role of the address bus: */
    4048. 

  4048.       #define type_pointable(type,obj)  \
    4049. 

  4049.         ((optimized_upointer(type_data_object(type,0)) == 0) \
    4050. 

  4050.          ? (void*)(aint)optimized_upointer(obj)              \
    4051. 

  4051.          : (void*)(aint)pointable(obj)                       \
    4052. 

  4052.         )
    4053. 

  4053.     #endif
    4054. 

  4054.   #else
    4055. 

  4055.     /* If pointable(obj) = obj, type_pointable() doesn't do anything as well: */
    4056. 

  4056.     #define type_pointable(type,obj)  ((void*)(aint)as_oint(obj))
    4057. 

  4057.   #endif
    4058. 

  4058. 

  4059. /* If you want to access an object that has one of several known
    4060. 

  4060.  type infos, you can probably omit the 'untype'.
    4061. 

  4061.  The  OR of the type infos is more authoritative. */
    4062. 

  4062.   #define types_pointable(ORed_types,obj)  type_pointable(ORed_types,obj)
    4063. 

  4063. 

  4064. #else /* HEAPCODES */
    4065. 

  4065. 

  4066.   #define pointable_address_unchecked(obj_o)  \
    4067. 

  4067.     (((aint)((obj_o) >> oint_addr_shift) & (aint)(oint_addr_mask >> oint_addr_shift)) << addr_shift)
    4068. 

  4068. 

  4069. #endif
    4070. 

  4070. %% #ifdef TYPECODES
    4071. 

  4071. %%  export_def(pointable_unchecked(obj));
    4072. 

  4072. %%  export_def(pointable_address_unchecked(obj_o));
    4073. 

  4073. %%  #ifdef DEBUG_GCSAFETY
    4074. 

  4074. %%   puts("static inline void* pointable (gcv_object_t obj) { return pointable_unchecked(obj); }");
    4075. 

  4075. %%   puts("static inline void* pointable (object obj) { return pointable_unchecked((gcv_object_t)obj); }");
    4076. 

  4076. %%  #else
    4077. 

  4077. %%   emit_define("pointable(obj)","pointable_unchecked(obj)");
    4078. 

  4078. %%  #endif
    4079. 

  4079. %% #endif
    4080. 

  4080. 

  4081. 

  4082. #if defined(SINGLEMAP_MEMORY) && (((system_type*1UL << oint_type_shift) & addressbus_mask) == 0)
    4083. 

  4083.   /* The STACK resides in a singlemap-area as well, Typinfo system_type. */
    4084. 

  4084.   #define SINGLEMAP_MEMORY_STACK
    4085. 

  4085. #endif
    4086. 

  4086. 

  4087. 

  4088. #ifdef oint_symbolflags_shift
    4089. 

  4089.   #if defined(SINGLEMAP_MEMORY) && (oint_symbolflags_shift==oint_type_shift)
    4090. 

  4090.     /* Since we can't multimap the symbol_tab, we can't use extrabits in
    4091. 

  4091.      a symbol's typecode. */
    4092. 

  4092.     #undef oint_symbolflags_shift
    4093. 

  4093.     #define NO_symbolflags
    4094. 

  4094.   #endif
    4095. 

  4095. #endif
    4096. 

  4096. #ifdef NO_symbolflags
    4097. 

  4097.   #define oint_symbolflags_shift  -1 /* invalid value */
    4098. 

  4098. #endif
    4099. 

  4099. 

  4100. 

  4101. /* Whether we try to initialize subr_tab statically.
    4102. 

  4102.  (g++ 3.3 doesn't accept compound expressions as initializers: PR#12615.
    4103. 

  4103.  g++ 3.4 similarly: PR#15180.) */
    4104. 

  4104. #if !(defined(WIDE_SOFT) && !defined(WIDE_STRUCT)) && !(defined(__GNUG__) && (__GNUC__ == 3) && (__GNUC_MINOR__ == 3 || __GNUC_MINOR__ == 4) && defined(OBJECT_STRUCT))
    4105. 

  4105.   #define INIT_SUBR_TAB
    4106. 

  4106. #endif
    4107. 

  4107. /* NB: This has to be defined so external modules can work.
    4108. 

  4108.  When changed: do nothing */
    4109. 

  4109. 

  4110. /* Whether we try to initialize symbol_tab statically.
    4111. 

  4111.  (Make initialization easier, but there is not enough space for the
    4112. 

  4112.  compilation of SPVWTABS on some systems.
    4113. 

  4113.  EMX 0.9c (gcc-2.7.2.1) says "Virtual memory exhausted".
    4114. 

  4114.  g++ 3.3 doesn't accept compound expressions as initializers: PR#12615.
    4115. 

  4115.  g++ 3.4 similarly: PR#15180.) */
    4116. 

  4116. #if !(defined(WIDE_SOFT) && !defined(WIDE_STRUCT)) && !(defined(__GNUG__) && (__GNUC__ == 3) && (__GNUC_MINOR__ == 3 || __GNUC_MINOR__ == 4) && defined(OBJECT_STRUCT))
    4117. 

  4117.   #define INIT_SYMBOL_TAB
    4118. 

  4118. #endif
    4119. 

  4119. /* When changed: nothing to do */
    4120. 

  4120. 

  4121. /* Whether we try to initialize object_tab statically.
    4122. 

  4122.  (g++ 3.3 doesn't accept compound expressions as initializers: PR#12615.
    4123. 

  4123.  g++ 3.4 similarly: PR#15180.) */
    4124. 

  4124. #if !(defined(WIDE_SOFT) && !defined(WIDE_STRUCT)) && !(defined(__GNUG__) && (__GNUC__ == 3) && (__GNUC_MINOR__ == 3 || __GNUC_MINOR__ == 4) && defined(OBJECT_STRUCT))
    4125. 

  4125.   #define INIT_OBJECT_TAB
    4126. 

  4126. #endif
    4127. 

  4127. /* When changed: do nothing */
    4128. 

  4128. 

  4129. 

  4130. /* Set during the core of GC.
    4131. 

  4131.  When this is set, unexpected handle_fault() calls that can
    4132. 

  4132.  - if defined(MORRIS_GC) && defined(GENERATIONAL_GC) - copy
    4133. 

  4133.  Morris-chain backpointers from a cons cell to an old_new_pointer_t with set
    4134. 

  4134.  garcol_bit(!) into the heap, where they are guaranteed to lead to a crash
    4135. 

  4135.  later. So, uncontrolled memory accesses are forbidden while inside_gc. */
    4136. 

  4136. extern bool inside_gc;
    4137. 

  4137. %% puts("extern bool inside_gc;");
    4138. 

  4138. 

  4139. 

  4140. #ifdef DEBUG_GCSAFETY
    4141. 

  4141. 

  4142.   /* Forward declarations. */
    4143. 

  4143.   static inline bool gcinvariant_symbol_p (object obj);
    4144. 

  4144.   #ifdef LINUX_NOEXEC_HEAPCODES
    4145. 

  4145.   static inline bool nonimmsubrp (object obj);
    4146. 

  4146.   #else
    4147. 

  4147.   #define nonimmsubrp(obj)  false
    4148. 

  4148.   #endif
    4149. 

  4149. 

  4150.   /* Force a crash if a memory pointer points to nonexistent memory. */
    4151. 

  4151.   #define nonimmprobe(obj_o)  \
    4152. 

  4152.     do {                                                                       \
    4153. 

  4153.       /* Don't do probes inside GC. It leads to unexpected handle_fault()      \
    4154. 

  4154.          calls that can - if defined(MORRIS_GC) && defined(GENERATIONAL_GC) -  \
    4155. 

  4155.          copy Morris-chain backpointers from a cons cell to an old_new_pointer_t \
    4156. 

  4156.          with set garcol_bit(!) into the heap, where they are guaranteed to    \
    4157. 

  4157.          lead to a crash later. */                                             \
    4158. 

  4158.       if (!inside_gc)                                                          \
    4159. 

  4159.         if (((obj_o) & wbit(garcol_bit_o)) == 0) /* exclude frame words from the STACK */ \
    4160. 

  4160.           if (!gcinvariant_oint_p(obj_o)) /* exclude immediate objects */      \
    4161. 

  4161.             /* Access a single char, without needing to subtract the bias. */  \
    4162. 

  4162.             *(volatile char *)pointable_address_unchecked(obj_o);              \
    4163. 

  4163.     } while (0)
    4164. 

  4164. 

  4165.   /* When a gcv_object_t is fetched from a GC visible location (in the heap or
    4166. 

  4166.    on the STACK) we can assume that GC has updated it. */
    4167. 

  4167.   inline gcv_object_t::operator object () const {
    4168. 

  4168.     nonimmprobe(one_o);
    4169. 

  4169.     return (object){ one_o: one_o INIT_ALLOCSTAMP };
    4170. 

  4170.   }
    4171. 

  4171. 

  4172.   /* When an object is put into a GC visible location (in the heap or
    4173. 

  4173.    on the STACK) we check that it has not been held in a GC-unsafe variable
    4174. 

  4174.    while a memory allocation was made. */
    4175. 

  4175.   inline gcv_object_t::gcv_object_t (object obj) {
    4176. 

  4176.     if (!(gcinvariant_object_p(obj) || gcinvariant_symbol_p(obj)
    4177. 

  4177.           || obj.allocstamp == alloccount || nonimmsubrp(obj)))
    4178. 

  4178.       abort();
    4179. 

  4179.     one_o = as_oint(obj);
    4180. 

  4180.     nonimmprobe(one_o);
    4181. 

  4181.   }
    4182. 

  4182.   /* The only exception are fake gcv_objects. */
    4183. 

  4183.   inline gcv_object_t::gcv_object_t (fake_gcv_object obj) {
    4184. 

  4184.     one_o = obj.fake_value;
    4185. 

  4185.   }
    4186. 

  4186. 

  4187.   /* Uninitialized. */
    4188. 

  4188.   inline gcv_object_t::gcv_object_t () {
    4189. 

  4189.   }
    4190. 

  4190. 

  4191.   /* Start of an area where no GC can be triggered. */
    4192. 

  4192.   inline gcunsafe_object_t::gcunsafe_object_t (object obj)
    4193. 

  4193.     : gcv_object_t (obj), allocstamp (alloccount) {}
    4194. 

  4194.   inline gcunsafe_object_t::gcunsafe_object_t (gcv_object_t obj)
    4195. 

  4195.     : gcv_object_t (obj), allocstamp (alloccount) {}
    4196. 

  4196.   /* End of an area where no GC can be triggered. */
    4197. 

  4197.   inline gcunsafe_object_t::~gcunsafe_object_t () {
    4198. 

  4198.     if (!(allocstamp == alloccount))
    4199. 

  4199.       abort();
    4200. 

  4200.   }
    4201. 

  4201. 

  4202. #endif
    4203. 

  4203. %% #ifdef DEBUG_GCSAFETY
    4204. 

  4204. %%   puts("static inline bool gcinvariant_symbol_p (object obj);");
    4205. 

  4205. %%   #ifdef LINUX_NOEXEC_HEAPCODES
    4206. 

  4206. %%     puts("static inline bool nonimmsubrp (object obj);");
    4207. 

  4207. %%   #else
    4208. 

  4208. %%     emit_define("nonimmsubrp(obj)","false");
    4209. 

  4209. %%   #endif
    4210. 

  4210. %%   export_def(nonimmprobe(obj_o));
    4211. 

  4211. %%   puts("inline gcv_object_t::operator object () const { nonimmprobe(one_o); return (object){ one_o: one_o, allocstamp: alloccount }; }");
    4212. 

  4212. %%   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); }");
    4213. 

  4213. %%   puts("inline gcv_object_t::gcv_object_t () {}");
    4214. 

  4214. %% #endif
    4215. 

  4215. 

  4216. 

  4217. /* Force a memory allocation for all functions which can trigger GC but
    4218. 

  4218.    sometimes do and sometimes don't. This makes DEBUG_GCSAFETY more efficient.
    4219. 

  4219.    GCTRIGGER()             does a no-op memory allocation
    4220. 

  4220.    GCTRIGGER1(obj1)        likewise, but saves obj1 temporarily
    4221. 

  4221.    GCTRIGGER2(obj1,obj2)   likewise, but saves obj1, obj2 temporarily
    4222. 

  4222.    ...
    4223. 

  4223.    GCTRIGGER_IF(condition, statement)
    4224. 

  4224.                            likewise, but only if the condition is fulfilled */
    4225. 

  4225. #ifdef DEBUG_GCSAFETY
    4226. 

  4226.   /* When these macros are used in C macros, obj1, obj2 etc. can sometimes be
    4227. 

  4227.    expressions of type 'object' and sometimes of type 'gcv_object_t'. Need
    4228. 

  4228.    two implementations of inc_allocstamp. */
    4229. 

  4229.   inline void inc_allocstamp (object& obj) { obj.allocstamp++; }
    4230. 

  4230.   inline void inc_allocstamp (gcv_object_t& obj) { }
    4231. 

  4231.   #define GCTRIGGER()  \
    4232. 

  4232.     (void)(alloccount++)
    4233. 

  4233.   #define GCTRIGGER1(obj1)  \
    4234. 

  4234.     (void)(inc_allocstamp(obj1), alloccount++)
    4235. 

  4235.   #define GCTRIGGER2(obj1,obj2)  \
    4236. 

  4236.     (void)(inc_allocstamp(obj1), inc_allocstamp(obj2), alloccount++)
    4237. 

  4237.   #define GCTRIGGER3(obj1,obj2,obj3)  \
    4238. 

  4238.     (void)(inc_allocstamp(obj1), inc_allocstamp(obj2), inc_allocstamp(obj3), alloccount++)
    4239. 

  4239.   #define GCTRIGGER4(obj1,obj2,obj3,obj4)  \
    4240. 

  4240.     (void)(inc_allocstamp(obj1), inc_allocstamp(obj2), inc_allocstamp(obj3), inc_allocstamp(obj4), alloccount++)
    4241. 

  4241.   #define GCTRIGGER5(obj1,obj2,obj3,obj4,obj5)  \
    4242. 

  4242.     (void)(inc_allocstamp(obj1), inc_allocstamp(obj2), inc_allocstamp(obj3), inc_allocstamp(obj4), inc_allocstamp(obj5), alloccount++)
    4243. 

  4243.   #define GCTRIGGER6(obj1,obj2,obj3,obj4,obj5,obj6)  \
    4244. 

  4244.     (void)(inc_allocstamp(obj1), inc_allocstamp(obj2), inc_allocstamp(obj3), inc_allocstamp(obj4), inc_allocstamp(obj5), inc_allocstamp(obj6), alloccount++)
    4245. 

  4245.   #define GCTRIGGER_IF(condition,statement)  \
    4246. 

  4246.     if (condition) statement
    4247. 

  4247. #else
    4248. 

  4248.   #define GCTRIGGER()  (void)0
    4249. 

  4249.   #define GCTRIGGER1(obj1)  (void)0
    4250. 

  4250.   #define GCTRIGGER2(obj1,obj2)  (void)0
    4251. 

  4251.   #define GCTRIGGER3(obj1,obj2,obj3)  (void)0
    4252. 

  4252.   #define GCTRIGGER4(obj1,obj2,obj3,obj4)  (void)0
    4253. 

  4253.   #define GCTRIGGER5(obj1,obj2,obj3,obj4,obj5)  (void)0
    4254. 

  4254.   #define GCTRIGGER6(obj1,obj2,obj3,obj4,obj5,obj6)  (void)0
    4255. 

  4255.   #define GCTRIGGER_IF(condition,statement)  (void)0
    4256. 

  4256. #endif
    4257. 

  4257. 

  4258. 

  4259. /* ################### Methods for memory management #####################
    4260. 

    4261. 

  4261.  SPVW_BLOCKS : Memory management with few memory blocks
    4262. 

  4262.  SPVW_PAGES  : Memory management with many memory blocks
    4263. 

  4263.  SPVW_MIXED  : Objects of mixed types are possible on the same page or block
    4264. 

  4264.  SPVW_PURE   : Every memory block/every memory page contains only objects
    4265. 

  4265.                of exactly one type */
    4266. 

  4266. #if defined(MAP_MEMORY) || defined(TRIVIALMAP_MEMORY)
    4267. 

  4267.   /* Multimapping of single pages isn't implemented yet.??
    4268. 

  4268.    Singlemapping of single pages isn't implemented yet.??
    4269. 

  4269.    If you use mmap() as malloc()-replacement, single pages aren't needed. */
    4270. 

  4270.   #define SPVW_BLOCKS
    4271. 

  4271. #elif defined(VIRTUAL_MEMORY)
    4272. 

  4272.   /* On Unix-systems you can still fetch more memory afterwards,
    4273. 

  4273.    but you should concentrate the data - if possible - on few pages. */
    4274. 

  4274.   #define SPVW_PAGES
    4275. 

  4275. #else
    4276. 

  4276.   #define SPVW_BLOCKS
    4277. 

  4277. #endif
    4278. 

  4278. #if defined(MULTIMAP_MEMORY)
    4279. 

  4279.   /* MULTIMAP_MEMORY -> Mixed pages allow a better usage of memory. */
    4280. 

  4280.   #define SPVW_MIXED
    4281. 

  4281. #elif defined(SINGLEMAP_MEMORY)
    4282. 

  4282.   /* SINGLEMAP_MEMORY -> Ony pure pages/blocks make sense, since
    4283. 

  4283.    the address of a page determines the type of the objects it contains. */
    4284. 

  4284.   #define SPVW_PURE
    4285. 

  4285. #elif !defined(TYPECODES) || defined(MC68000) || defined(SUN3) || defined(SPVW_BLOCKS) || defined(TRIVIALMAP_MEMORY)
    4286. 

  4286.   /* !TYPECODES -> there aren't real typecodes, only Cons and Varobject.
    4287. 

  4287.    MC68000 or SUN3 -> type_pointable(...) costs little or nothing.
    4288. 

  4288.    SPVW_BLOCKS -> SPVW_PURE_BLOCKS is only implemented for SINGLEMAP_MEMORY.
    4289. 

  4289.    TRIVIALMAP_MEMORY -> not many blocks available, small adress space. */
    4290. 

  4290.   #define SPVW_MIXED
    4291. 

  4291. #elif 1 /* provisionally!?? */
    4292. 

  4292.   #define SPVW_MIXED
    4293. 

  4293. #endif
    4294. 

  4294. #if !(defined(SPVW_BLOCKS) || defined(SPVW_PAGES))
    4295. 

  4295.   #error "readjust SPVW_BLOCKS/SPVW_PAGES!"
    4296. 

  4296. #endif
    4297. 

  4297. #if !(defined(SPVW_MIXED) || defined(SPVW_PURE))
    4298. 

  4298.   #error "readjust SPVW_MIXED/SPVW_PURE!"
    4299. 

  4299. #endif
    4300. 

  4300. #if (defined(SPVW_BLOCKS) && defined(SPVW_PURE)) != defined(SINGLEMAP_MEMORY)
    4301. 

  4301.   #error "SINGLEMAP_MEMORY <==> SPVW_PURE_BLOCKS!"
    4302. 

  4302. #endif
    4303. 

  4303. #if (defined(SPVW_BLOCKS) && defined(SPVW_MIXED)) < defined(TRIVIALMAP_MEMORY)
    4304. 

  4304.   #error "TRIVIALMAP_MEMORY ==> SPVW_MIXED_BLOCKS!"
    4305. 

  4305. #endif
    4306. 

  4306. #if defined(SPVW_PURE) && !defined(TYPECODES)
    4307. 

  4307.   #error "SPVW_PURE ==> TYPECODES!"
    4308. 

  4308. #endif
    4309. 

  4309. #if (defined(SPVW_BLOCKS) && (defined(SPVW_PURE) || defined(SPVW_MIXED))) < defined(GENERATIONAL_GC)
    4310. 

  4310.   #error "GENERATIONAL_GC ==> SPVW_PURE_BLOCKS or SPVW_MIXED_BLOCKS_STAGGERED or SPVW_MIXED_BLOCKS_OPPOSITE!"
    4311. 

  4311. #endif
    4312. 

  4312. 

  4313. /* Algorithm by Morris, that compacts Conses without mixing them up: */
    4314. 

  4314. #if defined(SPVW_BLOCKS) && defined(VIRTUAL_MEMORY) && !defined(NO_MORRIS_GC)
    4315. 

  4315.   /* Morris-GC is recommended, as it preserves the locality. */
    4316. 

  4316.   #define MORRIS_GC
    4317. 

  4317. #endif
    4318. 

  4318. 

  4319. /* Put subr_tab and symbol_tab to given addresses through memory-mapping.
    4320. 

  4320.  (The Morris-GC uses the macro upointer() for MULTIMAP_MEMORY. For
    4321. 

  4321.  &symbol_tab = 0x20000000 it'd be upointer(NIL)=0. Darn!) */
    4322. 

  4322. #if defined(MAP_MEMORY) && !defined(WIDE_SOFT) && !(defined(MULTIMAP_MEMORY) && defined(MORRIS_GC))
    4323. 

  4323.   #define MAP_MEMORY_TABLES
    4324. 

  4324. #endif
    4325. 

  4325. 

  4326. 

  4327. /* ################# definitions by cases with respect to type codes ################# */
    4328. 

  4328. 

  4329. #ifdef TYPECODES
    4330. 

  4330. 

  4331. /* Has to start with switch (typecode(obj)), after that it's like a
    4332. 

  4332.  switch-statement with arbitrarily many case-labels.
    4333. 

  4333.  Example:  switch (typecode(arg)) { case_string: ...; break; ... } */
    4334. 

  4334.   #define case_machine    case machine_type   /* machine-pointer */
    4335. 

  4335.   #define case_sstring    case sstring_type   /* Simple-String */
    4336. 

  4336.   #define case_ostring    case string_type    /* Other String */
    4337. 

  4337.   #define case_sbvector   case sbvector_type   /* Simple-Bit-Vector */
    4338. 

  4338.   #define case_obvector   case bvector_type    /* Other Bit-Vector */
    4339. 

  4339.   #define case_sb2vector  case sb2vector_type  /* Simple-2Bit-Vector */
    4340. 

  4340.   #define case_ob2vector  case b2vector_type   /* Other 2Bit-Vector */
    4341. 

  4341.   #define case_sb4vector  case sb4vector_type  /* Simple-4Bit-Vector */
    4342. 

  4342.   #define case_ob4vector  case b4vector_type   /* Other 4Bit-Vector */
    4343. 

  4343.   #define case_sb8vector  case sb8vector_type  /* Simple-8Bit-Vector */
    4344. 

  4344.   #define case_ob8vector  case b8vector_type   /* Other 8Bit-Vector */
    4345. 

  4345.   #define case_sb16vector case sb16vector_type /* Simple-16Bit-Vector */
    4346. 

  4346.   #define case_ob16vector case b16vector_type  /* Other 16Bit-Vector */
    4347. 

  4347.   #define case_sb32vector case sb32vector_type /* Simple-32Bit-Vector */
    4348. 

  4348.   #define case_ob32vector case b32vector_type  /* Other 32Bit-Vector */
    4349. 

  4349.   #define case_svector    case svector_type    /* Simple-(General-)Vector */
    4350. 

  4350.   #define case_ovector    case vector_type    /* Other (General-)Vector */
    4351. 

  4351.   #define case_mdarray    case mdarray_type   /* other Array */
    4352. 

  4352.   #define case_string     case_sstring: case_ostring /* general string */
    4353. 

  4353.   #define case_bvector    case_sbvector: case_obvector /* general bit vector */
    4354. 

  4354.   #define case_b2vector   case_sb2vector: case_ob2vector /* general 2bit vector */
    4355. 

  4355.   #define case_b4vector   case_sb4vector: case_ob4vector /* general 4bit vector */
    4356. 

  4356.   #define case_b8vector   case_sb8vector: case_ob8vector /* general 8bit vector */
    4357. 

  4357.   #define case_b16vector  case_sb16vector: case_ob16vector /* general 16bit vector */
    4358. 

  4358.   #define case_b32vector  case_sb32vector: case_ob32vector /* general 32bit vector */
    4359. 

  4359.   #define case_vector     case_svector: case_ovector /* general vector */
    4360. 

  4360.   #define case_array      case_string: case_bvector: case_b2vector: case_b4vector: case_b8vector: case_b16vector: case_b32vector: case_vector: case_mdarray /* general Array */
    4361. 

  4361.   #define case_closure    case closure_type   /* Closure */
    4362. 

  4362.   #ifdef structure_type
    4363. 

  4363.   #define case_structure  case structure_type /* Structure */
    4364. 

  4364.   #define _case_structure case_structure:
    4365. 

  4365.   #else
    4366. 

  4366.   #define structure_type  orecord_type        /* Structures are OtherRecords */
    4367. 

  4367.   #define _case_structure
    4368. 

  4368.   #endif
    4369. 

  4369.   #ifdef stream_type
    4370. 

  4370.   #define case_stream     case stream_type    /* Stream */
    4371. 

  4371.   #define _case_stream    case_stream:
    4372. 

  4372.   #else
    4373. 

  4373.   #define stream_type     orecord_type        /* Streams are OtherRecords */
    4374. 

  4374.   #define _case_stream
    4375. 

  4375.   #endif
    4376. 

  4376.   #define case_orecord    case orecord_type   /* Other Record */
    4377. 

  4377.   #define case_instance   case instance_type  /* CLOS-Instance */
    4378. 

  4378.   #define case_lrecord    case lrecord_type   /* Long Record */
    4379. 

  4379.   #define case_char       case char_type      /* Character */
    4380. 

  4380.   #define case_subr       case subr_type      /* SUBR */
    4381. 

  4381.   #define case_system     case system_type    /* Frame-Pointer, Small-Read-Label, System */
    4382. 

  4382.   #define case_posfixnum  case fixnum_type    /* Fixnum >=0 */
    4383. 

  4383.   #define case_negfixnum  case fixnum_type|bit(sign_bit_t) /* Fixnum <0 */
    4384. 

  4384.   #define case_fixnum     case_posfixnum: case_negfixnum /* Fixnum */
    4385. 

  4385.   #define case_posbignum  case bignum_type    /* Bignum >0 */
    4386. 

  4386.   #define case_negbignum  case bignum_type|bit(sign_bit_t) /* Bignum <0 */
    4387. 

  4387.   #define case_bignum     case_posbignum: case_negbignum /* Bignum */
    4388. 

  4388.   #define case_integer    case_fixnum: case_bignum /* Integer */
    4389. 

  4389.   #define case_ratio      case ratio_type: case ratio_type|bit(sign_bit_t) /* Ratio */
    4390. 

  4390.   #ifdef SPVW_MIXED
    4391. 

  4391.   #define _case_ratio     case_ratio:
    4392. 

  4392.   #else
    4393. 

  4393.   #define _case_ratio
    4394. 

  4394.   #endif
    4395. 

  4395.   #define case_rational   case_integer: case_ratio /* Rational */
    4396. 

  4396.   #define case_sfloat     case sfloat_type: case sfloat_type|bit(sign_bit_t) /* Short-Float */
    4397. 

  4397.   #define case_ffloat     case ffloat_type: case ffloat_type|bit(sign_bit_t) /* Single-Float */
    4398. 

  4398.   #define case_dfloat     case dfloat_type: case dfloat_type|bit(sign_bit_t) /* Double-Float */
    4399. 

  4399.   #define case_lfloat     case lfloat_type: case lfloat_type|bit(sign_bit_t) /* Long-Float */
    4400. 

  4400.   #define case_float      case_sfloat: case_ffloat: case_dfloat: case_lfloat /* Float */
    4401. 

  4401.   #define case_real       case_rational: case_float /* Real */
    4402. 

  4402.   #define case_complex    case complex_type /* Complex */
    4403. 

  4403.   #ifdef SPVW_MIXED
    4404. 

  4404.   #define _case_complex   case_complex:
    4405. 

  4405.   #else
    4406. 

  4406.   #define _case_complex
    4407. 

  4407.   #endif
    4408. 

  4408.   #define case_number     case_real: case_complex /* Number */
    4409. 

  4409.   #define case_symbol     case symbol_type /* Symbol */
    4410. 

  4410.   #define case_sxrecord   case_closure: _case_structure _case_stream _case_ratio _case_complex case_orecord: case_instance /* Srecord/Xrecord general */
    4411. 

  4411.   #define case_record     case_sxrecord: case_lrecord /* Lrecord/Srecord/Xrecord general */
    4412. 

  4412.   #if /* !defined(NO_symbolflags) && */ (oint_symbolflags_shift==oint_type_shift)
    4413. 

  4413.   #define case_symbolflagged  /* Symbol with Flags                        */\
    4414. 

  4414.           case symbol_type:                                             \
    4415. 

  4415.           case symbol_type|bit(active_bit):                             \
    4416. 

  4416.           case symbol_type|bit(dynam_bit):                              \
    4417. 

  4417.           case symbol_type|bit(dynam_bit)|bit(active_bit):              \
    4418. 

  4418.           case symbol_type|bit(svar_bit):                               \
    4419. 

  4419.           case symbol_type|bit(svar_bit)|bit(active_bit):               \
    4420. 

  4420.           case symbol_type|bit(svar_bit)|bit(dynam_bit):                \
    4421. 

  4421.           case symbol_type|bit(svar_bit)|bit(dynam_bit)|bit(active_bit)
    4422. 

  4422.   #else
    4423. 

  4423.   #define case_symbolflagged  case_symbol /* Symbol with flags */
    4424. 

  4424.   #endif
    4425. 

  4425.   #define case_cons       case cons_type /* Cons */
    4426. 

  4426. 

  4427. #else
    4428. 

  4428. 

  4429.   #define _case_structure
    4430. 

  4430.   #define _case_stream
    4431. 

  4431. 

  4432. #endif
    4433. 

  4433. 

  4434. 

  4435. /* ################## Structure of memory of LISP objects ###################
    4436. 

    4437. 

  4437.  uintWC is the Integer type for the lengths of Bignum, Lfloat, Iarray.
    4438. 

  4438.  Subset relation: uintW <= uintWC <= uintC. */
    4439. 

  4439. #ifdef TYPECODES
    4440. 

  4440.   #define intWCsize intCsize
    4441. 

  4441.   typedef uintC uintWC;
    4442. 

  4442.   typedef sintC sintWC;
    4443. 

  4443. #else
    4444. 

  4444.   /* Type and sign are stored in the heap - only 16 bits for the length. */
    4445. 

  4445.   #define intWCsize intWsize
    4446. 

  4446.   typedef uintW uintWC;
    4447. 

  4447.   typedef sintW sintWC;
    4448. 

  4448. #endif
    4449. 

  4449. /* uintWCoverflow(x) checks, if there has been an overflow after the execution
    4450. 

  4450.  of an x++. */
    4451. 

  4451. #define uintWCoverflow(x)  ((intWCsize<intLsize) && ((uintWC)(x)==0))
    4452. 

  4452. 

  4453. /* ---------------------- Objects with two pointers ---------------------- #
    4454. 

  4454.  They contain just the two pointers, no header. The type must already be
    4455. 

  4455.  known when the object is accessed.
    4456. 

    4457. 

  4457.  Normally, Cons, Ratio, Complex can all be considered as pairs. But if
    4458. 

  4458.  SPVW_MIXED, the heap statistics are a little unspecific if we mix the
    4459. 

  4459.  three types; therefore in that case we let Ratio and Complex be Varobjects. */
    4460. 

  4460. #ifdef SPVW_MIXED
    4461. 

  4461.   #define case_pair  case_cons
    4462. 

  4462. #else
    4463. 

  4463.   #define case_pair  case_cons: case_ratio: case_complex
    4464. 

  4464. #endif
    4465. 

  4465. 

  4466. /* ---------------------- Objects of varying length ---------------------- #
    4467. 

  4467.  The first word is reserved for garbage collection. Outside of garbage
    4468. 

  4468.  collection, it contains a pointer to the object itself. Note that the
    4469. 

  4469.  GC, when it moves an object, takes care not to modify the typecode of
    4470. 

  4470.  this first word (except the GC bit, which it temporarily uses).
    4471. 

    4472. 

  4472.  Type of the header flags: */
    4473. 

  4473. #if (oint_type_len<=8) && !defined(ARM) && !defined(DECALPHA) && !defined(IA64) && !defined(DEBUG_GCSAFETY)
    4474. 

  4474.   /* Access to an individual byte is possible */
    4475. 

  4475.   #define hfintsize  intBsize
    4476. 

  4476.   typedef uintB  hfint;
    4477. 

  4477. #else
    4478. 

  4478.   /* access to a full word */
    4479. 

  4479.   #define hfintsize  pointer_bitsize
    4480. 

  4480.   typedef uintP  hfint;
    4481. 

  4481. #endif
    4482. 

  4482. %% #if (oint_type_len<=8) && !defined(ARM) && !defined(DECALPHA) && !defined(IA64) && !defined(DEBUG_GCSAFETY)
    4483. 

  4483. %%   emit_typedef("uintB","hfint");
    4484. 

  4484. %% #else
    4485. 

  4485. %%   emit_typedef("uintP","hfint");
    4486. 

  4486. %% #endif
    4487. 

  4487. 

  4488. /* Objecs with variable length */
    4489. 

  4489. #ifdef TYPECODES
    4490. 

  4490.   #ifdef DEBUG_GCSAFETY
    4491. 

  4491.     #define VAROBJECT_HEADER  \
    4492. 

  4492.                gcv_object_t _GCself;  /* Self pointer for GC, contains flags */
    4493. 

  4493.   #else
    4494. 

  4494.     #define VAROBJECT_HEADER  \
    4495. 

  4495.                union {                                                    \
    4496. 

  4496.                  gcv_object_t _GCself;  /* Self pointer for GC              */\
    4497. 

  4497.                  hfint flags[sizeof(gcv_object_t)/sizeof(hfint)]; /* Flags  */\
    4498. 

  4498.                } header;
    4499. 

  4499.   #endif
    4500. 

  4500. #else
    4501. 

  4501.   #define VAROBJECT_HEADER  \
    4502. 

  4502.                gcv_object_t GCself;  /* Self pointer for GC  */\
    4503. 

  4503.                uintL tfl;            /* type, flags, length */
    4504. 

  4504. #endif
    4505. 

  4505. typedef struct {
    4506. 

  4506.   VAROBJECT_HEADER
    4507. 

  4507. } varobject_;
    4508. 

  4508. typedef varobject_ *  Varobject;
    4509. 

  4509. #ifdef TYPECODES
    4510. 

  4510.   #ifdef DEBUG_GCSAFETY
    4511. 

  4511.     #define GCself  _GCself
    4512. 

  4512.     #define header_flags  _GCself.one_o
    4513. 

  4513.   #else
    4514. 

  4514.     #define GCself  header._GCself
    4515. 

  4515.     /* The typecode can be found in the byte ((Varobject)p)->header_flags. */
    4516. 

  4516.     #if !(oint_type_len>=hfintsize ? oint_type_shift%hfintsize==0 : floor(oint_type_shift,hfintsize)==floor(oint_type_shift+oint_type_len-1,hfintsize))
    4517. 

  4517.       #error "Bogus header_flags -- redefine header_flags!"
    4518. 

  4518.     #endif
    4519. 

  4519.     #if BIG_ENDIAN_P
    4520. 

  4520.       #define header_flags  header.flags[sizeof(gcv_object_t)/sizeof(hfint)-1-floor(oint_type_shift,hfintsize)]
    4521. 

  4521.     #else
    4522. 

  4522.       #define header_flags  header.flags[floor(oint_type_shift,hfintsize)]
    4523. 

  4523.     #endif
    4524. 

  4524.   #endif
    4525. 

  4525.   /* it applies  mtypecode(((Varobject)p)->GCself) =
    4526. 

  4526.    (((Varobject)p)->header_flags >> (oint_type_shift%hfintsize)) & tint_type_mask
    4527. 

  4527.    Bits for Symbols in the self pointer (see above):
    4528. 

  4528.    define var_bit0_t  ...  # set if the symbol is proclaimed SPECIAL or constant
    4529. 

  4529.    define var_bit1_t  ...  # set if the symbol is a symbol-macro or constant */
    4530. 

  4530.   #define var_bit0_hf  (var_bit0_t+(oint_type_shift%hfintsize))
    4531. 

  4531.   #define var_bit1_hf  (var_bit1_t+(oint_type_shift%hfintsize))
    4532. 

  4532. #else
    4533. 

  4533.   /* Three possible layouts of type, flags, length:
    4534. 

  4534.      8 bits type, 24 bits length [Vrecord, Lrecord]
    4535. 

  4535.      8 bits type, 8 bits flags, 16 bits length [Srecord]
    4536. 

  4536.      8 bits type, 8 bits flags, 8 bits length, 8 bits xlength [Xrecord] */
    4537. 

  4537.   #define vrecord_tfl(type,length)  \
    4538. 

  4538.     ((uintL)(uintB)(type)+((uintL)(length)<<8))
    4539. 

  4539.   #define lrecord_tfl(type,length)  \
    4540. 

  4540.     ((uintL)(uintB)(type)+((uintL)(length)<<8))
    4541. 

  4541.   #define srecord_tfl(type,flags,length)  \
    4542. 

  4542.     ((uintL)(uintB)(type)+((uintL)(uintB)(flags)<<8)+((uintL)(length)<<16))
    4543. 

  4543.   #define xrecord_tfl(type,flags,length,xlength)  \
    4544. 

  4544.     ((uintL)(uintB)(type)+((uintL)(uintB)(flags)<<8)+((uintL)(uintB)(length)<<16)+((uintL)(uintB)(xlength)<<24))
    4545. 

  4545.   #define varobject_type(ptr) ((sintB)((ptr)->tfl & 0xFF))
    4546. 

  4546.   #if defined(__GNUC__) && (__GNUC__ == 2) && ((__GNUC_MINOR__ == 8) || (__GNUC_MINOR__ == 90))
    4547. 

  4547.     /* Work around for a gcc bug present (at least) in gcc-2.8.1 on hppa and
    4548. 

  4548.      egcs-1.0.3a on i386. It miscompiles xpathnamep. */
    4549. 

  4549.     #undef varobject_type
    4550. 

  4550.     #define varobject_type(ptr) ((sintB)((sintL)((ptr)->tfl) & 0xFF))
    4551. 

  4551.   #endif
    4552. 

  4552.     /* Bits for symbols in the flags: */
    4553. 

  4553.     #define header_flags  tfl
    4554. 

  4554.     #define var_bit0_hf  (var_bit0_f+8)
    4555. 

  4555.     #define var_bit1_hf  (var_bit1_f+8)
    4556. 

  4556. #endif
    4557. 

  4557. %% export_def(VAROBJECT_HEADER);
    4558. 

  4558. %% #ifndef TYPECODES
    4559. 

  4559. %%  export_def(GCself);
    4560. 

  4560. %%  export_def(varobject_type(ptr));
    4561. 

  4561. %% #endif
    4562. 

  4562. 

  4563. /* Records
    4564. 

  4564.  These are varobjects with a one-byte type field in memory.
    4565. 

  4565.  There are three types of records:
    4566. 

  4566.    Vector-Records can have up to 16777215 elements, but have no flags and
    4567. 

  4567.    if TYPECODES also no type (because the type info is in the pointer).
    4568. 

  4568.    Long-Records can have up to 16777215 elements, but have no flags.
    4569. 

  4569.    Simple-Records can have up to 65535 elements,
    4570. 

  4570.    Extended-Records have room for up to 255 elements and 255 extra (non-Lisp)
    4571. 

  4571.    elements.
    4572. 

  4572.  Vector-Records are recognized by their type field:
    4573. 

  4573.    rectype == Rectype_Sbvector, Rectype_Sb[2|4|8|16|32]vector,
    4574. 

  4574.               Rectype_S[8|16|32]string, Rectype_Imm_S[8|16|32]string,
    4575. 

  4575.               Rectype_Svector.
    4576. 

  4576.  Long-Records are recognized by rectype >= rectype_longlimit, or if TYPECODES
    4577. 

  4577.  equivalently by their typecode lrecord_type.
    4578. 

  4578.  The others are partitioned into:
    4579. 

  4579.    - Simple-Records, if rectype < rectype_limit.
    4580. 

  4580.    - Extended-Records, if rectype >= rectype_limit. */
    4581. 

  4581. 

  4582. #ifdef TYPECODES
    4583. 

  4583.   #define RECORD_HEADER                                               \
    4584. 

  4584.     VAROBJECT_HEADER   /* self-pointer GC */                          \
    4585. 

  4585.     sintB rectype;     /* for OtherRecord and LongRecord: sub-type */ \
    4586. 

  4586.     uintB recflags;    /* for OtherRecord: flags */                   \
    4587. 

  4587.     uintW reclength;   /* lengths and others */
    4588. 

  4588. #else
    4589. 

  4589.   #define RECORD_HEADER  \
    4590. 

  4590.     VAROBJECT_HEADER   /* self-pointer for GC, tfl */
    4591. 

  4591. #endif
    4592. 

  4592. typedef struct {
    4593. 

  4593.   RECORD_HEADER
    4594. 

  4594.   gcv_object_t recdata[unspecified] _attribute_aligned_object_; /* elements */
    4595. 

  4595. } record_;
    4596. 

  4596. typedef record_ *  Record;
    4597. 

  4597. /* access to type, flags: */
    4598. 

  4598. #ifdef TYPECODES
    4599. 

  4599.   #define record_type(ptr)  ((ptr)->rectype)
    4600. 

  4600. #else
    4601. 

  4601.   #define record_type(ptr)  varobject_type(ptr)
    4602. 

  4602. #endif
    4603. 

  4603. #define Record_type(obj)  record_type(TheRecord(obj))
    4604. 

  4604. #ifdef TYPECODES
    4605. 

  4605.   #define record_flags(ptr)  ((ptr)->recflags)
    4606. 

  4606. #else
    4607. 

  4607.   #define record_flags(ptr)  (((ptr)->tfl >> 8) & 0xFF)
    4608. 

  4608. #endif
    4609. 

  4609. #define Record_flags(obj)  record_flags(TheRecord(obj))
    4610. 

  4610. #ifdef TYPECODES
    4611. 

  4611.   #define record_flags_clr(ptr,bits)  ((ptr)->recflags &= ~(bits))
    4612. 

  4612.   #define record_flags_set(ptr,bits)  ((ptr)->recflags |= (bits))
    4613. 

  4613.   #define record_flags_replace(ptr,newflags)  ((ptr)->recflags = (newflags))
    4614. 

  4614. #else
    4615. 

  4615.   #define record_flags_clr(ptr,bits)  ((ptr)->tfl &= ~((uintL)(bits) << 8))
    4616. 

  4616.   #define record_flags_set(ptr,bits)  ((ptr)->tfl |= ((uintL)(bits) << 8))
    4617. 

  4617.   #define record_flags_replace(ptr,newflags)  \
    4618. 

  4618.     ((ptr)->tfl ^= (((ptr)->tfl ^ (uintL)(newflags)<<8) & 0xFF00))
    4619. 

  4619. #endif
    4620. 

  4620. %% export_def(RECORD_HEADER);
    4621. 

  4621. %% sprintf(buf,"struct { RECORD_HEADER gcv_object_t recdata[unspecified]%s; }",attribute_aligned_object);
    4622. 

  4622. %% emit_typedef(buf,"record_");
    4623. 

  4623. %% emit_typedef("record_ *","Record");
    4624. 

  4624. %% export_def(record_type(ptr));
    4625. 

  4625. %% export_def(Record_type(obj));
    4626. 

  4626. %% export_def(record_flags(ptr));
    4627. 

  4627. %% export_def(record_flags_set(ptr,bits));
    4628. 

  4628. %% export_def(Record_flags(obj));
    4629. 

  4629. 

  4630. #ifdef TYPECODES
    4631. 

  4631.   #define VRECORD_HEADER  \
    4632. 

  4632.                  VAROBJECT_HEADER /* self-pointer for GC  */\
    4633. 

  4633.                  uintL length;    /* length */
    4634. 

  4634. #else
    4635. 

  4635.   #define VRECORD_HEADER  \
    4636. 

  4636.                  VAROBJECT_HEADER /* self-pointer for GC, tfl */
    4637. 

  4637. #endif
    4638. 

  4638. typedef struct {
    4639. 

  4639.   VRECORD_HEADER
    4640. 

  4640. } vrecord_;
    4641. 

  4641. typedef vrecord_ *  Vrecord;
    4642. 

  4642. #ifdef TYPECODES
    4643. 

  4643.   #define vrecord_length(ptr)  ((ptr)->length)
    4644. 

  4644. #else
    4645. 

  4645.   #define vrecord_length(ptr)  ((ptr)->tfl >> 8)
    4646. 

  4646. #endif
    4647. 

  4647. %% export_def(VRECORD_HEADER);
    4648. 

  4648. %% emit_typedef("struct { VRECORD_HEADER }","vrecord_");
    4649. 

  4649. %% emit_typedef("vrecord_ *","Vrecord");
    4650. 

  4650. %% export_def(vrecord_length(ptr));
    4651. 

  4651. 

  4652. #ifdef TYPECODES
    4653. 

  4653.   #define LRECORD_HEADER  \
    4654. 

  4654.                  VAROBJECT_HEADER /* self-pointer for GC  */\
    4655. 

  4655.                  uintL tfl;       /* subtype (1 byte), then length (3 bytes) */
    4656. 

  4656. #else
    4657. 

  4657.   #define LRECORD_HEADER  \
    4658. 

  4658.                  VAROBJECT_HEADER /* self-pointer for GC, tfl */
    4659. 

  4659. #endif
    4660. 

  4660. typedef struct {
    4661. 

  4661.   LRECORD_HEADER
    4662. 

  4662.   gcv_object_t recdata[unspecified] _attribute_aligned_object_; /* reclength elements */
    4663. 

  4663. } lrecord_;
    4664. 

  4664. typedef lrecord_ *  Lrecord;
    4665. 

  4665. #ifdef TYPECODES
    4666. 

  4666.   #if BIG_ENDIAN_P
    4667. 

  4667.     #define lrecord_tfl(type,length)  \
    4668. 

  4668.       (((uintL)(uintB)(type)<<24)+(uintL)(length))
    4669. 

  4669.     #define lrecord_length(ptr)  ((ptr)->tfl & 0xFFFFFF)
    4670. 

  4670.   #else
    4671. 

  4671.     #define lrecord_tfl(type,length)  \
    4672. 

  4672.       ((uintL)(uintB)(type)+((uintL)(length)<<8))
    4673. 

  4673.     #define lrecord_length(ptr)  ((ptr)->tfl >> 8)
    4674. 

  4674.   #endif
    4675. 

  4675. #else
    4676. 

  4676.   #define lrecord_length(ptr)  ((ptr)->tfl >> 8)
    4677. 

  4677. #endif
    4678. 

  4678. #define Lrecord_length(obj)  lrecord_length(TheLrecord(obj))
    4679. 

  4679. 

  4680. #ifdef TYPECODES
    4681. 

  4681.   #define SRECORD_HEADER                                        \
    4682. 

  4682.                  VAROBJECT_HEADER /* self-pointer GC              */\
    4683. 

  4683.                  sintB rectype;   /* subtype, < rectype_limit     */\
    4684. 

  4684.                  uintB recflags;  /* flags                        */\
    4685. 

  4685.                  uintW reclength; /* lengths in objects */
    4686. 

  4686. #else
    4687. 

  4687.   #define SRECORD_HEADER  \
    4688. 

  4688.                  VAROBJECT_HEADER /* self-pointer for GC, tfl */
    4689. 

  4689. #endif
    4690. 

  4690. typedef struct {
    4691. 

  4691.   SRECORD_HEADER
    4692. 

  4692.   gcv_object_t recdata[unspecified] _attribute_aligned_object_; /* reclength elements */
    4693. 

  4693. } srecord_;
    4694. 

  4694. typedef srecord_ *  Srecord;
    4695. 

  4695. #ifdef TYPECODES
    4696. 

  4696.   #define srecord_length(ptr)  ((ptr)->reclength)
    4697. 

  4697. #else
    4698. 

  4698.   #define srecord_length(ptr)  ((ptr)->tfl >> 16)
    4699. 

  4699. #endif
    4700. 

  4700. #define Srecord_length(obj)  srecord_length(TheSrecord(obj))
    4701. 

  4701. %% export_def(SRECORD_HEADER);
    4702. 

  4702. %% sprintf(buf,"struct { SRECORD_HEADER gcv_object_t recdata[unspecified]%s; }",attribute_aligned_object);
    4703. 

  4703. %% emit_typedef(buf,"srecord_");
    4704. 

  4704. %% emit_typedef("srecord_ *","Srecord");
    4705. 

  4705. %% export_def(srecord_length(ptr));
    4706. 

  4706. 

  4707. #ifdef TYPECODES
    4708. 

  4708.   #define XRECORD_HEADER                                                \
    4709. 

  4709.                  VAROBJECT_HEADER  /* self-pointer for GC                 */\
    4710. 

  4710.                  sintB rectype;    /* subtype, >= rectype_limit           */\
    4711. 

  4711.                  uintB recflags;   /* flags                               */\
    4712. 

  4712.                  uintB reclength;  /* lengths in objects                  */\
    4713. 

  4713.                  uintB recxlength; /* lengths of the extra objects */
    4714. 

  4714. #else
    4715. 

  4715.   #define XRECORD_HEADER  \
    4716. 

  4716.                  VAROBJECT_HEADER  /* self-pointer for GC, tfl */
    4717. 

  4717. #endif
    4718. 

  4718. typedef struct {
    4719. 

  4719.   XRECORD_HEADER
    4720. 

  4720.   gcv_object_t recdata[unspecified] _attribute_aligned_object_; /* reclength elements */
    4721. 

  4721.   /* uintB      recxdata[unspecified]; # recxlength extra elements */
    4722. 

  4722. } xrecord_;
    4723. 

  4723. typedef xrecord_ *  Xrecord;
    4724. 

  4724. #ifdef TYPECODES
    4725. 

  4725.   #define xrecord_length(ptr)  ((ptr)->reclength)
    4726. 

  4726.   #define xrecord_xlength(ptr)  ((ptr)->recxlength)
    4727. 

  4727. #else
    4728. 

  4728.   #define xrecord_length(ptr)  (((ptr)->tfl >> 16) & 0xFF)
    4729. 

  4729.   #define xrecord_xlength(ptr)  ((ptr)->tfl >> 24)
    4730. 

  4730. #endif
    4731. 

  4731. #define Xrecord_length(obj)  xrecord_length(TheXrecord(obj))
    4732. 

  4732. #define Xrecord_xlength(obj)  xrecord_xlength(TheXrecord(obj))
    4733. 

  4733. %% export_def(XRECORD_HEADER);
    4734. 

  4734. %% #if notused
    4735. 

  4735. %% sprintf(buf,"struct { XRECORD_HEADER gcv_object_t recdata[unspecified]%s; }",attribute_aligned_object);
    4736. 

  4736. %% emit_typedef(buf,"xrecord_");
    4737. 

  4737. %% emit_typedef("xrecord_ *","Xrecord");
    4738. 

  4738. %% #endif
    4739. 

  4739. 

  4740. /* *** Possible rectype values for records. *** */
    4741. 

  4741. enum {
    4742. 

  4742.   enum_rectype_first = -4, /* Try to keep rectype_limit = 0. */
    4743. 

  4743.   Rectype_Closure,
    4744. 

  4744. %% printf("#define Rectype_Closure %d\n",Rectype_Closure);
    4745. 

  4745.   Rectype_Structure,     /* only used #ifndef case_structure */
    4746. 

  4746. %% printf("#define Rectype_Structure %d\n",Rectype_Structure);
    4747. 

  4747.   Rectype_Instance,
    4748. 

  4748. %% printf("#define Rectype_Instance %d\n",Rectype_Instance);
    4749. 

  4749.      rectype_limit, /* Here is the limit between Srecord and Xrecord. */
    4750. 

  4750.   Rectype_Hashtable = rectype_limit,
    4751. 

  4751. %% printf("#define Rectype_Hashtable %d\n",Rectype_Hashtable);
    4752. 

  4752. #ifndef TYPECODES
    4753. 

  4753. %% #ifndef TYPECODES
    4754. 

  4754.   /* Rectype_vector is the bottom ARRAY & VECTOR */
    4755. 

  4755.   Rectype_vector,       /* 1 -- Iarray, not Srecord/Xrecord */
    4756. 

  4756. %% printf("#define Rectype_vector %d\n",Rectype_vector);
    4757. 

  4757.   Rectype_bvector,      /* 2 -- Iarray, not Srecord/Xrecord */
    4758. 

  4758. %% printf("#define Rectype_bvector %d\n",Rectype_bvector);
    4759. 

  4759.   Rectype_b2vector,     /* 3 -- Iarray, not Srecord/Xrecord */
    4760. 

  4760. %% printf("#define Rectype_b2vector %d\n",Rectype_b2vector);
    4761. 

  4761.   Rectype_b4vector,     /* 4 -- Iarray, not Srecord/Xrecord */
    4762. 

  4762. %% printf("#define Rectype_b4vector %d\n",Rectype_b4vector);
    4763. 

  4763.   Rectype_b8vector,     /* 5 -- Iarray, not Srecord/Xrecord */
    4764. 

  4764. %% printf("#define Rectype_b8vector %d\n",Rectype_b8vector);
    4765. 

  4765.   Rectype_b16vector,    /* 6 -- Iarray, not Srecord/Xrecord */
    4766. 

  4766. %% printf("#define Rectype_b16vector %d\n",Rectype_b16vector);
    4767. 

  4767.   Rectype_b32vector,    /* 7 -- Iarray, not Srecord/Xrecord */
    4768. 

  4768. %% printf("#define Rectype_b32vector %d\n",Rectype_b32vector);
    4769. 

  4769.   Rectype_unused1,           /* 8 */
    4770. 

  4770.   /* Rectype_Svector is the bottom SIMPLE VECTOR */
    4771. 

  4771.   Rectype_Svector,     /* 9 -- Svector, not Srecord/Xrecord */
    4772. 

  4772. %% printf("#define Rectype_Svector %d\n",Rectype_Svector);
    4773. 

  4773.   Rectype_Sbvector,   /* 10 -- Sbvector, not Srecord/Xrecord */
    4774. 

  4774. %% printf("#define Rectype_Sbvector %d\n",Rectype_Sbvector);
    4775. 

  4775.   Rectype_Sb2vector,  /* 11 -- Sbvector, not Srecord/Xrecord */
    4776. 

  4776. %% printf("#define Rectype_Sb2vector %d\n",Rectype_Sb2vector);
    4777. 

  4777.   Rectype_Sb4vector,  /* 12 -- Sbvector, not Srecord/Xrecord */
    4778. 

  4778. %% printf("#define Rectype_Sb4vector %d\n",Rectype_Sb4vector);
    4779. 

  4779.   Rectype_Sb8vector,  /* 13 -- Sbvector, not Srecord/Xrecord */
    4780. 

  4780. %% printf("#define Rectype_Sb8vector %d\n",Rectype_Sb8vector);
    4781. 

  4781.   Rectype_Sb16vector, /* 14 -- Sbvector, not Srecord/Xrecord */
    4782. 

  4782. %% printf("#define Rectype_Sb16vector %d\n",Rectype_Sb16vector);
    4783. 

  4783.   Rectype_Sb32vector, /* 15 -- Sbvector, not Srecord/Xrecord */
    4784. 

  4784. %% printf("#define Rectype_Sb32vector %d\n",Rectype_Sb32vector);
    4785. 

  4785.   Rectype_unused2,          /* 16 */
    4786. 

  4786.   /* Rectype_S8string is the bottom STRING */
    4787. 

  4787.   Rectype_S8string,   /* 17 -- S8string, not Srecord/Xrecord */
    4788. 

  4788. %% printf("#define Rectype_S8string %d\n",Rectype_S8string);
    4789. 

  4789.   Rectype_Imm_S8string, /* 18 -- immutable S8string, not Srecord/Xrecord */
    4790. 

  4790. %% printf("#define Rectype_Imm_S8string %d\n",Rectype_Imm_S8string);
    4791. 

  4791.   Rectype_S16string, /* 19 -- S16string, not Srecord/Xrecord */
    4792. 

  4792. %% printf("#define Rectype_S16string %d\n",Rectype_S16string);
    4793. 

  4793.   Rectype_Imm_S16string, /* 20 -- immutable S16string, not Srecord/Xrecord */
    4794. 

  4794. %% printf("#define Rectype_Imm_S16string %d\n",Rectype_Imm_S16string);
    4795. 

  4795.   Rectype_S32string, /* 21 -- S32string, not Srecord/Xrecord */
    4796. 

  4796. %% printf("#define Rectype_S32string %d\n",Rectype_S32string);
    4797. 

  4797.   Rectype_Imm_S32string, /* 22 -- immutable S32string, not Srecord/Xrecord */
    4798. 

  4798. %% printf("#define Rectype_Imm_S32string %d\n",Rectype_Imm_S32string);
    4799. 

  4799.   Rectype_reallocstring, /* 23 -- reallocated simple string, an Sistring, only used #ifdef HAVE_SMALL_SSTRING */
    4800. 

  4800. %% printf("#define Rectype_reallocstring %d\n",Rectype_reallocstring);
    4801. 

  4801.   /* Rectype_reallocstring is the top SIMPLE-STRING & SIMPLE-VECTOR */
    4802. 

  4802.   Rectype_string,      /* 24 -- Iarray, not Srecord/Xrecord */
    4803. 

  4803. %% printf("#define Rectype_string %d\n",Rectype_string);
    4804. 

  4804.   /* Rectype_string is the top STRING */
    4805. 

  4805.   Rectype_mdarray,     /* 25 -- Iarray, not Srecord/Xrecord */
    4806. 

  4806. %% printf("#define Rectype_mdarray %d\n",Rectype_mdarray);
    4807. 

  4807.   /* Rectype_mdarray is the top ARRAY
    4808. 

  4808.    Rectype_Bignum is the bottom NUMBER */
    4809. 

  4809.   Rectype_Bignum,        /* Bignum, not Srecord/Xrecord */
    4810. 

  4810. %% printf("#define Rectype_Bignum %d\n",Rectype_Bignum);
    4811. 

  4811.   Rectype_Lfloat,        /* Lfloat, not Srecord/Xrecord */
    4812. 

  4812. %% printf("#define Rectype_Lfloat %d\n",Rectype_Lfloat);
    4813. 

  4813.   Rectype_Dfloat,
    4814. 

  4814. %% printf("#define Rectype_Dfloat %d\n",Rectype_Dfloat);
    4815. 

  4815.   Rectype_Ffloat,
    4816. 

  4816. %% printf("#define Rectype_Ffloat %d\n",Rectype_Ffloat);
    4817. 

  4817. %% #endif
    4818. 

  4818. #endif  /* TYPECODES */
    4819. 

  4819. #ifdef SPVW_MIXED
    4820. 

  4820. %% #ifdef SPVW_MIXED
    4821. 

  4821.   Rectype_Ratio,
    4822. 

  4822. %% printf("#define Rectype_Ratio %d\n",Rectype_Ratio);
    4823. 

  4823.   Rectype_Complex,
    4824. 

  4824. %% printf("#define Rectype_Complex %d\n",Rectype_Complex);
    4825. 

  4825. %% #endif
    4826. 

  4826. #endif /* SPVW_MIXED */
    4827. 

  4827.   /* *** Here the numbers end. *** */
    4828. 

  4828. #ifndef TYPECODES
    4829. 

  4829. %% #ifndef TYPECODES
    4830. 

  4830.   Rectype_Symbol,
    4831. 

  4831. %% printf("#define Rectype_Symbol %d\n",Rectype_Symbol);
    4832. 

  4832. %% #endif
    4833. 

  4833. #endif  /* TYPECODES */
    4834. 

  4834.   Rectype_Package,
    4835. 

  4835. %% printf("#define Rectype_Package %d\n",Rectype_Package);
    4836. 

  4836.   Rectype_Readtable,
    4837. 

  4837. %% printf("#define Rectype_Readtable %d\n",Rectype_Readtable);
    4838. 

  4838.   Rectype_Pathname,
    4839. 

  4839. %% printf("#define Rectype_Pathname %d\n",Rectype_Pathname);
    4840. 

  4840. #ifdef LOGICAL_PATHNAMES
    4841. 

  4841. %% #ifdef LOGICAL_PATHNAMES
    4842. 

  4842.   Rectype_Logpathname,
    4843. 

  4843. %% printf("#define Rectype_Logpathname %d\n",Rectype_Logpathname);
    4844. 

  4844. %% #endif
    4845. 

  4845. #endif  /* LOGICAL_PATHNAMES */
    4846. 

  4846.   Rectype_Random_State,
    4847. 

  4847. %% printf("#define Rectype_Random_State %d\n",Rectype_Random_State);
    4848. 

  4848. #ifndef case_stream
    4849. 

  4849. %% #ifndef case_stream
    4850. 

  4850.   Rectype_Stream,
    4851. 

  4851. %% printf("#define Rectype_Stream %d\n",Rectype_Stream);
    4852. 

  4852. %% #endif
    4853. 

  4853. #endif  /* case_stream */
    4854. 

  4854.   Rectype_Byte,
    4855. 

  4855. %% printf("#define Rectype_Byte %d\n",Rectype_Byte);
    4856. 

  4856.   Rectype_Subr,
    4857. 

  4857. %% printf("#define Rectype_Subr %d\n",Rectype_Subr);
    4858. 

  4858.   Rectype_Fsubr,
    4859. 

  4859. %% printf("#define Rectype_Fsubr %d\n",Rectype_Fsubr);
    4860. 

  4860.   Rectype_Loadtimeeval,
    4861. 

  4861. %% printf("#define Rectype_Loadtimeeval %d\n",Rectype_Loadtimeeval);
    4862. 

  4862.   Rectype_Symbolmacro,
    4863. 

  4863. %% printf("#define Rectype_Symbolmacro %d\n",Rectype_Symbolmacro);
    4864. 

  4864.   Rectype_GlobalSymbolmacro,
    4865. 

  4865. %% printf("#define Rectype_GlobalSymbolmacro %d\n",Rectype_GlobalSymbolmacro);
    4866. 

  4866.   Rectype_Macro,
    4867. 

  4867. %% printf("#define Rectype_Macro %d\n",Rectype_Macro);
    4868. 

  4868.   Rectype_FunctionMacro,
    4869. 

  4869. %% printf("#define Rectype_FunctionMacro %d\n",Rectype_FunctionMacro);
    4870. 

  4870.   Rectype_BigReadLabel,
    4871. 

  4871. %% printf("#define Rectype_BigReadLabel %d\n",Rectype_BigReadLabel);
    4872. 

  4872.   Rectype_Encoding,
    4873. 

  4873. %% printf("#define Rectype_Encoding %d\n",Rectype_Encoding);
    4874. 

  4874.   Rectype_Fpointer,      /* only used #ifdef FOREIGN */
    4875. 

  4875. %% printf("#define Rectype_Fpointer %d\n",Rectype_Fpointer);
    4876. 

  4876. #ifdef DYNAMIC_FFI
    4877. 

  4877. %% #ifdef DYNAMIC_FFI
    4878. 

  4878.   Rectype_Faddress,
    4879. 

  4879. %% printf("#define Rectype_Faddress %d\n",Rectype_Faddress);
    4880. 

  4880.   Rectype_Fvariable,
    4881. 

  4881. %% printf("#define Rectype_Fvariable %d\n",Rectype_Fvariable);
    4882. 

  4882.   Rectype_Ffunction,
    4883. 

  4883. %% printf("#define Rectype_Ffunction %d\n",Rectype_Ffunction);
    4884. 

  4884. %% #endif
    4885. 

  4885. #endif  /* DYNAMIC_FFI */
    4886. 

  4886.   Rectype_Weakpointer,
    4887. 

  4887. %% printf("#define Rectype_Weakpointer %d\n",Rectype_Weakpointer);
    4888. 

  4888.   Rectype_MutableWeakList,
    4889. 

  4889. %% printf("#define Rectype_MutableWeakList %d\n",Rectype_MutableWeakList);
    4890. 

  4890.   Rectype_MutableWeakAlist,
    4891. 

  4891. %% printf("#define Rectype_MutableWeakAlist %d\n",Rectype_MutableWeakAlist);
    4892. 

  4892.   Rectype_Weakmapping,
    4893. 

  4893. %% printf("#define Rectype_Weakmapping %d\n",Rectype_Weakmapping);
    4894. 

  4894.   Rectype_Finalizer,
    4895. 

  4895. %% printf("#define Rectype_Finalizer %d\n",Rectype_Finalizer);
    4896. 

  4896. #ifdef SOCKET_STREAMS
    4897. 

  4897. %% #ifdef SOCKET_STREAMS
    4898. 

  4898.   Rectype_Socket_Server,
    4899. 

  4899. %% printf("#define Rectype_Socket_Server %d\n",Rectype_Socket_Server);
    4900. 

  4900. %% #endif
    4901. 

  4901. #endif  /* SOCKET_STREAMS */
    4902. 

  4902. #ifdef YET_ANOTHER_RECORD
    4903. 

  4903. %% #ifdef YET_ANOTHER_RECORD
    4904. 

  4904.   Rectype_Yetanother,
    4905. 

  4905. %% printf("#define Rectype_Yetanother %d\n",Rectype_Yetanother);
    4906. 

  4906. %% #endif
    4907. 

  4907. #endif /* YET_ANOTHER_RECORD */
    4908. 

  4908.   rectype_longlimit, /* the boundary between Srecord/Xrecord and Lrecord. */
    4909. 

  4909.   Rectype_WeakList,
    4910. 

  4910. %% printf("#define Rectype_WeakList %d\n",Rectype_WeakList);
    4911. 

  4911.   Rectype_WeakAnd,
    4912. 

  4912. %% printf("#define Rectype_WeakAnd %d\n",Rectype_WeakAnd);
    4913. 

  4913.   Rectype_WeakOr,
    4914. 

  4914. %% printf("#define Rectype_WeakOr %d\n",Rectype_WeakOr);
    4915. 

  4915.   Rectype_WeakAndMapping,
    4916. 

  4916. %% printf("#define Rectype_WeakAndMapping %d\n",Rectype_WeakAndMapping);
    4917. 

  4917.   Rectype_WeakOrMapping,
    4918. 

  4918. %% printf("#define Rectype_WeakOrMapping %d\n",Rectype_WeakOrMapping);
    4919. 

  4919.   Rectype_WeakAlist_Key,
    4920. 

  4920. %% printf("#define Rectype_WeakAlist_Key %d\n",Rectype_WeakAlist_Key);
    4921. 

  4921.   Rectype_WeakAlist_Value,
    4922. 

  4922. %% printf("#define Rectype_WeakAlist_Value %d\n",Rectype_WeakAlist_Value);
    4923. 

  4923.   Rectype_WeakAlist_Either,
    4924. 

  4924. %% printf("#define Rectype_WeakAlist_Either %d\n",Rectype_WeakAlist_Either);
    4925. 

  4925.   Rectype_WeakAlist_Both,
    4926. 

  4926. %% printf("#define Rectype_WeakAlist_Both %d\n",Rectype_WeakAlist_Both);
    4927. 

  4927.   Rectype_WeakHashedAlist_Key,
    4928. 

  4928. %% printf("#define Rectype_WeakHashedAlist_Key %d\n",Rectype_WeakHashedAlist_Key);
    4929. 

  4929.   Rectype_WeakHashedAlist_Value,
    4930. 

  4930. %% printf("#define Rectype_WeakHashedAlist_Value %d\n",Rectype_WeakHashedAlist_Value);
    4931. 

  4931.   Rectype_WeakHashedAlist_Either,
    4932. 

  4932. %% printf("#define Rectype_WeakHashedAlist_Either %d\n",Rectype_WeakHashedAlist_Either);
    4933. 

  4933.   Rectype_WeakHashedAlist_Both,
    4934. 

  4934. %% printf("#define Rectype_WeakHashedAlist_Both %d\n",Rectype_WeakHashedAlist_Both);
    4935. 

  4935. #ifdef MULTITHREAD
    4936. 

  4936. %% #ifdef MULTITHREAD
    4937. 

  4937.   Rectype_Thread,
    4938. 

  4938. %%  printf("#define Rectype_Thread %d\n",Rectype_Thread);
    4939. 

  4939.   Rectype_Mutex,
    4940. 

  4940. %%  printf("#define Rectype_Mutex %d\n",Rectype_Mutex);
    4941. 

  4941.   Rectype_Exemption,
    4942. 

  4942. %%  printf("#define Rectype_Exemption %d\n",Rectype_Exemption);
    4943. 

  4943. %% #endif
    4944. 

  4944. #endif
    4945. 

  4945.   rectype_for_broken_compilers_that_dont_like_trailing_commas
    4946. 

  4946. };
    4947. 

  4947. 

  4948. /* -------------------------- the various types -------------------------- */
    4949. 

  4949. 

  4950. /* Cons */
    4951. 

  4951. typedef struct {
    4952. 

  4952.   gcv_object_t cdr _attribute_aligned_object_; /* CDR */
    4953. 

  4953.   gcv_object_t car _attribute_aligned_object_; /* CAR */
    4954. 

  4954. } cons_;
    4955. 

  4955. typedef cons_ *  Cons;
    4956. 

  4956. %% sprintf(buf,"struct { gcv_object_t cdr%s; gcv_object_t car%s; }",attribute_aligned_object,attribute_aligned_object);
    4957. 

  4957. %% emit_typedef(buf,"cons_");
    4958. 

  4958. %% emit_typedef("cons_ *","Cons");
    4959. 

  4959. 

  4960. /* Ratio */
    4961. 

  4961. typedef struct {
    4962. 

  4962.   #ifdef SPVW_MIXED
    4963. 

  4963.   XRECORD_HEADER
    4964. 

  4964.   #endif
    4965. 

  4965.   gcv_object_t rt_num _attribute_aligned_object_; /* numerator, Integer */
    4966. 

  4966.   gcv_object_t rt_den _attribute_aligned_object_; /* denominator, Integer >0 */
    4967. 

  4967. } ratio_;
    4968. 

  4968. typedef ratio_ *  Ratio;
    4969. 

  4969. %% #if notused
    4970. 

  4970. %% #ifdef SPVW_MIXED
    4971. 

  4971. %%   sprintf(buf,"struct { XRECORD_HEADER gcv_object_t rt_num%s; gcv_object_t rt_den%s; }",attribute_aligned_object,attribute_aligned_object);
    4972. 

  4972. %% #else
    4973. 

  4973. %%   sprintf(buf,"struct { gcv_object_t rt_num%s; gcv_object_t rt_den%s; }",attribute_aligned_object,attribute_aligned_object);
    4974. 

  4974. %% #endif
    4975. 

  4975. %% emit_typedef(buf,"ratio_");
    4976. 

  4976. %% emit_typedef("ratio_ *","Ratio");
    4977. 

  4977. %% #endif
    4978. 

  4978. 

  4979. /* Complex */
    4980. 

  4980. typedef struct {
    4981. 

  4981.   #ifdef SPVW_MIXED
    4982. 

  4982.   XRECORD_HEADER
    4983. 

  4983.   #endif
    4984. 

  4984.   gcv_object_t c_real _attribute_aligned_object_; /* real part, real number */
    4985. 

  4985.   gcv_object_t c_imag _attribute_aligned_object_; /* imaginary part, real number */
    4986. 

  4986. } complex_;
    4987. 

  4987. typedef complex_ *  Complex;
    4988. 

  4988. %% #if notused
    4989. 

  4989. %% #ifdef SPVW_MIXED
    4990. 

  4990. %%   sprintf(buf,"struct { XRECORD_HEADER gcv_object_t c_real%s; gcv_object_t c_imag%s; }",attribute_aligned_object,attribute_aligned_object);
    4991. 

  4991. %% #else
    4992. 

  4992. %%   sprintf(buf,"struct { gcv_object_t c_real%s; gcv_object_t c_imag%s; }",attribute_aligned_object,attribute_aligned_object);
    4993. 

  4993. %% #endif
    4994. 

  4994. %% emit_typedef(buf,"complex_");
    4995. 

  4995. %% emit_typedef("complex_ *","Complex");
    4996. 

  4996. %% #endif
    4997. 

  4997. 

  4998. /* Symbol */
    4999. 

  4999. typedef struct {
    5000. 

  5000.   VAROBJECT_HEADER
    5001. 

  5001.   gcv_object_t symvalue    _attribute_aligned_object_; /* value cell */
    5002. 

  5002.   gcv_object_t symfunction _attribute_aligned_object_; /* function definition cell */
    5003. 

  5003.   gcv_object_t hashcode    _attribute_aligned_object_; /* hash code */
    5004. 

  5004.   gcv_object_t proplist    _attribute_aligned_object_; /* property list */
    5005. 

  5005.   gcv_object_t pname       _attribute_aligned_object_; /* Printname */
    5006. 

  5006.   gcv_object_t homepackage _attribute_aligned_object_; /* Home-Package or NIL */
    5007. 

  5007.   /* If necessary, add fillers here to ensure sizeof(subr_t) is a multiple of
    5008. 

  5008.    varobject_alignment. */
    5009. 

  5009.   #if defined(LINUX_NOEXEC_HEAPCODES) && 0
    5010. 

  5010.   gcv_object_t filler      _attribute_aligned_object_;
    5011. 

  5011.   #endif
    5012. 

  5012. } symbol_;
    5013. 

  5013. typedef symbol_ *  Symbol;
    5014. 

  5014. #ifdef LINUX_NOEXEC_HEAPCODES
    5015. 

  5015.   /* Compile-time check: sizeof(symbol_) is a multiple of varobject_alignment. */
    5016. 

  5016.   typedef int symbol_size_check[1 - 2 * (int)(sizeof(symbol_) % varobject_alignment)];
    5017. 

  5017. #endif
    5018. 

  5018. #define symbol_objects_offset  offsetof(symbol_,symvalue)
    5019. 

  5019. #define symbol_length  6
    5020. 

  5020. %% #if defined(LINUX_NOEXEC_HEAPCODES) && 0
    5021. 

  5021. %%   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; gcv_object_t filler%s; }",attribute_aligned_object,attribute_aligned_object,attribute_aligned_object,attribute_aligned_object,attribute_aligned_object,attribute_aligned_object,attribute_aligned_object);
    5022. 

  5022. %% #else
    5023. 

  5023. %%   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);
    5024. 

  5024. %% #endif
    5025. 

  5025. %% emit_typedef(buf,"symbol_");
    5026. 

  5026. %% emit_typedef("symbol_ *","Symbol");
    5027. 

  5027. 

  5028. /* Every keyword is a constant. */
    5029. 

  5029. 

  5030. /* Tests whether a symbol is a keyword: */
    5031. 

  5031.   #define keywordp(sym)  \
    5032. 

  5032.     (eq(TheSymbol(sym)->homepackage,O(keyword_package)))
    5033. 

  5033. 

  5034. /* For constants, the special-bit is meaningless (since constants
    5035. 

  5035.  can't be bound lexically nor dynamically). */
    5036. 

  5036. 

  5037. /* Tests whether a symbol is a constant: */
    5038. 

  5038.   #define constant_var_p(sym)  \
    5039. 

  5039.     (((bit(var_bit0_hf)|bit(var_bit1_hf)) & ~((sym)->header_flags)) == 0)
    5040. 

  5040. 

  5041. /* Tests whether a symbol is a SPECIAL-proclaimed variable or a constant: */
    5042. 

  5042.   #define special_var_p(sym)  (((sym)->header_flags) & bit(var_bit0_hf))
    5043. 

  5043. 

  5044. /* Tests whether a symbol is a symbol-macro: */
    5045. 

  5045.   #define symmacro_var_p(sym)  \
    5046. 

  5046.     ((((sym)->header_flags) & bit(var_bit1_hf))            \
    5047. 

  5047.      && ((((sym)->header_flags) & bit(var_bit0_hf)) == 0))
    5048. 

  5048. 

  5049. /* Set the constant-flag of a non-symbol-macro symbol: */
    5050. 

  5050.   #define set_const_flag(sym)  \
    5051. 

  5051.     (((sym)->header_flags) |= bit(var_bit0_hf)|bit(var_bit1_hf))
    5052. 

  5052. 

  5053. /* Delete the constant-flag of a symbol that is a constant:
    5054. 

  5054.  (Symbol must not be a Keyword, comp. spvw.d:case_symbolwithflags) */
    5055. 

  5055.   #define clear_const_flag(sym)  \
    5056. 

  5056.     (((sym)->header_flags) &= ~(bit(var_bit0_hf)|bit(var_bit1_hf)))
    5057. 

  5057. 

  5058. /* Set the special-flag of a non-symbol-macro symbol: */
    5059. 

  5059.   #define set_special_flag(sym)  \
    5060. 

  5060.     (((sym)->header_flags) |= bit(var_bit0_hf))
    5061. 

  5061. 

  5062. /* Delete the special-flag of a symbol that is special and non-constant: */
    5063. 

  5063.   #define clear_special_flag(sym)  \
    5064. 

  5064.     (((sym)->header_flags) &= ~bit(var_bit0_hf))
    5065. 

  5065. 

  5066. /* Set the symbol-macro-flag of a non-special/constant symbol: */
    5067. 

  5067.   #define set_symmacro_flag(sym)  \
    5068. 

  5068.     (((sym)->header_flags) |= bit(var_bit1_hf))
    5069. 

  5069. 

  5070. /* Delete the symbol-macro-flag of a symbol that is a symbol-macro: */
    5071. 

  5071.   #define clear_symmacro_flag(sym)  \
    5072. 

  5072.     (((sym)->header_flags) &= ~bit(var_bit1_hf))
    5073. 

  5073. 

  5074. /* Define symbol as constant with given value val.
    5075. 

  5075.  val must not trigger the GC! */
    5076. 

  5076.   #define define_constant(sym,val)                              \
    5077. 

  5077.     do { var Symbol sym_from_define_constant = TheSymbol(sym);  \
    5078. 

  5078.          set_const_flag(sym_from_define_constant);              \
    5079. 

  5079.          sym_from_define_constant->symvalue = (val);            \
    5080. 

  5080.     } while(0)
    5081. 

  5081. 

  5082. /* Define symbol as variable and initialize it with a given value val.
    5083. 

  5083.  val must not trigger the GC! */
    5084. 

  5084.   #define define_variable(sym,val)                              \
    5085. 

  5085.     do { var Symbol sym_from_define_variable = TheSymbol(sym);  \
    5086. 

  5086.          set_special_flag(sym_from_define_variable);            \
    5087. 

  5087.          sym_from_define_variable->symvalue = (val);            \
    5088. 

  5088.     } while(0)
    5089. 

  5089. 

  5090. /* Remove flag-bits of a symbol: */
    5091. 

  5091. #if defined(NO_symbolflags)
    5092. 

  5092.   #define symbol_without_flags(symbol)  symbol
    5093. 

  5093. #elif (oint_symbolflags_shift==oint_type_shift)
    5094. 

  5094.   #define symbol_without_flags(symbol)  \
    5095. 

  5095.     as_object(as_oint(symbol) & (type_zero_oint(symbol_type) | oint_addr_mask))
    5096. 

  5096. #else
    5097. 

  5097.   #define symbol_without_flags(symbol)  \
    5098. 

  5098.     as_object(as_oint(symbol) & ~((wbit(active_bit)|wbit(dynam_bit)|wbit(svar_bit))<<oint_symbolflags_shift))
    5099. 

  5099. #endif
    5100. 

  5100. /* add a flag to the object */
    5101. 

  5101. #define SET_BIT(o,b)  as_object(as_oint(o) | wbit(b));
    5102. 

  5102. /* remove a flag from the object */
    5103. 

  5103. #define CLR_BIT(o,b)  as_object(as_oint(o) & ~wbit(b));
    5104. 

  5104. 

  5105. /* Characters */
    5106. 

  5106. 

  5107. /* Integer type holding the data of a character: */
    5108. 

  5108. #ifdef UNICODE
    5109. 

  5109.   #define char_int_len 24  /* anything between 21 and 32 will do */
    5110. 

  5110.   #define char_int_limit 0x110000UL
    5111. 

  5111. #else
    5112. 

  5112.   #define char_int_len 8
    5113. 

  5113.   #define char_int_limit 0x100UL
    5114. 

  5114. #endif
    5115. 

  5115. typedef unsigned_int_with_n_bits(char_int_len)  cint;
    5116. 

  5116. #define char_code_limit  char_int_limit
    5117. 

  5117. /* Converting an integral code to a character: */
    5118. 

  5118. #define int_char(int_from_int_char)  \
    5119. 

  5119.   type_data_object(char_type,(aint)(cint)(int_from_int_char))
    5120. 

  5120. /* Converting a character to an integral code: */
    5121. 

  5121. #if !((oint_data_shift==0) && (char_int_len<=oint_data_len) && (exact_uint_size_p(char_int_len)))
    5122. 

  5122.   #ifdef TYPECODES
    5123. 

  5123.     #define char_int(char_from_char_int)  \
    5124. 

  5124.       ((cint)(untype(char_from_char_int)))
    5125. 

  5125.   #else
    5126. 

  5126.     #if (char_type>>oint_data_shift)==0 || (char_int_len<=16)
    5127. 

  5127.       #define char_int(char_from_char_int)  \
    5128. 

  5128.         ((cint)(as_oint(char_from_char_int)>>oint_data_shift))
    5129. 

  5129.     #else
    5130. 

  5130.       #define char_int(char_from_char_int)  \
    5131. 

  5131.         ((cint)((as_oint(char_from_char_int)>>oint_data_shift)&(bitm(oint_data_len)-1)))
    5132. 

  5132.     #endif
    5133. 

  5133.   #endif
    5134. 

  5134. #else
    5135. 

  5135.   /* If oint_data_shift=0, untype does not need to shift. If also
    5136. 

  5136.    char_int_len<=oint_data_len, and if a cint has exactly char_int_len
    5137. 

  5137.    bits, untype does not need to AND. */
    5138. 

  5138.   #define char_int(char_from_char_int)  \
    5139. 

  5139.     ((cint)as_oint(char_from_char_int))
    5140. 

  5140. #endif
    5141. 

  5141. /* Characters can therefore be compared for equality using EQ, this is an
    5142. 

  5142.  oint comparison, among the characters a comparison of their integral code. */
    5143. 

  5143. %% sprintf(buf,"uint%d",char_int_len); emit_typedef(buf,"cint");
    5144. 

  5144. %% export_def(int_char(int_from_int_char));
    5145. 

  5145. %% export_def(char_int(char_from_char_int));
    5146. 

  5146. 

  5147. /* A standalone character. Prefer `chart' to `cint' wherever possible because
    5148. 

  5148.  it is typesafe. sizeof(chart) = sizeof(cint). */
    5149. 

  5149. #ifdef CHART_STRUCT
    5150. 

  5150.   #ifdef __cplusplus
    5151. 

  5151.     struct chart { chart() {} chart(int c) : one_c(c) {} cint one_c; };
    5152. 

  5152.   #else
    5153. 

  5153.     typedef struct { cint one_c; } chart;
    5154. 

  5154.   #endif
    5155. 

  5155. #else
    5156. 

  5156.   typedef cint chart;
    5157. 

  5157. #endif
    5158. 

  5158. /* Conversions between both:
    5159. 

  5159.  as_cint(ch)   chart --> cint
    5160. 

  5160.  as_chart(c)   cint --> chart */
    5161. 

  5161. #ifdef CHART_STRUCT
    5162. 

  5162.   #define as_cint(ch)  ((ch).one_c)
    5163. 

  5163.   #if 1
    5164. 

  5164.     #ifdef __cplusplus
    5165. 

  5165.       inline chart as_chart(int c) { return chart(c); }
    5166. 

  5166.     #else
    5167. 

  5167.       #define as_chart(c)  ((chart){one_c:(c)})
    5168. 

  5168.     #endif
    5169. 

  5169.   #else
    5170. 

  5170.     extern __inline__ chart as_chart (register cint c)
    5171. 

  5171.       { register chart ch; ch.one_c = c; return ch; }
    5172. 

  5172.   #endif
    5173. 

  5173. #else
    5174. 

  5174.   #define as_cint(ch)  (ch)
    5175. 

  5175.   #define as_chart(c)  (c)
    5176. 

  5176. #endif
    5177. 

  5177. /* Conversion chart --> object. */
    5178. 

  5178. #define code_char(ch)  int_char(as_cint(ch))
    5179. 

  5179. /* Conversion object --> chart. */
    5180. 

  5180. #define char_code(obj)  as_chart(char_int(obj))
    5181. 

  5181. /* Comparison operations. */
    5182. 

  5182. #define chareq(ch1,ch2)  (as_cint(ch1) == as_cint(ch2))
    5183. 

  5183. #define charlt(ch1,ch2)  (as_cint(ch1) < as_cint(ch2))
    5184. 

  5184. #define chargt(ch1,ch2)  (as_cint(ch1) > as_cint(ch2))
    5185. 

  5185. %% #ifdef CHART_STRUCT
    5186. 

  5186. %%   emit_typedef("struct { cint one_c; }","chart");
    5187. 

  5187. %% #else
    5188. 

  5188. %%   emit_typedef("cint","chart");
    5189. 

  5189. %% #endif
    5190. 

  5190. %% export_def(as_cint(ch));
    5191. 

  5191. %% export_def(as_chart(c));
    5192. 

  5192. %% export_def(code_char(ch));
    5193. 

  5193. %% export_def(char_code(obj));
    5194. 

  5194. 

  5195. /* Conversion standard char (in ASCII encoding) --> chart. */
    5196. 

  5196. #define ascii(x)  as_chart((uintB)(x))
    5197. 

  5197. /* Conversion standard char (in ASCII encoding) --> object. */
    5198. 

  5198. #define ascii_char(x)  code_char(ascii(x))
    5199. 

  5199. 

  5200. /* Test for STANDARD-CHAR. */
    5201. 

  5201. #define standard_cint_p(x)  ((('~' >= (x)) && ((x) >= ' ')) || ((x) == NL))
    5202. 

  5202. 

  5203. /* Whether to use three different kinds of string representations. */
    5204. 

  5204. #if defined(UNICODE) && (defined(GNU) || (defined(UNIX) && !defined(NO_ALLOCA) && !defined(SPARC)) || defined(BORLAND) || defined(MICROSOFT)) && !defined(NO_SMALL_SSTRING)
    5205. 

  5205. #define HAVE_SMALL_SSTRING
    5206. 

  5206. #endif
    5207. 

  5207. 

  5208. #ifdef HAVE_SMALL_SSTRING
    5209. 

  5209.   #define if_HAVE_SMALL_SSTRING(statement)  statement
    5210. 

  5210.   /* We have three kinds of simple strings, with 8-bit codes (ISO-8859-1
    5211. 

  5211.    strings), with 16-bit codes (UCS-2 strings) and with 32-bit codes
    5212. 

  5212.    (UCS-4/UTF-32 strings). */
    5213. 

  5213.   typedef uint8 cint8;
    5214. 

  5214.   #define cint8_limit (1UL<<8)
    5215. 

  5215.   typedef uint16 cint16;
    5216. 

  5216.   #define cint16_limit (1UL<<16)
    5217. 

  5217.   typedef uint32 cint32;
    5218. 

  5218.   #define cint32_limit 0x110000UL
    5219. 

  5219. #else
    5220. 

  5220.   #define if_HAVE_SMALL_SSTRING(statement)  /*nop*/
    5221. 

  5221.   /* Only one kind of simple strings. */
    5222. 

  5222.   typedef cint cint8;
    5223. 

  5223.   #define cint8_limit char_int_limit
    5224. 

  5224.   typedef cint cint16;
    5225. 

  5225.   #define cint16_limit char_int_limit
    5226. 

  5226.   typedef cint cint32;
    5227. 

  5227.   #define cint32_limit char_int_limit
    5228. 

  5228. #endif
    5229. 

  5229. %% #ifdef HAVE_SMALL_SSTRING
    5230. 

  5230. %%   emit_typedef("uint8","cint8");
    5231. 

  5231. %%   emit_typedef("uint16","cint16");
    5232. 

  5232. %%   emit_typedef("uint32","cint32");
    5233. 

  5233. %% #endif
    5234. 

  5234. 

  5235. /* Base characters. */
    5236. 

  5236. #define base_char_int_len char_int_len
    5237. 

  5237. #define base_char_code_limit  char_code_limit
    5238. 

  5238. /* The BASE-CHAR type is defined as
    5239. 

  5239.      (upgraded-array-element-type 'standard-char),
    5240. 

  5240.  i.e. the element-type of arrays created with (make-array 'standard-char ...).
    5241. 

  5241.  Since it defeats the purpose of UNICODE to have different 8-bit, 16-bit
    5242. 

  5242.  and 24-bit character types, we define BASE-CHAR=CHARACTER. */
    5243. 

  5243. 

  5244. /* Fixnums */
    5245. 

  5245. 

  5246. /* fixnum(x) is a fixnum with value x>=0.
    5247. 

  5247.  x is an expression with 0 <= x < 2^oint_data_len.
    5248. 

  5248.  (Should really be called posfixnum(x).) */
    5249. 

  5249. #define fixnum(x)  type_data_object(fixnum_type,x)
    5250. 

  5250. %% export_def(fixnum(x));
    5251. 

  5251. 

  5252. /* Fixnum_0 is the number 0, Fixnum_1 is the number 1,
    5253. 

  5253.  Fixnum_minus1 is the number -1 */
    5254. 

  5254. #define Fixnum_0  fixnum(0)
    5255. 

  5255. #define Fixnum_1  fixnum(1)
    5256. 

  5256. #define Fixnum_minus1  type_data_object( fixnum_type | bit(sign_bit_t), vbitm(oint_data_len)-1 )
    5257. 

  5257. %% export_def(Fixnum_0);
    5258. 

  5258. %% export_def(Fixnum_1);
    5259. 

  5259. %% export_def(Fixnum_minus1);
    5260. 

  5260. 

  5261. /* Value of a non-negative fixnum:
    5262. 

  5262.  posfixnum_to_V(obj)
    5263. 

  5263.  result is >= 0, < 2^oint_data_len. */
    5264. 

  5264. #if !(defined(SPARC) && (oint_data_len+oint_data_shift<32))
    5265. 

  5265.   #define posfixnum_to_V(obj)  \
    5266. 

  5266.     ((uintV)((as_oint(obj)&((oint)wbitm(oint_data_len+oint_data_shift)-1))>>oint_data_shift))
    5267. 

  5267. #else
    5268. 

  5268.   /* Long constants are slower than shifts on a SPARC-processor: */
    5269. 

  5269.   #define posfixnum_to_V(obj)  \
    5270. 

  5270.     ((uintV)((as_oint(obj) << (32-oint_data_len-oint_data_shift)) >> (32-oint_data_len)))
    5271. 

  5271. #endif
    5272. 

  5272. %% export_def(posfixnum_to_V(obj));
    5273. 

  5273. 

  5274. /* Value of a negative fixnum:
    5275. 

  5275.  negfixnum_to_V(obj)
    5276. 

  5276.  Result is >= - 2^oint_data_len, < 0. */
    5277. 

  5277. #define negfixnum_to_V(obj)  (posfixnum_to_V(obj) | (-vbitm(oint_data_len)))
    5278. 

  5278. %% #if notused
    5279. 

  5279. %% export_def(negfixnum_to_V(obj));
    5280. 

  5280. %% #endif
    5281. 

  5281. 

  5282. /* Absolute value of a negative fixnum:
    5283. 

  5283.  negfixnum_abs_V(obj)
    5284. 

  5284.  Result is > 0, <= 2^oint_data_len.
    5285. 

  5285.  Beware: Possible wraparound at oint_data_len=intVsize! */
    5286. 

  5286. #define negfixnum_abs_V(obj)  \
    5287. 

  5287.   ((uintV)((as_oint(fixnum_inc(Fixnum_minus1,1))-as_oint(obj))>>oint_data_shift))
    5288. 

  5288. 

  5289. /* Value of a fixnum, obj should be a variable:
    5290. 

  5290.  fixnum_to_V(obj)
    5291. 

  5291.  Result is >= - 2^oint_data_len, < 2^oint_data_len and of Type sintV.
    5292. 

  5292.  This macro should only be used for oint_data_len+1 <= intLsize! */
    5293. 

  5293. #if (oint_data_len>=intVsize)
    5294. 

  5294.   /* No space left for the sign-bit, thus fixnum_to_V = posfixnum_to_V = negfixnum_to_V ! */
    5295. 

  5295.   #define fixnum_to_V(obj)  (sintV)posfixnum_to_V(obj)
    5296. 

  5296. #elif (sign_bit_o == oint_data_len+oint_data_shift)
    5297. 

  5297.   #define fixnum_to_V(obj)  \
    5298. 

  5298.     (((sintV)as_oint(obj) << (intVsize-1-sign_bit_o)) >> (intVsize-1-sign_bit_o+oint_data_shift))
    5299. 

  5299. #else
    5300. 

  5300.   #if !defined(SPARC)
    5301. 

  5301.     #define fixnum_to_V(obj)  \
    5302. 

  5302.       (sintV)( ((((sintV)as_oint(obj) >> sign_bit_o) << (intVsize-1)) >> (intVsize-1-oint_data_len)) \
    5303. 

  5303.               |((uintV)((as_oint(obj) & ((oint)wbitm(oint_data_len+oint_data_shift)-1)) >> oint_data_shift)) \
    5304. 

  5304.              )
    5305. 

  5305.   #else
    5306. 

  5306.     /* Long constants are slower than shifts on a SPARC-processor: */
    5307. 

  5307.     #define fixnum_to_V(obj)  \
    5308. 

  5308.       (sintV)( ((((sintV)as_oint(obj) >> sign_bit_o) << (intVsize-1)) >> (intVsize-1-oint_data_len)) \
    5309. 

  5309.               |(((uintV)as_oint(obj) << (intVsize-oint_data_len-oint_data_shift)) >> (intVsize-oint_data_len)) \
    5310. 

  5310.              )
    5311. 

  5311.   #endif
    5312. 

  5312. #endif
    5313. 

  5313. %% export_def(fixnum_to_V(obj));
    5314. 

  5314. 

  5315. #ifdef intQsize
    5316. 

  5316.   /* Value of a fixnum, obj should be a variable:
    5317. 

  5317.    fixnum_to_Q(obj)
    5318. 

  5318.    Result is >= - 2^oint_data_len, < 2^oint_data_len. */
    5319. 

  5319.   #if (sign_bit_o == oint_data_len+oint_data_shift)
    5320. 

  5320.     #define fixnum_to_Q(obj)  \
    5321. 

  5321.       (((sintQ)as_oint(obj) << (intQsize-1-sign_bit_o)) >> (intQsize-1-sign_bit_o+oint_data_shift))
    5322. 

  5322.   #else
    5323. 

  5323.     #define fixnum_to_Q(obj)  \
    5324. 

  5324.       (sintQ)( ((((sintQ)as_oint(obj) >> sign_bit_o) << (intQsize-1)) >> (intQsize-1-oint_data_len)) \
    5325. 

  5325.               |((uintQ)((as_oint(obj) & (wbitm(oint_data_len+oint_data_shift)-1)) >> oint_data_shift)) \
    5326. 

  5326.              )
    5327. 

  5327.   #endif
    5328. 

  5328. #endif
    5329. 

  5329. 

  5330. /* Add a constant to a non-negative fixnum, given that
    5331. 

  5331.  the result is a non-negative fixnum as well:
    5332. 

  5332.  fixnum_inc(obj,delta)
    5333. 

  5333.  > obj: a fixnum
    5334. 

  5334.  > delta: a constant
    5335. 

  5335.  < result: incremented fixnum */
    5336. 

  5336. #define fixnum_inc(obj,delta)                                           \
    5337. 

  5337.     objectplus(obj, (soint)(delta) << oint_data_shift)
    5338. 

  5338. %% export_def(fixnum_inc(obj,delta));
    5339. 

  5339. 

  5340. /* posfixnum(x) is a fixnum with value x>=0. */
    5341. 

  5341. #define posfixnum(x)  fixnum_inc(Fixnum_0,x)
    5342. 

  5342. %% export_def(posfixnum(x));
    5343. 

  5343. 

  5344. /* negfixnum(x) is a fixnum with value x<0.
    5345. 

  5345.  (Beware if x is unsigned!) */
    5346. 

  5346. #define negfixnum(x)  fixnum_inc(fixnum_inc(Fixnum_minus1,1),x)
    5347. 

  5347. %% export_def(negfixnum(x));
    5348. 

  5348. 

  5349. /* sfixnum(x) is a fixnum with value x,
    5350. 

  5350.  x is a constant-expression with -2^oint_data_len <= x < 2^oint_data_len. */
    5351. 

  5351. #define sfixnum(x) ((x)>=0 ? posfixnum(x) : negfixnum(x))
    5352. 

  5352. %% export_def(sfixnum(x));
    5353. 

  5353. 

  5354. /* Convert a character into a fixnum >=0 (the same as for char-int): */
    5355. 

  5355. #ifdef WIDE_STRUCT
    5356. 

  5356.   #define char_to_fixnum(obj)  \
    5357. 

  5357.     type_data_object(fixnum_type,untype(obj))
    5358. 

  5358. #else
    5359. 

  5359.   #define char_to_fixnum(obj)  \
    5360. 

  5360.     objectplus(obj,type_zero_oint(fixnum_type)-type_zero_oint(char_type))
    5361. 

  5361. #endif
    5362. 

  5362. 

  5363. /* Make a character from a fitting fixnum >=0 (the same as for int-char): */
    5364. 

  5364. #ifdef WIDE_STRUCT
    5365. 

  5365.   #define fixnum_to_char(obj)  \
    5366. 

  5366.     type_data_object(char_type,untype(obj))
    5367. 

  5367. #else
    5368. 

  5368.   #define fixnum_to_char(obj)  \
    5369. 

  5369.     objectplus(obj,type_zero_oint(char_type)-type_zero_oint(fixnum_type))
    5370. 

  5370. #endif
    5371. 

  5371. 

  5372. /* Bignums */
    5373. 

  5373. typedef struct {
    5374. 

  5374.   VAROBJECT_HEADER  /* self-pointer for GC */
    5375. 

  5375.   #ifdef TYPECODES
    5376. 

  5376.   uintC length;     /* length in digits */
    5377. 

  5377.   #endif
    5378. 

  5378.   uintD data[unspecified]; /* number as its two's complement representation */
    5379. 

  5379. } bignum_;
    5380. 

  5380. typedef bignum_ *  Bignum;
    5381. 

  5381. /* The length is actually an uintWC. */
    5382. 

  5382. #ifdef TYPECODES
    5383. 

  5383.   #define bignum_length(ptr)  ((ptr)->length)
    5384. 

  5384. #else
    5385. 

  5385.   #define bignum_length(ptr)  srecord_length(ptr)
    5386. 

  5386. #endif
    5387. 

  5387. #define Bignum_length(obj)  bignum_length(TheBignum(obj))
    5388. 

  5388. %% #ifdef TYPECODES
    5389. 

  5389. %%   emit_typedef("struct { VAROBJECT_HEADER uintC length; uintD data[unspecified]; }","bignum_");
    5390. 

  5390. %% #else
    5391. 

  5391. %%   emit_typedef("struct { VAROBJECT_HEADER uintD data[unspecified]; }","bignum_");
    5392. 

  5392. %% #endif
    5393. 

  5393. %% emit_typedef("bignum_ *","Bignum");
    5394. 

  5394. %% export_def(bignum_length(ptr));
    5395. 

  5395. %% export_def(Bignum_length(obj));
    5396. 

  5396. 

  5397. /* Single-Floats */
    5398. 

  5398. typedef uint32 ffloat; /* 32-Bit-Float in IEEE-format */
    5399. 

  5399. typedef union {
    5400. 

  5400.   ffloat eksplicit;    /* Value, explicit */
    5401. 

  5401.   #ifdef FAST_FLOAT
    5402. 

  5402.   float machine_float; /* Value, as C-'float' */
    5403. 

  5403.   #endif
    5404. 

  5404. } ffloatjanus;
    5405. 

  5405. #if !defined(IMMEDIATE_FFLOAT)
    5406. 

  5406. typedef struct {
    5407. 

  5407.   VAROBJECT_HEADER            /* self-pointer for GC */
    5408. 

  5408.   ffloatjanus representation; /* Value */
    5409. 

  5409. } ffloat_;
    5410. 

  5410. typedef ffloat_ *  Ffloat;
    5411. 

  5411. #define ffloat_value(obj)  (TheFfloat(obj)->float_value)
    5412. 

  5412. #else
    5413. 

  5413. /* The float-value is stored in the pointer itself, like short-floats. */
    5414. 

  5414. #define ffloat_value(obj)  ((ffloat)untype(obj))
    5415. 

  5415. #endif
    5416. 

  5416. %% emit_typedef("uint32","ffloat");
    5417. 

  5417. %% emit_typedef("union { ffloat eksplicit; }","ffloatjanus");
    5418. 

  5418. 

  5419. /* Double-Floats */
    5420. 

  5420. typedef /* 64-Bit-Float in IEEE-format: */
    5421. 

  5421.         #ifdef intQsize
    5422. 

  5422.           /* Sign/Exponent/Mantissa */
    5423. 

  5423.           uint64
    5424. 

  5424.         #else
    5425. 

  5425.           /* Sign/Exponent/MantissaHigh and MantissaLow */
    5426. 

  5426.           #if BIG_ENDIAN_P || defined(ARM)
    5427. 

  5427.             struct {uint32 semhi,mlo;}
    5428. 

  5428.           #else
    5429. 

  5429.             struct {uint32 mlo,semhi;}
    5430. 

  5430.           #endif
    5431. 

  5431.         #endif
    5432. 

  5432.   dfloat;
    5433. 

  5433. typedef union {
    5434. 

  5434.   dfloat eksplicit;      /* Value, explicit */
    5435. 

  5435.   #ifdef FAST_DOUBLE
    5436. 

  5436.   double machine_double; /* Value, as C-'double' */
    5437. 

  5437.   #endif
    5438. 

  5438. } dfloatjanus;
    5439. 

  5439. typedef struct {
    5440. 

  5440.   VAROBJECT_HEADER            /* self-pointer for GC */
    5441. 

  5441.   dfloatjanus representation; /* value */
    5442. 

  5442. } dfloat_;
    5443. 

  5443. typedef dfloat_ *  Dfloat;
    5444. 

  5444. %% #ifdef intQsize
    5445. 

  5445. %%   emit_typedef("uint64","dfloat");
    5446. 

  5446. %% #else
    5447. 

  5447. %%   #if BIG_ENDIAN_P
    5448. 

  5448. %%     emit_typedef("struct {uint32 semhi,mlo;}","dfloat");
    5449. 

  5449. %%   #else
    5450. 

  5450. %%     emit_typedef("struct {uint32 mlo,semhi;}","dfloat");
    5451. 

  5451. %%   #endif
    5452. 

  5452. %% #endif
    5453. 

  5453. %% emit_typedef("union { dfloat eksplicit; }","dfloatjanus");
    5454. 

  5454. 

  5455. /* Single- and Double-Floats */
    5456. 

  5456.   #define float_value  representation.eksplicit
    5457. 

  5457. 

  5458. /* Long-Floats */
    5459. 

  5459. typedef struct {
    5460. 

  5460.   VAROBJECT_HEADER   /* Self-pointer for GC */
    5461. 

  5461.   #ifdef TYPECODES
    5462. 

  5462.   uintC  len;        /* length of the mantissa in digits */
    5463. 

  5463.   #endif
    5464. 

  5464.   uint32 expo;       /* exponent */
    5465. 

  5465.   uintD  data[unspecified]; /* mantissa */
    5466. 

  5466. } lfloat_;
    5467. 

  5467. typedef lfloat_ *  Lfloat;
    5468. 

  5468. /* The length is actually an uintWC. */
    5469. 

  5469. #ifdef TYPECODES
    5470. 

  5470.   #define lfloat_length(ptr)  ((ptr)->len)
    5471. 

  5471. #else
    5472. 

  5472.   #define lfloat_length(ptr)  srecord_length(ptr)
    5473. 

  5473. #endif
    5474. 

  5474. #define Lfloat_length(obj)  lfloat_length(TheLfloat(obj))
    5475. 

  5475. 

  5476. /* simple array (cover simple linear arrays: simple bit vector, simple vector) */
    5477. 

  5477. typedef struct {
    5478. 

  5478.   VRECORD_HEADER /* Self-pointer for GC, length in elements */
    5479. 

  5479. } sarray_;
    5480. 

  5480. typedef sarray_ *  Sarray;
    5481. 

  5481. #define sarray_length(ptr)  vrecord_length(ptr)
    5482. 

  5482. #define Sarray_length(obj)  sarray_length(TheSarray(obj))
    5483. 

  5483. %% #if notused
    5484. 

  5484. %% emit_typedef("struct { VRECORD_HEADER }","sarray_");
    5485. 

  5485. %% emit_typedef("sarray_ *","Sarray");
    5486. 

  5486. %% #endif
    5487. 

  5487. %% export_def(sarray_length(ptr));
    5488. 

  5488. %% export_def(Sarray_length(obj));
    5489. 

  5489. 

  5490. /* simple bit vector */
    5491. 

  5491. typedef struct {
    5492. 

  5492.   VRECORD_HEADER /* self-pointer for GC, length in bits */
    5493. 

  5493.   uint8  data[unspecified]; /* Bits, divided into bytes */
    5494. 

  5494. } sbvector_;
    5495. 

  5495. typedef sbvector_ *  Sbvector;
    5496. 

  5496. #define sbvector_length(ptr)  sarray_length(ptr)
    5497. 

  5497. #define Sbvector_length(obj)  sbvector_length(TheSbvector(obj))
    5498. 

  5498. %% emit_typedef("struct { VRECORD_HEADER uint8  data[unspecified]; }","sbvector_");
    5499. 

  5499. %% emit_typedef("sbvector_ *","Sbvector");
    5500. 

  5500. %% export_def(sbvector_length(ptr));
    5501. 

  5501. %% export_def(Sbvector_length(obj));
    5502. 

  5502. 

  5503. /* simple string template */
    5504. 

  5504. #ifdef TYPECODES
    5505. 

  5505.   #define SSTRING_HEADER  \
    5506. 

  5506.                  VAROBJECT_HEADER /* self-pointer for GC  */\
    5507. 

  5507.                  uintL tfl;       /* type, flags, length */
    5508. 

  5508. #else
    5509. 

  5509.   #define SSTRING_HEADER  \
    5510. 

  5510.                  VAROBJECT_HEADER /* self-pointer for GC, tfl */
    5511. 

  5511. #endif
    5512. 

  5512. typedef struct {
    5513. 

  5513.   SSTRING_HEADER
    5514. 

  5514. } sstring_;
    5515. 

  5515. typedef sstring_ *  Sstring;
    5516. 

  5516. #define STRUCT_SSTRING(cint_type) \
    5517. 

  5517.   struct {                                                                     \
    5518. 

  5518.     SSTRING_HEADER /* self-pointer for GC, type+flags, length in characters */ \
    5519. 

  5519.     cint_type  data[unspecified];  /* characters */                            \
    5520. 

  5520.   }
    5521. 

  5521. #ifdef HAVE_SMALL_SSTRING
    5522. 

  5522.   typedef STRUCT_SSTRING(cint8)  s8string_;
    5523. 

  5523.   typedef s8string_ *  S8string;
    5524. 

  5524.   typedef STRUCT_SSTRING(cint16)  s16string_;
    5525. 

  5525.   typedef s16string_ *  S16string;
    5526. 

  5526.   typedef STRUCT_SSTRING(cint32)  s32string_;
    5527. 

  5527.   typedef s32string_ *  S32string;
    5528. 

  5528. #else
    5529. 

  5529.   /* Only one kind of simple strings. */
    5530. 

  5530.   #ifdef UNICODE
    5531. 

  5531.     typedef STRUCT_SSTRING(cint32)  s32string_;
    5532. 

  5532.     typedef s32string_ *  S32string;
    5533. 

  5533.     /* Aliases. */
    5534. 

  5534.     typedef s32string_  s16string_;
    5535. 

  5535.     typedef S32string  S16string;
    5536. 

  5536.     typedef s32string_  s8string_;
    5537. 

  5537.     typedef S32string  S8string;
    5538. 

  5538.   #else
    5539. 

  5539.     typedef STRUCT_SSTRING(cint8)  s8string_;
    5540. 

  5540.     typedef s8string_ *  S8string;
    5541. 

  5541.     /* Aliases. */
    5542. 

  5542.     typedef s8string_  s16string_;
    5543. 

  5543.     typedef S8string  S16string;
    5544. 

  5544.     typedef s8string_  s32string_;
    5545. 

  5545.     typedef S8string  S32string;
    5546. 

  5546.   #endif
    5547. 

  5547. #endif
    5548. 

  5548. /* A "normal simple string" is one of maximum-width element type.
    5549. 

  5549.  It cannot be reallocated. Only strings with smaller element type
    5550. 

  5550.  (called "small simple strings") can be reallocated. */
    5551. 

  5551.   typedef STRUCT_SSTRING(chart)  snstring_;
    5552. 

  5552.   typedef snstring_ *  Snstring;
    5553. 

  5553. /* These accessors work on any simple string, except reallocated simple-strings. */
    5554. 

  5554. #ifdef TYPECODES
    5555. 

  5555.   #define sstring_length(ptr)  ((ptr)->tfl >> 6)
    5556. 

  5556. #else
    5557. 

  5557.   #define sstring_length(ptr)  ((ptr)->tfl >> 10)
    5558. 

  5558. #endif
    5559. 

  5559. #define Sstring_length(obj)  sstring_length(TheSstring(obj))
    5560. 

  5560. /* Maximum allowed simple-string length: */
    5561. 

  5561. #ifdef TYPECODES
    5562. 

  5562.   #define stringsize_limit_1  ((uintL)(bit(intLsize-6)-1))
    5563. 

  5563. #else
    5564. 

  5564.   #define stringsize_limit_1  ((uintL)(bit(intLsize-10)-1))
    5565. 

  5565. #endif
    5566. 

  5566. /* Constructing the tfl word: */
    5567. 

  5567. #ifdef TYPECODES
    5568. 

  5568.   #define sstring_tfl(eltype,imm,flags,length)  \
    5569. 

  5569.     (((length) << 6) + ((eltype) << 4) + ((imm) << 3) + (flags))
    5570. 

  5570. #else
    5571. 

  5571.   /* This must be consistent with vrecord_tfl. */
    5572. 

  5572.   #define sstringrecord_tfl(rectype,flags,length)  \
    5573. 

  5573.     (((length) << 10) + ((flags) << 8) + (rectype))
    5574. 

  5574.   #define sstring_tfl(eltype,imm,flags,length)  \
    5575. 

  5575.     sstringrecord_tfl(Rectype_S8string + ((eltype) << 1) + (imm),flags,length)
    5576. 

  5576. #endif
    5577. 

  5577. /* Test whether a simple string is reallocated: */
    5578. 

  5578. #ifdef HAVE_SMALL_SSTRING
    5579. 

  5579.   #ifdef TYPECODES
    5580. 

  5580.     #define sstringflags_forwarded_B  bit(2)
    5581. 

  5581.     #define sstring_reallocatedp(ptr)  ((ptr)->tfl & sstringflags_forwarded_B)
    5582. 

  5582.   #else
    5583. 

  5583.     #define sstring_reallocatedp(ptr)  (record_type(ptr) == Rectype_reallocstring)
    5584. 

  5584.   #endif
    5585. 

  5585. #else
    5586. 

  5586.   #define sstring_reallocatedp(ptr)  0
    5587. 

  5587. #endif
    5588. 

  5588. /* Extract the element type of a not-reallocated simple string: */
    5589. 

  5589. #ifdef TYPECODES
    5590. 

  5590.   #define sstring_eltype(ptr)  (((ptr)->tfl >> 4) & 3)
    5591. 

  5591. #else
    5592. 

  5592.   #define sstring_eltype(ptr)  ((record_type(ptr) - Rectype_S8string) >> 1)
    5593. 

  5593. #endif
    5594. 

  5594. /* Possible values of sstring_eltype: */
    5595. 

  5595.   #define Sstringtype_8Bit   0
    5596. 

  5596.   #define Sstringtype_16Bit  1
    5597. 

  5597.   #define Sstringtype_32Bit  2
    5598. 

  5598. /* Extract the immutable bit of a simple string (reallocated or not): */
    5599. 

  5599. #ifdef TYPECODES
    5600. 

  5600.   #define sstring_immutable(ptr)  (((ptr)->tfl >> 3) & 1)
    5601. 

  5601. #else
    5602. 

  5602.   #define sstring_immutable(ptr)  ((record_type(ptr) - Rectype_S8string) & 1)
    5603. 

  5603. #endif
    5604. 

  5604. /* Extract the flags of a simple string (reallocated or not): */
    5605. 

  5605. #ifdef TYPECODES
    5606. 

  5606.   /* Three bits, containing also sstringflags_forwarded_B. */
    5607. 

  5607.   #define sstring_flags(ptr)  ((ptr)->tfl & 7)
    5608. 

  5608.   #define sstring_flags_clr(ptr,bits)  ((ptr)->tfl &= ~(uintL)(bits))
    5609. 

  5609.   #define sstring_flags_set(ptr,bits)  ((ptr)->tfl |= (uintL)(bits))
    5610. 

  5610. #else
    5611. 

  5611.   #define sstring_flags(ptr)  (((ptr)->tfl >> 8) & 3)
    5612. 

  5612.   #define sstring_flags_clr(ptr,bits)  ((ptr)->tfl &= ~((uintL)(bits) << 8))
    5613. 

  5613.   #define sstring_flags_set(ptr,bits)  ((ptr)->tfl |= ((uintL)(bits) << 8))
    5614. 

  5614. #endif
    5615. 

  5615. /* Bit masks in the flags. Only used during garbage collection. */
    5616. 

  5616.   #define sstringflags_backpointer_B  bit(0)
    5617. 

  5617.   #define sstringflags_relocated_B    bit(1)
    5618. 

  5618.   #define mark_sstring_clean(ptr)  \
    5619. 

  5619.     sstring_flags_clr(ptr,sstringflags_backpointer_B|sstringflags_relocated_B)
    5620. 

  5620. %% export_def(SSTRING_HEADER);
    5621. 

  5621. %% emit_typedef("struct { SSTRING_HEADER }","sstring_");
    5622. 

  5622. %% emit_typedef("sstring_ *","Sstring");
    5623. 

  5623. %% #ifdef HAVE_SMALL_SSTRING
    5624. 

  5624. %%   export_def(STRUCT_SSTRING(cint_type));
    5625. 

  5625. %%   emit_typedef("STRUCT_SSTRING(cint8)","s8string_");
    5626. 

  5626. %%   emit_typedef("s8string_ *","S8string");
    5627. 

  5627. %%   emit_typedef("STRUCT_SSTRING(cint16)","s16string_");
    5628. 

  5628. %%   emit_typedef("s16string_ *","S16string");
    5629. 

  5629. %%   emit_typedef("STRUCT_SSTRING(cint32)","s32string_");
    5630. 

  5630. %%   emit_typedef("s32string_ *","S32string");
    5631. 

  5631. %% #endif
    5632. 

  5632. %% emit_typedef("struct { SSTRING_HEADER chart data[unspecified]; }","snstring_");
    5633. 

  5633. %% emit_typedef("snstring_*","Snstring");
    5634. 

  5634. %% export_def(sstring_length(ptr));
    5635. 

  5635. %% export_def(Sstring_length(obj));
    5636. 

  5636. %% export_def(sstring_eltype(ptr));
    5637. 

  5637. 

  5638. /* simple vector */
    5639. 

  5639. typedef struct {
    5640. 

  5640.   VRECORD_HEADER /* self-pointer for GC, length in objects */
    5641. 

  5641.   gcv_object_t data[unspecified] _attribute_aligned_object_; /* elements */
    5642. 

  5642. } svector_;
    5643. 

  5643. typedef svector_ *  Svector;
    5644. 

  5644. #define svector_length(ptr)  sarray_length(ptr)
    5645. 

  5645. #define Svector_length(obj)  svector_length(TheSvector(obj))
    5646. 

  5646. %% sprintf(buf,"struct { VRECORD_HEADER gcv_object_t data[unspecified]%s; }",attribute_aligned_object);
    5647. 

  5647. %% emit_typedef(buf,"svector_");
    5648. 

  5648. %% emit_typedef("svector_ *","Svector");
    5649. 

  5649. 

  5650. /* simple indirect string */
    5651. 

  5651. typedef struct {
    5652. 

  5652.   SSTRING_HEADER   /* self-pointer for GC, tfl */
    5653. 

  5653.   gcv_object_t data _attribute_aligned_object_; /* data vector */
    5654. 

  5654. } sistring_;
    5655. 

  5655. typedef sistring_ *  Sistring;
    5656. 

  5656. #define sistring_data_offset  offsetof(sistring_,data)
    5657. 

  5657. 

  5658. /* non-simple indirect Array */
    5659. 

  5659. typedef struct {
    5660. 

  5660.   VAROBJECT_HEADER   /* self-pointer for GC */
    5661. 

  5661.   #ifdef TYPECODES
    5662. 

  5662.   uintB flags;       /* flags */
    5663. 

  5663.   uintC rank;        /* rank n */
    5664. 

  5664.   #endif
    5665. 

  5665.   gcv_object_t data _attribute_aligned_object_; /* data vector */
    5666. 

  5666.   uintL totalsize;   /* totalsize = product of the n dimensions */
    5667. 

  5667.   uintL dims[unspecified]; /* poss. displaced-offset, n dimensions, poss. fill-pointer */
    5668. 

  5668. } iarray_;
    5669. 

  5669. typedef iarray_ *  Iarray;
    5670. 

  5670. #define iarray_data_offset  offsetof(iarray_,data)
    5671. 

  5671. /* The rank is actually an uintWC.
    5672. 

  5672.  access Rang, Flags: */
    5673. 

  5673. #ifdef TYPECODES
    5674. 

  5674.   #define iarray_rank(ptr)  ((ptr)->rank)
    5675. 

  5675. #else
    5676. 

  5676.   #define iarray_rank(ptr)  srecord_length(ptr)
    5677. 

  5677. #endif
    5678. 

  5678. #define Iarray_rank(obj)  iarray_rank(TheIarray(obj))
    5679. 

  5679. #ifdef TYPECODES
    5680. 

  5680.   #define iarray_flags(ptr)  ((ptr)->flags)
    5681. 

  5681. #else
    5682. 

  5682.   #define iarray_flags(ptr)  record_flags(ptr)
    5683. 

  5683. #endif
    5684. 

  5684. #define Iarray_flags(obj)  iarray_flags(TheIarray(obj))
    5685. 

  5685. #ifdef TYPECODES
    5686. 

  5686.   #define iarray_flags_clr(ptr,bits)  ((ptr)->flags &= ~(bits))
    5687. 

  5687.   #define iarray_flags_set(ptr,bits)  ((ptr)->flags |= (bits))
    5688. 

  5688.   #define iarray_flags_replace(ptr,newflags)  ((ptr)->flags = (newflags))
    5689. 

  5689. #else
    5690. 

  5690.   #define iarray_flags_clr(ptr,bits)  record_flags_clr(ptr,bits)
    5691. 

  5691.   #define iarray_flags_set(ptr,bits)  record_flags_set(ptr,bits)
    5692. 

  5692.   #define iarray_flags_replace(ptr,newflags) record_flags_replace(ptr,newflags)
    5693. 

  5693. #endif
    5694. 

  5694. /* Bits in the Flags: */
    5695. 

  5695. #define arrayflags_adjustable_bit  7 /* set, if array is adjustable */
    5696. 

  5696. #define arrayflags_fillp_bit       6 /* set, if a fill-pointer exists (only possible for n=1) */
    5697. 

  5697. #define arrayflags_displaced_bit   5 /* set, if array is displaced */
    5698. 

  5698. #define arrayflags_dispoffset_bit  4 /* set, if there is space for the
    5699. 

  5699.                                         displaced-offset
    5700. 

  5700.                                         (<==> array adjustable or displaced) */
    5701. 

  5701. #define arrayflags_atype_mask  0x0F  /* mask for the element-type */
    5702. 

  5702. /* Element-types of arrays in Bits 3..0 of its flags:
    5703. 

  5703.  The first ones are chosen, so that 2^Atype_nBit = n. */
    5704. 

  5704. #define Atype_Bit    0  /* storage vector is of type sbvector_type */
    5705. 

  5705. #define Atype_2Bit   1  /* storage vector is of type sb2vector_type */
    5706. 

  5706. #define Atype_4Bit   2  /* storage vector is of type sb4vector_type */
    5707. 

  5707. #define Atype_8Bit   3  /* storage vector is of type sb8vector_type */
    5708. 

  5708. #define Atype_16Bit  4  /* storage vector is of type sb16vector_type */
    5709. 

  5709. #define Atype_32Bit  5  /* storage vector is of type sb32vector_type */
    5710. 

  5710. #define Atype_T      6  /* storage vector is of type svector_type */
    5711. 

  5711. #define Atype_Char   7  /* storage vector is of type sstring_type */
    5712. 

  5712. #define Atype_NIL    8  /* storage vector is NIL */
    5713. 

  5713. %% export_def(Atype_Bit);
    5714. 

  5714. %% export_def(Atype_8Bit);
    5715. 

  5715. %% export_def(Atype_32Bit);
    5716. 

  5716. %% export_def(Atype_T);
    5717. 

  5717. 

  5718. /* array-types */
    5719. 

  5719. #ifdef TYPECODES
    5720. 

  5720.   #define Array_type(obj)  typecode(obj)
    5721. 

  5721.   #define Array_type_bvector     bvector_type      /* Iarray */
    5722. 

  5722.   #define Array_type_b2vector    b2vector_type     /* Iarray */
    5723. 

  5723.   #define Array_type_b4vector    b4vector_type     /* Iarray */
    5724. 

  5724.   #define Array_type_b8vector    b8vector_type     /* Iarray */
    5725. 

  5725.   #define Array_type_b16vector   b16vector_type    /* Iarray */
    5726. 

  5726.   #define Array_type_b32vector   b32vector_type    /* Iarray */
    5727. 

  5727.   #define Array_type_string      string_type       /* Iarray */
    5728. 

  5728.   #define Array_type_vector      vector_type       /* Iarray */
    5729. 

  5729.   #define Array_type_mdarray     mdarray_type      /* Iarray */
    5730. 

  5730.   #define Array_type_sbvector    sbvector_type     /* Sbvector */
    5731. 

  5731.   #define Array_type_sb2vector   sb2vector_type    /* Sbvector */
    5732. 

  5732.   #define Array_type_sb4vector   sb4vector_type    /* Sbvector */
    5733. 

  5733.   #define Array_type_sb8vector   sb8vector_type    /* Sbvector */
    5734. 

  5734.   #define Array_type_sb16vector  sb16vector_type   /* Sbvector */
    5735. 

  5735.   #define Array_type_sb32vector  sb32vector_type   /* Sbvector */
    5736. 

  5736.   #define Array_type_sstring     sstring_type      /* Sstring */
    5737. 

  5737.   #define Array_type_svector     svector_type      /* Svector */
    5738. 

  5738.   #define Array_type_snilvector  symbol_type       /* Symbol NIL */
    5739. 

  5739.   /* Array_type_simple_bit_vector(atype)
    5740. 

  5740.    maps Atype_[n]Bit to Array_type_sb[n]vector. Depends on TB0, TB1, TB2.
    5741. 

  5741.    The formula works because there are only 4 possible cases:
    5742. 

  5742.     (TB0,TB1,TB2)   formula
    5743. 

  5743.       (0, 1, 2)      atype
    5744. 

  5744.       (0, 1, 3)      atype + (atype & -4)
    5745. 

  5745.       (0, 2, 3)      atype + (atype & -2)
    5746. 

  5746.       (1, 2, 3)      atype + (atype & -1) = atype << 1 */
    5747. 

  5747.   #define Array_type_simple_bit_vector(atype)  \
    5748. 

  5748.     (Array_type_sbvector + ((atype)<<TB0) + ((atype)&(bit(TB0+1)-bit(TB1))) + ((atype)&(bit(TB1+1)-bit(TB2))))
    5749. 

  5749. #else
    5750. 

  5750.   #define Array_type(obj)  Record_type(obj)
    5751. 

  5751.   #define Array_type_bvector     Rectype_bvector     /* Iarray */
    5752. 

  5752.   #define Array_type_b2vector    Rectype_b2vector    /* Iarray */
    5753. 

  5753.   #define Array_type_b4vector    Rectype_b4vector    /* Iarray */
    5754. 

  5754.   #define Array_type_b8vector    Rectype_b8vector    /* Iarray */
    5755. 

  5755.   #define Array_type_b16vector   Rectype_b16vector   /* Iarray */
    5756. 

  5756.   #define Array_type_b32vector   Rectype_b32vector   /* Iarray */
    5757. 

  5757.   #define Array_type_string      Rectype_string      /* Iarray */
    5758. 

  5758.   #define Array_type_vector      Rectype_vector      /* Iarray */
    5759. 

  5759.   #define Array_type_mdarray     Rectype_mdarray     /* Iarray */
    5760. 

  5760.   #define Array_type_sbvector    Rectype_Sbvector    /* Sbvector */
    5761. 

  5761.   #define Array_type_sb2vector   Rectype_Sb2vector   /* Sbvector */
    5762. 

  5762.   #define Array_type_sb4vector   Rectype_Sb4vector   /* Sbvector */
    5763. 

  5763.   #define Array_type_sb8vector   Rectype_Sb8vector   /* Sbvector */
    5764. 

  5764.   #define Array_type_sb16vector  Rectype_Sb16vector  /* Sbvector */
    5765. 

  5765.   #define Array_type_sb32vector  Rectype_Sb32vector  /* Sbvector */
    5766. 

  5766.   #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 */
    5767. 

  5767.   #define Array_type_svector     Rectype_Svector     /* Svector */
    5768. 

  5768.   #define Array_type_snilvector  Rectype_Symbol      /* Symbol NIL */
    5769. 

  5769. #endif
    5770. 

  5770. /* Determining the atype of a [simple-]bit-array: */
    5771. 

  5771. #define sbNvector_atype(obj)  \
    5772. 

  5772.   type_bits_to_atype(Array_type(obj) - Array_type_sbvector)
    5773. 

  5773. #define bNvector_atype(obj)  \
    5774. 

  5774.   type_bits_to_atype(Array_type(obj) - Array_type_bvector)
    5775. 

  5775. #ifdef TYPECODES
    5776. 

  5776.   /* There are only 4 cases:
    5777. 

  5777.     (TB0,TB1,TB2)   formula
    5778. 

  5778.       (0, 1, 2)      type
    5779. 

  5779.       (0, 1, 3)      (type + (type & 3)) >> 1 = type - ((type & -8) >> 1)
    5780. 

  5780.       (0, 2, 3)      (type + (type & 1)) >> 1 = type - ((type & -4) >> 1)
    5781. 

  5781.       (1, 2, 3)      type >> 1                = type - ((type & -2) >> 1) */
    5782. 

  5782.   #if TB2 > 2
    5783. 

  5783.     #define type_bits_to_atype(type)  \
    5784. 

  5784.       (((type) + ((type)&(bit(6-TB0-TB1-TB2)-1))) >> 1)
    5785. 

  5785.   #else
    5786. 

  5786.     #define type_bits_to_atype(type)  (type)
    5787. 

  5787.   #endif
    5788. 

  5788. #else
    5789. 

  5789.   #define type_bits_to_atype(type)  (type)
    5790. 

  5790. #endif
    5791. 

  5791. %% #ifdef TYPECODES
    5792. 

  5792. %%  export_def(Array_type_simple_bit_vector(atype));
    5793. 

  5793. %% #endif
    5794. 

  5794. 

  5795. /* Packages */
    5796. 

  5796. typedef struct {
    5797. 

  5797.   XRECORD_HEADER
    5798. 

  5798.   gcv_object_t pack_external_symbols  _attribute_aligned_object_;
    5799. 

  5799.   gcv_object_t pack_internal_symbols  _attribute_aligned_object_;
    5800. 

  5800.   gcv_object_t pack_shadowing_symbols _attribute_aligned_object_;
    5801. 

  5801.   gcv_object_t pack_use_list          _attribute_aligned_object_;
    5802. 

  5802.   gcv_object_t pack_used_by_list      _attribute_aligned_object_;
    5803. 

  5803.   gcv_object_t pack_name              _attribute_aligned_object_;
    5804. 

  5804.   gcv_object_t pack_nicknames         _attribute_aligned_object_;
    5805. 

  5805.   gcv_object_t pack_docstring         _attribute_aligned_object_;
    5806. 

  5806.   gcv_object_t pack_shortest_name     _attribute_aligned_object_;
    5807. 

  5807. } *  Package;
    5808. 

  5808. #define package_length  ((sizeof(*(Package)0)-offsetofa(record_,recdata))/sizeof(gcv_object_t))
    5809. 

  5809. /* Some packages are case-sensitive. */
    5810. 

  5810. #define mark_pack_casesensitive(obj)  record_flags_set(ThePackage(obj),bit(0))
    5811. 

  5811. #define mark_pack_caseinsensitive(obj) record_flags_clr(ThePackage(obj),bit(0))
    5812. 

  5812. #define pack_casesensitivep(obj)      (record_flags(ThePackage(obj)) & bit(0))
    5813. 

  5813. /* Some packages are case-inverted. */
    5814. 

  5814. #define mark_pack_caseinverted(obj)  record_flags_set(ThePackage(obj),bit(1))
    5815. 

  5815. #define mark_pack_casepreserved(obj) record_flags_clr(ThePackage(obj),bit(1))
    5816. 

  5816. #define pack_caseinvertedp(obj)      (record_flags(ThePackage(obj)) & bit(1))
    5817. 

  5817. /* Some packages, such as COMMON-LISP, are locked. */
    5818. 

  5818. #define mark_pack_locked(obj)    record_flags_set(ThePackage(obj),bit(2))
    5819. 

  5819. #define mark_pack_unlocked(obj)  record_flags_clr(ThePackage(obj),bit(2))
    5820. 

  5820. #define pack_locked_p(obj)       (record_flags(ThePackage(obj)) & bit(2))
    5821. 

  5821. /* Do not do anything with deleted packages. */
    5822. 

  5822. #define mark_pack_deleted(obj)  record_flags_set(ThePackage(obj),bit(7))
    5823. 

  5823. #define pack_deletedp(obj)      (record_flags(ThePackage(obj)) & bit(7))
    5824. 

  5824. %% #if notused
    5825. 

  5825. %% 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; } *",attribute_aligned_object,attribute_aligned_object,attribute_aligned_object,attribute_aligned_object,attribute_aligned_object,attribute_aligned_object,attribute_aligned_object,attribute_aligned_object);
    5826. 

  5826. %% emit_typedef(buf,"Package");
    5827. 

  5827. %% #endif
    5828. 

  5828. 

  5829. /* Hash-Tables */
    5830. 

  5830. typedef struct {
    5831. 

  5831.   XRECORD_HEADER
    5832. 

  5832.   #ifdef GENERATIONAL_GC
    5833. 

  5833.   gcv_object_t ht_lastrehash         _attribute_aligned_object_;
    5834. 

  5834.   #endif
    5835. 

  5835.   gcv_object_t ht_maxcount           _attribute_aligned_object_;
    5836. 

  5836.   gcv_object_t ht_kvtable            _attribute_aligned_object_;
    5837. 

  5837.   gcv_object_t ht_lookupfn           _attribute_aligned_object_;
    5838. 

  5838.   gcv_object_t ht_hashcodefn         _attribute_aligned_object_;
    5839. 

  5839.   gcv_object_t ht_testfn             _attribute_aligned_object_;
    5840. 

  5840.   gcv_object_t ht_gcinvariantfn      _attribute_aligned_object_;
    5841. 

  5841.   gcv_object_t ht_rehash_size        _attribute_aligned_object_;
    5842. 

  5842.   gcv_object_t ht_mincount_threshold _attribute_aligned_object_;
    5843. 

  5843.   gcv_object_t ht_mincount           _attribute_aligned_object_;
    5844. 

  5844.   gcv_object_t ht_test               _attribute_aligned_object_; /* hash-table-test - for define-hash-table-test */
    5845. 

  5845.   gcv_object_t ht_hash               _attribute_aligned_object_; /* hash function */
    5846. 

  5846.   uintL ht_size;
    5847. 

  5847. } *  Hashtable;
    5848. 

  5848. #ifdef GENERATIONAL_GC
    5849. 

  5849.   #define hashtable_length  12
    5850. 

  5850. #else
    5851. 

  5851.   #define hashtable_length  11
    5852. 

  5852. #endif
    5853. 

  5853. #define hashtable_xlength  (sizeof(*(Hashtable)0)-offsetofa(record_,recdata)-hashtable_length*sizeof(gcv_object_t))
    5854. 

  5854. /* Mark a Hash Table as now to reorganize
    5855. 

  5855.  set_ht_invalid(TheHashtable(ht));
    5856. 

  5856.  mark_ht_invalid(TheHashtable(ht));
    5857. 

  5857.  A bit that is set when the list structure is invalid and a rehash is needed. */
    5858. 

  5858. #define htflags_invalid_B  bit(7)
    5859. 

  5859. /* A bit that is set if the table has a key whose hash code is not GC-invariant. */
    5860. 

  5860. #define htflags_gc_rehash_B  bit(6)
    5861. 

  5861. #ifdef GENERATIONAL_GC
    5862. 

  5862.   #define mark_ht_invalid(ptr)  \
    5863. 

  5863.     (record_flags_set(ptr,htflags_invalid_B), \
    5864. 

  5864.      (ptr)->ht_lastrehash = unbound)
    5865. 

  5865.   #define mark_ht_valid(ptr)  \
    5866. 

  5866.     (record_flags_clr(ptr,htflags_invalid_B), \
    5867. 

  5867.      (ptr)->ht_lastrehash = O(gc_count))
    5868. 

  5868.   #define ht_validp(ptr)  \
    5869. 

  5869.     ((record_flags(ptr) & htflags_invalid_B) == 0       \
    5870. 

  5870.      && ((record_flags(ptr) & htflags_gc_rehash_B) == 0 \
    5871. 

  5871.          || eq((ptr)->ht_lastrehash,O(gc_count))))
    5872. 

  5872. #else
    5873. 

  5873.   #define mark_ht_invalid(ptr)  record_flags_set(ptr,htflags_invalid_B)
    5874. 

  5874.   #define mark_ht_valid(ptr)  record_flags_clr(ptr,htflags_invalid_B)
    5875. 

  5875.   #define ht_validp(ptr)  ((record_flags(ptr) & htflags_invalid_B) == 0)
    5876. 

  5876. #endif
    5877. 

  5877. #ifdef GENERATIONAL_GC
    5878. 

  5878.   #define set_ht_invalid(ptr)  mark_ht_invalid(ptr)
    5879. 

  5879.   #define set_ht_valid(ptr)  mark_ht_valid(ptr)
    5880. 

  5880. #else
    5881. 

  5881.   extern bool hash_lookup_builtin (object ht, object obj, bool allowgc, gcv_object_t** KVptr_, gcv_object_t** Iptr_);
    5882. 

  5882.   extern bool hash_lookup_builtin_with_rehash (object ht, object obj, bool allowgc, gcv_object_t** KVptr_, gcv_object_t** Iptr_);
    5883. 

  5883.   #define set_ht_invalid(ptr)  \
    5884. 

  5884.     (mark_ht_invalid(ptr),                                               \
    5885. 

  5885.      eq((ptr)->ht_lookupfn,P(hash_lookup_builtin))                       \
    5886. 

  5886.      ? ((ptr)->ht_lookupfn = P(hash_lookup_builtin_with_rehash), 0) : 0)
    5887. 

  5887.   #define set_ht_valid(ptr)  \
    5888. 

  5888.     (mark_ht_valid(ptr),                                       \
    5889. 

  5889.      eq((ptr)->ht_lookupfn,P(hash_lookup_builtin_with_rehash)) \
    5890. 

  5890.      ? ((ptr)->ht_lookupfn = P(hash_lookup_builtin), 0) : 0)
    5891. 

  5891. #endif
    5892. 

  5892. #define set_ht_invalid_if_needed(ptr)  \
    5893. 

  5893.   if (record_flags(ptr) & htflags_gc_rehash_B) \
    5894. 

  5894.     set_ht_invalid(ptr)/*;*/
    5895. 

  5895. /* A bit that indicates whether to warn about this situation. */
    5896. 

  5896. #define htflags_warn_gc_rehash_B  bit(5)
    5897. 

  5897. /* Extract the part of the flags that encodes the test. */
    5898. 

  5898. #define ht_test_code(flags)  \
    5899. 

  5899.   (flags & (bit(0) | bit(1) | bit(2) | bit(3)))
    5900. 

  5900. /* Tests whether a test code indicates a user-defined test function. */
    5901. 

  5901. #define ht_test_code_user_p(test_code)  \
    5902. 

  5902.   (((test_code) & bit(2)) != 0)
    5903. 

  5903. /* Test whether a hash table is weak. */
    5904. 

  5904. #define ht_weak_p(ht)  \
    5905. 

  5905.   !simple_vector_p(TheHashtable(ht)->ht_kvtable)
    5906. 

  5906. /* The kvtable array is either a HashedAlist or a WeakHashedAlist.
    5907. 

  5907.  Both share the same layout, i.e.
    5908. 

  5908.    &((HashedAlist)0)->hal_data == &((WeakHashedAlist)0)->whal_data. */
    5909. 

  5909. typedef struct {
    5910. 

  5910.   VRECORD_HEADER /* self-pointer for GC, length in objects */
    5911. 

  5911.   gcv_object_t hal_filler            _attribute_aligned_object_; /* for consistency with WeakHashedAlist */
    5912. 

  5912.   gcv_object_t hal_itable            _attribute_aligned_object_; /* index-vector */
    5913. 

  5913.   gcv_object_t hal_count             _attribute_aligned_object_; /* remaining pairs */
    5914. 

  5914.   gcv_object_t hal_freelist          _attribute_aligned_object_; /* start index of freelist */
    5915. 

  5915.   gcv_object_t hal_data[unspecified] _attribute_aligned_object_; /* (key, value, next) triples */
    5916. 

  5916. } * HashedAlist;
    5917. 

  5917. /* TheHashedAlist is used to access both HashedAlist and WeakHashedAlist. */
    5918. 

  5918. #define TheHashedAlist(obj)  ((HashedAlist)TheVarobject(obj))
    5919. 

  5919. 

  5920. /* Readtables */
    5921. 

  5921. typedef struct {
    5922. 

  5922.   XRECORD_HEADER
    5923. 

  5923.   gcv_object_t readtable_syntax_table _attribute_aligned_object_;
    5924. 

  5924.   gcv_object_t readtable_macro_table  _attribute_aligned_object_;
    5925. 

  5925.   gcv_object_t readtable_case         _attribute_aligned_object_;
    5926. 

  5926. } *  Readtable;
    5927. 

  5927. #define readtable_length  ((sizeof(*(Readtable)0)-offsetofa(record_,recdata))/sizeof(gcv_object_t))
    5928. 

  5928. 

  5929. /* Pathnames */
    5930. 

  5930. typedef struct {
    5931. 

  5931.   XRECORD_HEADER
    5932. 

  5932.   #if HAS_HOST
    5933. 

  5933.     gcv_object_t pathname_host      _attribute_aligned_object_;
    5934. 

  5934.   #endif
    5935. 

  5935.   #if HAS_DEVICE
    5936. 

  5936.     gcv_object_t pathname_device    _attribute_aligned_object_;
    5937. 

  5937.   #endif
    5938. 

  5938.   #if 1
    5939. 

  5939.     gcv_object_t pathname_directory _attribute_aligned_object_;
    5940. 

  5940.     gcv_object_t pathname_name      _attribute_aligned_object_;
    5941. 

  5941.     gcv_object_t pathname_type      _attribute_aligned_object_;
    5942. 

  5942.     gcv_object_t pathname_version   _attribute_aligned_object_;
    5943. 

  5943.   #endif
    5944. 

  5944. } *  Pathname;
    5945. 

  5945. #define pathname_length  ((sizeof(*(Pathname)0)-offsetofa(record_,recdata))/sizeof(gcv_object_t))
    5946. 

  5946. 

  5947. #ifdef LOGICAL_PATHNAMES
    5948. 

  5948. /* Logical Pathnames */
    5949. 

  5949. typedef struct {
    5950. 

  5950.   XRECORD_HEADER
    5951. 

  5951.   gcv_object_t pathname_host      _attribute_aligned_object_;
    5952. 

  5952.   gcv_object_t pathname_directory _attribute_aligned_object_;
    5953. 

  5953.   gcv_object_t pathname_name      _attribute_aligned_object_;
    5954. 

  5954.   gcv_object_t pathname_type      _attribute_aligned_object_;
    5955. 

  5955.   gcv_object_t pathname_version   _attribute_aligned_object_;
    5956. 

  5956. } *  Logpathname;
    5957. 

  5957. #define logpathname_length  ((sizeof(*(Logpathname)0)-offsetofa(record_,recdata))/sizeof(gcv_object_t))
    5958. 

  5958. #endif
    5959. 

  5959. 

  5960. /* Random-States */
    5961. 

  5961. typedef struct {
    5962. 

  5962.   XRECORD_HEADER
    5963. 

  5963.   gcv_object_t random_state_seed _attribute_aligned_object_;
    5964. 

  5964. } *  Random_state;
    5965. 

  5965. #define random_state_length  ((sizeof(*(Random_state)0)-offsetofa(record_,recdata))/sizeof(gcv_object_t))
    5966. 

  5966. 

  5967. /* Bytes */
    5968. 

  5968. typedef struct {
    5969. 

  5969.   XRECORD_HEADER
    5970. 

  5970.   gcv_object_t byte_size     _attribute_aligned_object_;
    5971. 

  5971.   gcv_object_t byte_position _attribute_aligned_object_;
    5972. 

  5972. } *  Byte;
    5973. 

  5973. #define byte_length  ((sizeof(*(Byte)0)-offsetofa(record_,recdata))/sizeof(gcv_object_t))
    5974. 

  5974. 

  5975. /* Fsubrs */
    5976. 

  5976. typedef struct {
    5977. 

  5977.   XRECORD_HEADER
    5978. 

  5978.   gcv_object_t name    _attribute_aligned_object_;
    5979. 

  5979.   gcv_object_t argtype _attribute_aligned_object_;
    5980. 

  5980.   void* function; /* actually a fsubr_function_t* */
    5981. 

  5981. } *  Fsubr;
    5982. 

  5982. #define fsubr_length  2
    5983. 

  5983. #define fsubr_xlength  (sizeof(*(Fsubr)0)-offsetofa(record_,recdata)-fsubr_length*sizeof(gcv_object_t))
    5984. 

  5984. 

  5985. /* Load-time-evals */
    5986. 

  5986. typedef struct {
    5987. 

  5987.   XRECORD_HEADER
    5988. 

  5988.   gcv_object_t loadtimeeval_form _attribute_aligned_object_;
    5989. 

  5989. } *  Loadtimeeval;
    5990. 

  5990. #define loadtimeeval_length  ((sizeof(*(Loadtimeeval)0)-offsetofa(record_,recdata))/sizeof(gcv_object_t))
    5991. 

  5991. 

  5992. /* Symbol-macros */
    5993. 

  5993. typedef struct {
    5994. 

  5994.   XRECORD_HEADER
    5995. 

  5995.   gcv_object_t symbolmacro_expansion _attribute_aligned_object_;
    5996. 

  5996. } *  Symbolmacro;
    5997. 

  5997. #define symbolmacro_length  ((sizeof(*(Symbolmacro)0)-offsetofa(record_,recdata))/sizeof(gcv_object_t))
    5998. 

  5998. 

  5999. /* Global-Symbol-macros */
    6000. 

  6000. typedef struct {
    6001. 

  6001.   XRECORD_HEADER
    6002. 

  6002.   gcv_object_t globalsymbolmacro_definition _attribute_aligned_object_;
    6003. 

  6003. } *  GlobalSymbolmacro;
    6004. 

  6004. #define globalsymbolmacro_length  ((sizeof(*(GlobalSymbolmacro)0)-offsetofa(record_,recdata))/sizeof(gcv_object_t))
    6005. 

  6005. 

  6006. /* Macros */
    6007. 

  6007. typedef struct {
    6008. 

  6008.   XRECORD_HEADER
    6009. 

  6009.   gcv_object_t macro_expander _attribute_aligned_object_;
    6010. 

  6010.   gcv_object_t macro_lambda_list _attribute_aligned_object_;
    6011. 

  6011. } *  Macro;
    6012. 

  6012. #define macro_length  ((sizeof(*(Macro)0)-offsetofa(record_,recdata))/sizeof(gcv_object_t))
    6013. 

  6013. 

  6014. /* FunctionMacros */
    6015. 

  6015. typedef struct {
    6016. 

  6016.   XRECORD_HEADER
    6017. 

  6017.   gcv_object_t functionmacro_macro_expander _attribute_aligned_object_;
    6018. 

  6018.   gcv_object_t functionmacro_function       _attribute_aligned_object_;
    6019. 

  6019. } *  FunctionMacro;
    6020. 

  6020. #define functionmacro_length  ((sizeof(*(FunctionMacro)0)-offsetofa(record_,recdata))/sizeof(gcv_object_t))
    6021. 

  6021. 

  6022. /* BigReadLabel */
    6023. 

  6023. typedef struct {
    6024. 

  6024.   XRECORD_HEADER
    6025. 

  6025.   gcv_object_t brl_value _attribute_aligned_object_;
    6026. 

  6026. } *  BigReadLabel;
    6027. 

  6027. #define bigreadlabel_length  ((sizeof(*(BigReadLabel)0)-offsetofa(record_,recdata))/sizeof(gcv_object_t))
    6028. 

  6028. 

  6029. /* Encoding */
    6030. 

  6030. typedef struct {
    6031. 

  6031.   XRECORD_HEADER
    6032. 

  6032.   gcv_object_t enc_eol         _attribute_aligned_object_; /* line termination, a keyword (:UNIX, :MAC, :DOS) */
    6033. 

  6033.   gcv_object_t enc_towcs_error _attribute_aligned_object_; /* input error action, :ERROR or :IGNORE or a character */
    6034. 

  6034.   gcv_object_t enc_tombs_error _attribute_aligned_object_; /* output error action, :ERROR or :IGNORE or a character or an uint8 */
    6035. 

  6035.   #ifdef UNICODE
    6036. 

  6036.   gcv_object_t enc_charset     _attribute_aligned_object_; /* character set, a symbol in the CHARSET package or a simple-string */
    6037. 

  6037.   /* Functions to convert bytes to characters. */
    6038. 

  6038.     gcv_object_t enc_mblen     _attribute_aligned_object_; /* uintL (*) (object encoding, const uintB* src, const uintB* srcend); */
    6039. 

  6039.     gcv_object_t enc_mbstowcs  _attribute_aligned_object_; /* void (*) (object encoding, object stream, const uintB* *srcp, const uintB* srcend, chart* *destp, chart* destend); */
    6040. 

  6040.   /* Functions to convert characters to bytes. */
    6041. 

  6041.     gcv_object_t enc_wcslen    _attribute_aligned_object_; /* uintL (*) (object encoding, const chart* src, const chart* srcend); */
    6042. 

  6042.     gcv_object_t enc_wcstombs  _attribute_aligned_object_; /* void (*) (object encoding, object stream, const chart* *srcp, const chart* srcend, uintB* *destp, uintB* destend); */
    6043. 

  6043.   /* Function to return the set of defined characters in the range [start,end],
    6044. 

  6044.    as a simple-string of intervals #(start1 end1 ... startm endm). */
    6045. 

  6045.     gcv_object_t enc_range     _attribute_aligned_object_; /* object (*) (object encoding, uintL start, uintL end, uintL maxintervals); */
    6046. 

  6046.   /* An auxiliary pointer. */
    6047. 

  6047.   gcv_object_t enc_table       _attribute_aligned_object_;
    6048. 

  6048.   /* Minimum number of bytes needed to represent a character
    6049. 

  6049.    caveat: correct only for some encodings, defaults to 1 */
    6050. 

  6050.   uintL min_bytes_per_char;
    6051. 

  6051.   /* Maximum number of bytes needed to represent a character
    6052. 

  6052.    caveat: correct only for some encodings, defaults to 8 */
    6053. 

  6053.   uintL max_bytes_per_char;
    6054. 

  6054.   #endif
    6055. 

  6055. } *  Encoding;
    6056. 

  6056. #ifdef UNICODE
    6057. 

  6057.   #define encoding_length  10
    6058. 

  6058. #else
    6059. 

  6059.   #define encoding_length  3
    6060. 

  6060. #endif
    6061. 

  6061. #define encoding_xlength  (sizeof(*(Encoding)0)-offsetofa(record_,recdata)-encoding_length*sizeof(gcv_object_t))
    6062. 

  6062. #ifdef UNICODE
    6063. 

  6063.   #define Encoding_mblen(encoding)  ((uintL (*) (object, const uintB*, const uintB*)) ThePseudofun(TheEncoding(encoding)->enc_mblen))
    6064. 

  6064.   #define Encoding_mbstowcs(encoding)  ((void (*) (object, object, const uintB**, const uintB*, chart**, chart*)) ThePseudofun(TheEncoding(encoding)->enc_mbstowcs))
    6065. 

  6065.   #define Encoding_wcslen(encoding)  ((uintL (*) (object, const chart*, const chart*)) ThePseudofun(TheEncoding(encoding)->enc_wcslen))
    6066. 

  6066.   #define Encoding_wcstombs(encoding)  ((void (*) (object, object, const chart**, const chart*, uintB**, uintB*)) ThePseudofun(TheEncoding(encoding)->enc_wcstombs))
    6067. 

  6067.   #define Encoding_range(encoding)  ((object (*) (object, uintL, uintL, uintL)) ThePseudofun(TheEncoding(encoding)->enc_range))
    6068. 

  6068. #endif
    6069. 

  6069. #ifdef UNICODE
    6070. 

  6070.   #define cslen(encoding,src,srclen)  \
    6071. 

  6071.     Encoding_wcslen(encoding)(encoding,src,(src)+(srclen))
    6072. 

  6072.   #define cstombs_help_(encoding,src,srclen,dest,destlen,A)         \
    6073. 

  6073.     do { var const chart* _srcptr = (src);                          \
    6074. 

  6074.       var const chart* _srcendptr = _srcptr+(srclen);               \
    6075. 

  6075.       var uintB* _destptr = (dest);                                 \
    6076. 

  6076.       var uintB* _destendptr = _destptr+(destlen);                  \
    6077. 

  6077.       Encoding_wcstombs(encoding)(encoding,nullobj,&_srcptr,_srcendptr,&_destptr,_destendptr); \
    6078. 

  6078.       A((_srcptr == _srcendptr) && (_destptr == _destendptr)); \
    6079. 

  6079.     } while(0)
    6080. 

  6080. #else
    6081. 

  6081.   #define cslen(encoding,src,srclen)  (srclen)
    6082. 

  6082.   #define cstombs_help_(encoding,src,srclen,dest,destlen,A)           \
    6083. 

  6083.     do { A((srclen) == (destlen));                                   \
    6084. 

  6084.          begin_system_call(); memcpy(dest,src,srclen); end_system_call(); \
    6085. 

  6085.     } while(0)
    6086. 

  6086. #endif
    6087. 

  6087. #define cstombs(encoding,src,srclen,dest,destlen)  cstombs_help_(encoding,src,srclen,dest,destlen,ASSERT)
    6088. 

  6088. %% 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);
    6089. 

  6089. %% #ifdef UNICODE
    6090. 

  6090. %%   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);
    6091. 

  6091. %% #endif
    6092. 

  6092. %% strcat(buf," } *");
    6093. 

  6093. %% emit_typedef(buf,"Encoding");
    6094. 

  6094. %% #ifdef UNICODE
    6095. 

  6095. %%  export_def(Encoding_wcslen(encoding));
    6096. 

  6096. %%  export_def(Encoding_wcstombs(encoding));
    6097. 

  6097. %% #endif
    6098. 

  6098. %% export_def(cslen(encoding,src,srclen));
    6099. 

  6099. %% export_def(cstombs_help_(encoding,src,srclen,dest,destlen,A));
    6100. 

  6100. %% puts("#define cstombs(encoding,src,srclen,dest,destlen)  cstombs_help_(encoding,src,srclen,dest,destlen,ASSERT)");
    6101. 

  6101. 

  6102. #ifdef FOREIGN
    6103. 

  6103. /* foreign pointer wrap */
    6104. 

  6104. typedef struct {
    6105. 

  6105.   XRECORD_HEADER
    6106. 

  6106.   void* fp_pointer;
    6107. 

  6107. } *  Fpointer;
    6108. 

  6108. #define fpointer_length  0
    6109. 

  6109. #define fpointer_xlength  (sizeof(*(Fpointer)0)-offsetofa(record_,recdata)-fpointer_length*sizeof(gcv_object_t))
    6110. 

  6110. #define mark_fp_invalid(ptr)  record_flags_set(ptr,bit(7))
    6111. 

  6111. #define mark_fp_valid(ptr)  record_flags_clr(ptr,bit(7))
    6112. 

  6112. #define fp_validp(ptr)  ((record_flags(ptr) & bit(7)) == 0)
    6113. 

  6113. #else
    6114. 

  6114. #define mark_fp_invalid(ptr)
    6115. 

  6115. #endif
    6116. 

  6116. %% #ifdef FOREIGN
    6117. 

  6117. %%   emit_typedef("struct { XRECORD_HEADER void* fp_pointer;} *","Fpointer");
    6118. 

  6118. %%   export_def(fp_validp(ptr));
    6119. 

  6119. %%   export_def(mark_fp_invalid(ptr));
    6120. 

  6120. %% #endif
    6121. 

  6121. 

  6122. #ifdef DYNAMIC_FFI
    6123. 

  6123. 

  6124. /* foreign adresses */
    6125. 

  6125. typedef struct {
    6126. 

  6126.   XRECORD_HEADER
    6127. 

  6127.   gcv_object_t fa_base _attribute_aligned_object_;
    6128. 

  6128.   sintP fa_offset;
    6129. 

  6129. } * Faddress;
    6130. 

  6130. #define faddress_length  1
    6131. 

  6131. #define faddress_xlength  (sizeof(*(Faddress)0)-offsetofa(record_,recdata)-faddress_length*sizeof(gcv_object_t))
    6132. 

  6132. 

  6133. /* foreign variables */
    6134. 

  6134. typedef struct {
    6135. 

  6135.   XRECORD_HEADER
    6136. 

  6136.   gcv_object_t fv_name    _attribute_aligned_object_;
    6137. 

  6137.   gcv_object_t fv_version _attribute_aligned_object_;
    6138. 

  6138.   gcv_object_t fv_address _attribute_aligned_object_;
    6139. 

  6139.   gcv_object_t fv_size    _attribute_aligned_object_;
    6140. 

  6140.   gcv_object_t fv_type    _attribute_aligned_object_;
    6141. 

  6141. } * Fvariable;
    6142. 

  6142. #define fvariable_length  ((sizeof(*(Fvariable)0)-offsetofa(record_,recdata))/sizeof(gcv_object_t))
    6143. 

  6143. 

  6144. /* foreign functions */
    6145. 

  6145. typedef struct {
    6146. 

  6146.   XRECORD_HEADER
    6147. 

  6147.   gcv_object_t ff_name       _attribute_aligned_object_;
    6148. 

  6148.   gcv_object_t ff_version    _attribute_aligned_object_;
    6149. 

  6149.   gcv_object_t ff_address    _attribute_aligned_object_;
    6150. 

  6150.   gcv_object_t ff_resulttype _attribute_aligned_object_;
    6151. 

  6151.   gcv_object_t ff_argtypes   _attribute_aligned_object_;
    6152. 

  6152.   gcv_object_t ff_flags      _attribute_aligned_object_;
    6153. 

  6153.   gcv_object_t ff_properties _attribute_aligned_object_;
    6154. 

  6154. } * Ffunction;
    6155. 

  6155. #define ffunction_length  ((sizeof(*(Ffunction)0)-offsetofa(record_,recdata))/sizeof(gcv_object_t))
    6156. 

  6156. 

  6157. #endif
    6158. 

  6158. 

  6159. /* weak pointer */
    6160. 

  6160. typedef struct {
    6161. 

  6161.   XRECORD_HEADER
    6162. 

  6162.   gcv_object_t wp_cdr   _attribute_aligned_object_; /* active weak-pointers form a chained list */
    6163. 

  6163.   gcv_object_t wp_value _attribute_aligned_object_; /* the referenced object */
    6164. 

  6164. } * Weakpointer;
    6165. 

  6165. /* Both wp_cdr and wp_value are invisible to gc_mark routines.
    6166. 

  6166.  When the weak-pointer becomes inactive, both fields are turned to unbound.
    6167. 

  6167.  When wp_value is GC-invariant, WP does not have to be on the
    6168. 

  6168.  O(all_weakpointers) list!  WP is on the list <==> ( wp_cdr != unbound ) */
    6169. 

  6169. #define weakpointer_length  ((sizeof(*(Weakpointer)0)-offsetofa(record_,recdata))/sizeof(gcv_object_t))
    6170. 

  6170. #define weakpointer_broken_p(wp) (!boundp(TheWeakpointer(wp)->wp_value))
    6171. 

  6171. 

  6172. /* weak list */
    6173. 

  6173. typedef struct {
    6174. 

  6174.   LRECORD_HEADER
    6175. 

  6175.   gcv_object_t wp_cdr                   _attribute_aligned_object_; /* active weak-pointers form a chained list */
    6176. 

  6176.   gcv_object_t wl_count                 _attribute_aligned_object_; /* remaining objects */
    6177. 

  6177.   gcv_object_t wl_elements[unspecified] _attribute_aligned_object_; /* the referenced objects */
    6178. 

  6178. } * WeakList;
    6179. 

  6179. 

  6180. /* mutable weak list */
    6181. 

  6181. typedef struct {
    6182. 

  6182.   XRECORD_HEADER
    6183. 

  6183.   gcv_object_t mwl_list _attribute_aligned_object_;
    6184. 

  6184. } * MutableWeakList;
    6185. 

  6185. #define mutableweaklist_length  ((sizeof(*(MutableWeakList)0)-offsetofa(record_,recdata))/sizeof(gcv_object_t))
    6186. 

  6186. 

  6187. /* weak "and" relation */
    6188. 

  6188. typedef struct {
    6189. 

  6189.   LRECORD_HEADER
    6190. 

  6190.   gcv_object_t wp_cdr                _attribute_aligned_object_; /* active weak-pointers form a chained list */
    6191. 

  6191.   gcv_object_t war_keys_list         _attribute_aligned_object_; /* list to copy the keys into */
    6192. 

  6192.   gcv_object_t war_keys[unspecified] _attribute_aligned_object_; /* the referenced objects */
    6193. 

  6193. } * WeakAnd;
    6194. 

  6194. 

  6195. /* weak "or" relation */
    6196. 

  6196. typedef struct {
    6197. 

  6197.   LRECORD_HEADER
    6198. 

  6198.   gcv_object_t wp_cdr                _attribute_aligned_object_; /* active weak-pointers form a chained list */
    6199. 

  6199.   gcv_object_t wor_keys_list         _attribute_aligned_object_; /* list to copy the keys into */
    6200. 

  6200.   gcv_object_t wor_keys[unspecified] _attribute_aligned_object_; /* the referenced objects */
    6201. 

  6201. } * WeakOr;
    6202. 

  6202. 

  6203. /* weak mapping */
    6204. 

  6204. typedef struct {
    6205. 

  6205.   XRECORD_HEADER
    6206. 

  6206.   gcv_object_t wp_cdr   _attribute_aligned_object_; /* active weak-pointers form a chained list */
    6207. 

  6207.   gcv_object_t wm_value _attribute_aligned_object_; /* the dependent referenced object */
    6208. 

  6208.   gcv_object_t wm_key   _attribute_aligned_object_; /* the weak referenced object */
    6209. 

  6209. } * Weakmapping;
    6210. 

  6210. #define weakmapping_length  ((sizeof(*(Weakmapping)0)-offsetofa(record_,recdata))/sizeof(gcv_object_t))
    6211. 

  6211. 

  6212. /* weak "and" mapping */
    6213. 

  6213. typedef struct {
    6214. 

  6214.   LRECORD_HEADER
    6215. 

  6215.   gcv_object_t wp_cdr                _attribute_aligned_object_; /* active weak-pointers form a chained list */
    6216. 

  6216.   gcv_object_t wam_value             _attribute_aligned_object_; /* the dependent referenced object */
    6217. 

  6217.   gcv_object_t wam_keys_list         _attribute_aligned_object_; /* list to copy the keys into */
    6218. 

  6218.   gcv_object_t wam_keys[unspecified] _attribute_aligned_object_; /* the referenced objects */
    6219. 

  6219. } * WeakAndMapping;
    6220. 

  6220. 

  6221. /* weak "or" mapping */
    6222. 

  6222. typedef struct {
    6223. 

  6223.   LRECORD_HEADER
    6224. 

  6224.   gcv_object_t wp_cdr                _attribute_aligned_object_; /* active weak-pointers form a chained list */
    6225. 

  6225.   gcv_object_t wom_value             _attribute_aligned_object_; /* the dependent referenced object */
    6226. 

  6226.   gcv_object_t wom_keys_list         _attribute_aligned_object_; /* list to copy the keys into */
    6227. 

  6227.   gcv_object_t wom_keys[unspecified] _attribute_aligned_object_; /* the referenced objects */
    6228. 

  6228. } * WeakOrMapping;
    6229. 

  6229. 

  6230. /* weak alist (rectype = Rectype_WeakAlist_{Key,Value,Either,Both}) */
    6231. 

  6231. typedef struct {
    6232. 

  6232.   LRECORD_HEADER
    6233. 

  6233.   gcv_object_t wp_cdr                _attribute_aligned_object_; /* active weak-pointers form a chained list */
    6234. 

  6234.   gcv_object_t wal_count             _attribute_aligned_object_; /* remaining pairs */
    6235. 

  6235.   gcv_object_t wal_data[unspecified] _attribute_aligned_object_; /* key, value alternating */
    6236. 

  6236. } * WeakAlist;
    6237. 

  6237. 

  6238. /* mutable weak alist */
    6239. 

  6239. typedef struct {
    6240. 

  6240.   XRECORD_HEADER
    6241. 

  6241.   gcv_object_t mwal_list _attribute_aligned_object_;
    6242. 

  6242. } * MutableWeakAlist;
    6243. 

  6243. #define mutableweakalist_length  ((sizeof(*(MutableWeakAlist)0)-offsetofa(record_,recdata))/sizeof(gcv_object_t))
    6244. 

  6244. 

  6245. /* weak hashed alist (rectype = Rectype_WeakHashedAlist_{Key,Value,Either,Both}) */
    6246. 

  6246. typedef struct {
    6247. 

  6247.   LRECORD_HEADER
    6248. 

  6248.   gcv_object_t wp_cdr                 _attribute_aligned_object_; /* active weak-pointers form a chained list */
    6249. 

  6249.   gcv_object_t whal_itable            _attribute_aligned_object_; /* index-vector */
    6250. 

  6250.   gcv_object_t whal_count             _attribute_aligned_object_; /* remaining pairs */
    6251. 

  6251.   gcv_object_t whal_freelist          _attribute_aligned_object_; /* start index of freelist */
    6252. 

  6252.   gcv_object_t whal_data[unspecified] _attribute_aligned_object_; /* (key, value, next) triples */
    6253. 

  6253. } * WeakHashedAlist;
    6254. 

  6254. 

  6255. /* Finalizer */
    6256. 

  6256. typedef struct {
    6257. 

  6257.   XRECORD_HEADER
    6258. 

  6258.   gcv_object_t fin_alive    _attribute_aligned_object_; /* only if this object is alive */
    6259. 

  6259.   gcv_object_t fin_trigger  _attribute_aligned_object_; /* wait for the death of this object */
    6260. 

  6260.   gcv_object_t fin_function _attribute_aligned_object_; /* then this function is called */
    6261. 

  6261.   gcv_object_t fin_cdr      _attribute_aligned_object_;
    6262. 

  6262. } * Finalizer;
    6263. 

  6263. #define finalizer_length  ((sizeof(*(Finalizer)0)-offsetofa(record_,recdata))/sizeof(gcv_object_t))
    6264. 

  6264. 

  6265. #ifdef SOCKET_STREAMS
    6266. 

  6266. /* Socket-Server */
    6267. 

  6267. typedef struct {
    6268. 

  6268.   XRECORD_HEADER
    6269. 

  6269.   gcv_object_t socket_handle _attribute_aligned_object_; /* socket handle */
    6270. 

  6270.   gcv_object_t host          _attribute_aligned_object_; /* host string */
    6271. 

  6271.   gcv_object_t port          _attribute_aligned_object_; /* port number */
    6272. 

  6272. } * Socket_server;
    6273. 

  6273. #define socket_server_length  ((sizeof(*(Socket_server)0)-offsetofa(record_,recdata))/sizeof(gcv_object_t))
    6274. 

  6274. 

  6275. /* Information about any of the two ends of a socket connection. */
    6276. 

  6276. #ifndef MAXHOSTNAMELEN
    6277. 

  6277.   #define MAXHOSTNAMELEN 64
    6278. 

  6278. #endif
    6279. 

  6279. typedef struct host_data_t {
    6280. 

  6280.   char hostname[45+1];   /* IP address in presentable, printable format
    6281. 

  6281.                         (IPv4 max. 15 characters, IPv6 max. 45 characters) */
    6282. 

  6282.   char truename[MAXHOSTNAMELEN+1]; /* hostname, with or without domain name */
    6283. 

  6283.   unsigned int port;
    6284. 

  6284. } host_data_t;
    6285. 

  6285. #endif
    6286. 

  6286. 

  6287. #ifdef YET_ANOTHER_RECORD
    6288. 

  6288. 

  6289. /* Yet another record */
    6290. 

  6290. typedef struct {
    6291. 

  6291.   XRECORD_HEADER
    6292. 

  6292.   gcv_object_t yetanother_x _attribute_aligned_object_;
    6293. 

  6293.   gcv_object_t yetanother_y _attribute_aligned_object_;
    6294. 

  6294.   gcv_object_t yetanother_z _attribute_aligned_object_;
    6295. 

  6295. } * Yetanother;
    6296. 

  6296. #define yetanother_length  ((sizeof(*(Yetanother)0)-offsetofa(record_,recdata))/sizeof(gcv_object_t))
    6297. 

  6297. 

  6298. #endif
    6299. 

  6299. 

  6300. /* Streams with metaclass BUILT-IN-CLASS */
    6301. 

  6301. typedef struct {
    6302. 

  6302.   #ifdef case_stream
    6303. 

  6303.     VAROBJECT_HEADER /* self-pointer for GC */
    6304. 

  6304.     uintB strmtype;  /* subtype (as sintB >=0 !) */
    6305. 

  6305.     uintB strmflags; /* flags */
    6306. 

  6306.     uintB reclength; /* length in object */
    6307. 

  6307.     uintB recxlength; /* lengths of the extra-elements */
    6308. 

  6308.   #else
    6309. 

  6309.     /* Because of space requirements, I have to put strmflags and strmtype
    6310. 

  6310.      into a fixnum in recdata[0]. */
    6311. 

  6311.     #if !((oint_addr_len+oint_addr_shift>=24) && (8>=oint_addr_shift))
    6312. 

  6312.       #error "No room for stream flags -- re-accommodate Stream-Flags!!"
    6313. 

  6313.     #endif
    6314. 

  6314.     XRECORD_HEADER
    6315. 

  6315.     #if defined(WIDE) && BIG_ENDIAN_P
    6316. 

  6316.       uintL strmfiller0;
    6317. 

  6317.     #endif
    6318. 

  6318.     uintB strmfiller1;
    6319. 

  6319.     uintB strmflags; /* Flags */
    6320. 

  6320.     uintB strmtype;  /* Subtype */
    6321. 

  6321.     uintB strmfiller2;
    6322. 

  6322.     #if defined(WIDE) && !BIG_ENDIAN_P
    6323. 

  6323.       uintL strmfiller0;
    6324. 

  6324.     #endif
    6325. 

  6325.   #endif
    6326. 

  6326.   gcv_object_t strm_rd_by            _attribute_aligned_object_;
    6327. 

  6327.   gcv_object_t strm_rd_by_array      _attribute_aligned_object_;
    6328. 

  6328.   gcv_object_t strm_wr_by            _attribute_aligned_object_;
    6329. 

  6329.   gcv_object_t strm_wr_by_array      _attribute_aligned_object_;
    6330. 

  6330.   gcv_object_t strm_rd_ch            _attribute_aligned_object_;
    6331. 

  6331.   gcv_object_t strm_pk_ch            _attribute_aligned_object_;
    6332. 

  6332.   gcv_object_t strm_rd_ch_array      _attribute_aligned_object_;
    6333. 

  6333.   gcv_object_t strm_rd_ch_last       _attribute_aligned_object_;
    6334. 

  6334.   gcv_object_t strm_wr_ch            _attribute_aligned_object_;
    6335. 

  6335.   gcv_object_t strm_wr_ch_array      _attribute_aligned_object_;
    6336. 

  6336.   gcv_object_t strm_wr_ch_npnl       _attribute_aligned_object_;
    6337. 

  6337.   gcv_object_t strm_wr_ch_array_npnl _attribute_aligned_object_;
    6338. 

  6338.   gcv_object_t strm_wr_ch_lpos       _attribute_aligned_object_;
    6339. 

  6339.   gcv_object_t strm_other[unspecified] _attribute_aligned_object_; /* type-specific components */
    6340. 

  6340. } *  Stream;
    6341. 

  6341. /* The macro TheStream actually means TheBuiltinStream. */
    6342. 

  6342. #define strm_len  ((sizeof(*(Stream)0)-offsetofa(record_,recdata))/sizeof(gcv_object_t)-unspecified)
    6343. 

  6343. #define stream_length(ptr)  xrecord_length(ptr)
    6344. 

  6344. #define stream_xlength(ptr)  xrecord_xlength(ptr)
    6345. 

  6345. #define Stream_length(obj)  stream_length(TheStream(obj))
    6346. 

  6346. #define Stream_xlength(obj)  stream_xlength(TheStream(obj))
    6347. 

  6347. /* Bit-masks in the Flags: */
    6348. 

  6348.   #define strmflags_open_bit_B   0  /* set, if the Stream is open */
    6349. 

  6349.   #define strmflags_immut_bit_B  1  /* set if read literals are immutable */
    6350. 

  6350.   #define strmflags_fasl_bit_B    2  /* Read-Eval is permitted; \r=#\Return */
    6351. 

  6351.   #define strmflags_rd_by_bit_B  4  /* set, if READ-BYTE is possible */
    6352. 

  6352.   #define strmflags_wr_by_bit_B  5  /* set, if WRITE-BYTE is possible */
    6353. 

  6353.   #define strmflags_rd_ch_bit_B  6  /* set, if READ-CHAR is possible */
    6354. 

  6354.   #define strmflags_wr_ch_bit_B  7  /* set, if WRITE-CHAR is possible */
    6355. 

  6355.   #define strmflags_open_B   bit(strmflags_open_bit_B)
    6356. 

  6356.   #define strmflags_rd_by_B  bit(strmflags_rd_by_bit_B)
    6357. 

  6357.   #define strmflags_wr_by_B  bit(strmflags_wr_by_bit_B)
    6358. 

  6358.   #define strmflags_rd_ch_B  bit(strmflags_rd_ch_bit_B)
    6359. 

  6359.   #define strmflags_wr_ch_B  bit(strmflags_wr_ch_bit_B)
    6360. 

  6360.   #define strmflags_rd_B  (strmflags_rd_by_B | strmflags_rd_ch_B)
    6361. 

  6361.   #define strmflags_wr_B  (strmflags_wr_by_B | strmflags_wr_ch_B)
    6362. 

  6362. /* approach Typinfo: */
    6363. 

  6363.   enum { /* The ordered values of this enumeration are 0,1,2,... */
    6364. 

  6364.   /* First the OS independent streams. */
    6365. 

  6365.                               enum_strmtype_synonym,
    6366. 

  6366.   #define strmtype_synonym    (uintB)enum_strmtype_synonym
    6367. 

  6367.                               enum_strmtype_broad,
    6368. 

  6368.   #define strmtype_broad      (uintB)enum_strmtype_broad
    6369. 

  6369.                               enum_strmtype_concat,
    6370. 

  6370.   #define strmtype_concat     (uintB)enum_strmtype_concat
    6371. 

  6371.                               enum_strmtype_twoway,
    6372. 

  6372.   #define strmtype_twoway     (uintB)enum_strmtype_twoway
    6373. 

  6373.                               enum_strmtype_echo,
    6374. 

  6374.   #define strmtype_echo       (uintB)enum_strmtype_echo
    6375. 

  6375.                               enum_strmtype_str_in,
    6376. 

  6376.   #define strmtype_str_in     (uintB)enum_strmtype_str_in
    6377. 

  6377.                               enum_strmtype_str_out,
    6378. 

  6378.   #define strmtype_str_out    (uintB)enum_strmtype_str_out
    6379. 

  6379.                               enum_strmtype_str_push,
    6380. 

  6380.   #define strmtype_str_push   (uintB)enum_strmtype_str_push
    6381. 

  6381.                               enum_strmtype_pphelp,
    6382. 

  6382.   #define strmtype_pphelp     (uintB)enum_strmtype_pphelp
    6383. 

  6383.                               enum_strmtype_buff_in,
    6384. 

  6384.   #define strmtype_buff_in    (uintB)enum_strmtype_buff_in
    6385. 

  6385.                               enum_strmtype_buff_out,
    6386. 

  6386.   #define strmtype_buff_out   (uintB)enum_strmtype_buff_out
    6387. 

  6387.   #ifdef GENERIC_STREAMS
    6388. 

  6388.                               enum_strmtype_generic,
    6389. 

  6389.   #define strmtype_generic    (uintB)enum_strmtype_generic
    6390. 

  6390.   #endif
    6391. 

  6391.   /* Then the OS dependent streams. */
    6392. 

  6392.                               enum_strmtype_file,
    6393. 

  6393.   #define strmtype_file       (uintB)enum_strmtype_file
    6394. 

  6394.   #ifdef KEYBOARD
    6395. 

  6395.                               enum_strmtype_keyboard,
    6396. 

  6396.   #define strmtype_keyboard   (uintB)enum_strmtype_keyboard
    6397. 

  6397.   #endif
    6398. 

  6398.                               enum_strmtype_terminal,
    6399. 

  6399.   #define strmtype_terminal   (uintB)enum_strmtype_terminal
    6400. 

  6400.   #ifdef SCREEN
    6401. 

  6401.                               enum_strmtype_window,
    6402. 

  6402.   #define strmtype_window     (uintB)enum_strmtype_window
    6403. 

  6403.   #endif
    6404. 

  6404.   #ifdef PRINTER
    6405. 

  6405.                               enum_strmtype_printer,
    6406. 

  6406.   #define strmtype_printer    (uintB)enum_strmtype_printer
    6407. 

  6407.   #endif
    6408. 

  6408.   #ifdef PIPES
    6409. 

  6409.                               enum_strmtype_pipe_in,
    6410. 

  6410.   #define strmtype_pipe_in    (uintB)enum_strmtype_pipe_in
    6411. 

  6411.                               enum_strmtype_pipe_out,
    6412. 

  6412.   #define strmtype_pipe_out   (uintB)enum_strmtype_pipe_out
    6413. 

  6413.   #endif
    6414. 

  6414.   #ifdef X11SOCKETS
    6415. 

  6415.                               enum_strmtype_x11socket,
    6416. 

  6416.   #define strmtype_x11socket  (uintB)enum_strmtype_x11socket
    6417. 

  6417.   #endif
    6418. 

  6418.   #ifdef SOCKET_STREAMS
    6419. 

  6419.                               enum_strmtype_socket,
    6420. 

  6420.   #define strmtype_socket     (uintB)enum_strmtype_socket
    6421. 

  6421.                               enum_strmtype_twoway_socket,
    6422. 

  6422.   #define strmtype_twoway_socket (uintB)enum_strmtype_twoway_socket
    6423. 

  6423.   #endif
    6424. 

  6424.                               enum_strmtype_dummy
    6425. 

  6425.   };
    6426. 

  6426.   /* When this table is changed, also adapt
    6427. 

  6427.    - the 12 jumptables for STREAM-ELEMENT-TYPE, SET-STREAM-ELEMENT-TYPE,
    6428. 

  6428.      STREAM-EXTERNAL-FORMAT, SET-STREAM-EXTERNAL-FORMAT, INTERACTIVE-STREAM-P,
    6429. 

  6429.      CLOSE, LISTEN-CHAR, CLEAR_INPUT, LISTEN-BYTE, FINISH_OUTPUT,
    6430. 

  6430.      FORCE_OUTPUT, CLEAR_OUTPUT in STREAM.D and
    6431. 

  6431.    - the name-table in CONSTOBJ.D and
    6432. 

  6432.    - the jumptable for PR_STREAM in IO.D and
    6433. 

  6433.    - the pseudo-function-table in PSEUDOFUN.D */
    6434. 

  6434.   #
    6435. 

  6435. /* more type-specific components: */
    6436. 

  6436.   #define strm_eltype          strm_other[0] /* CHARACTER or ([UN]SIGNED-BYTE n) */
    6437. 

  6437.   #define strm_encoding        strm_other[1] /* an encoding */
    6438. 

  6438.   #define strm_file_name       strm_other[6] /* filename, a pathname or NIL */
    6439. 

  6439.   #define strm_file_truename   strm_other[7] /* truename, a non-logical pathname or NIL */
    6440. 

  6440.   #define strm_buffered_channel  strm_other[5] /* packed Handle */
    6441. 

  6441.   #define strm_synonym_symbol  strm_other[0]
    6442. 

  6442.   #define strm_broad_list      strm_other[0] /* list of Streams */
    6443. 

  6443.   #define strm_concat_list     strm_other[0] /* list of Streams */
    6444. 

  6444.   #define strm_pphelp_lpos     strm_wr_ch_lpos /* Line Position (Fixnum>=0) */
    6445. 

  6445.   #define strm_pphelp_strings  strm_other[0]   /* Semi-Simple-Strings for Output */
    6446. 

  6446.   #define strm_pphelp_modus    strm_other[1]   /* Mode (NIL=Single line, T=multiple lines) */
    6447. 

  6447.   #define strm_pphelp_miserp   strm_other[2] /* miser mode indicator */
    6448. 

  6448.   #define strm_pphelp_offset   strm_other[3] /* initial line offset (indent) */
    6449. 

  6449.   #define strm_buff_in_fun     strm_other[0] /* read function */
    6450. 

  6450.   #define strm_buff_out_fun    strm_other[0] /* output function */
    6451. 

  6451.   #define strm_twoway_input    strm_other[0] /* stream for input */
    6452. 

  6452.   #define strm_twoway_output   strm_other[1] /* stream for output */
    6453. 

  6453.   #ifdef PIPES
    6454. 

  6454.   #define strm_pipe_pid        strm_other[6] /* process-Id, a Fixnum >=0 */
    6455. 

  6455.   #endif
    6456. 

  6456.   #ifdef X11SOCKETS
    6457. 

  6457.   #define strm_x11socket_connect  strm_other[6] /* List (host display) */
    6458. 

  6458.   #endif
    6459. 

  6459.   #ifdef SOCKET_STREAMS
    6460. 

  6460.   #define strm_socket_port     strm_other[6] /* port, a fixnum >=0 */
    6461. 

  6461.   #define strm_socket_host     strm_other[7] /* host, NIL or a string */
    6462. 

  6462.   #define strm_twoway_socket_input  strm_other[0] /* input side, a socket stream */
    6463. 

  6463.   #endif
    6464. 

  6464.   #ifdef GENERIC_STREAMS
    6465. 

  6465.   #define strm_controller_object strm_other[0] /* Controller (usually a CLOS-instance) */
    6466. 

  6466.   #endif
    6467. 

  6467.   #define strm_buffered_bufflen 4096   /* buffer length, a power of 2, <2^16 */
    6468. 

  6468. /* is used by stream.d, pathname.d, io.d */
    6469. 

  6469. %% export_def(strm_buffered_bufflen);
    6470. 

  6470. 

  6471. /* Structures */
    6472. 

  6472. typedef Srecord  Structure;
    6473. 

  6473.   #define structure_types   recdata[0]
    6474. 

  6474. #define structure_length(ptr)  srecord_length(ptr)
    6475. 

  6475. #define Structure_length(obj)  structure_length(TheStructure(obj))
    6476. 

  6476. %% emit_typedef("Srecord","Structure");
    6477. 

  6477. %% export_def(structure_types);
    6478. 

  6478. 

  6479. /* CLOS class-versions, see clos.lisp */
    6480. 

  6480. typedef struct {
    6481. 

  6481.   VRECORD_HEADER
    6482. 

  6482.   gcv_object_t cv_newest_class             _attribute_aligned_object_; /* the CLASS object describing the newest available version */
    6483. 

  6483.   gcv_object_t cv_class                    _attribute_aligned_object_; /* the CLASS object describing the slots */
    6484. 

  6484.   gcv_object_t cv_shared_slots             _attribute_aligned_object_; /* simple-vector with the values of all shared slots, or nil */
    6485. 

  6485.   gcv_object_t cv_serial                   _attribute_aligned_object_; /* serial number of this class version */
    6486. 

  6486.   gcv_object_t cv_next                     _attribute_aligned_object_; /* next class-version, or nil */
    6487. 

  6487.   gcv_object_t cv_slotlists_valid_p        _attribute_aligned_object_; /* true if the following fields are already computed */
    6488. 

  6488.   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 */
    6489. 

  6489.   gcv_object_t cv_added_slots              _attribute_aligned_object_; /* list of local slots that are added in the next version */
    6490. 

  6490.   gcv_object_t cv_discarded_slots          _attribute_aligned_object_; /* list of local slots that are removed or become shared in the next version */
    6491. 

  6491.   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 */
    6492. 

  6492. } *  ClassVersion;
    6493. 

  6493. #define classversion_length  ((sizeof(*(ClassVersion)0)-offsetofa(svector_,data))/sizeof(gcv_object_t))
    6494. 

  6494. 

  6495. /* CLOS-instances */
    6496. 

  6496. typedef struct {
    6497. 

  6497.   SRECORD_HEADER
    6498. 

  6498.   gcv_object_t inst_class_version _attribute_aligned_object_; /* indirect pointer to a CLOS-class */
    6499. 

  6499.   gcv_object_t other[unspecified] _attribute_aligned_object_;
    6500. 

  6500. } *  Instance;
    6501. 

  6501. /* Bit masks in the flags: */
    6502. 

  6502.   #define instflags_forwarded_B    bit(0)
    6503. 

  6503.   #define instflags_beingupdated_B bit(3)
    6504. 

  6504.   /* The following are only used during garbage collection. */
    6505. 

  6505.   #define instflags_backpointer_B  bit(1)
    6506. 

  6506.   #define instflags_relocated_B    bit(2)
    6507. 

  6507.   #define mark_inst_clean(ptr)  \
    6508. 

  6508.     record_flags_clr(ptr,instflags_backpointer_B|instflags_relocated_B)
    6509. 

  6509. %% sprintf(buf,"struct { SRECORD_HEADER gcv_object_t inst_class_version%s; gcv_object_t other[unspecified]%s; } *",attribute_aligned_object,attribute_aligned_object);
    6510. 

  6510. %% emit_typedef(buf,"Instance");
    6511. 

  6511. 

  6512. /* Structures that inherit from <structure-stablehash> */
    6513. 

  6513. typedef struct {
    6514. 

  6514.   SRECORD_HEADER
    6515. 

  6515.   gcv_object_t _structure_types   _attribute_aligned_object_;
    6516. 

  6516.   gcv_object_t stablehashcode     _attribute_aligned_object_;
    6517. 

  6517.   gcv_object_t other[unspecified] _attribute_aligned_object_;
    6518. 

  6518. } *  StablehashStructure;
    6519. 

  6519. 

  6520. /* CLOS instances that inherit from <standard-stablehash> */
    6521. 

  6521. typedef struct {
    6522. 

  6522.   SRECORD_HEADER
    6523. 

  6523.   gcv_object_t inst_class_version _attribute_aligned_object_; /* indirect pointer to a CLOS-class */
    6524. 

  6524.   gcv_object_t stablehashcode     _attribute_aligned_object_;
    6525. 

  6525.   gcv_object_t other[unspecified] _attribute_aligned_object_;
    6526. 

  6526. } *  StablehashInstance;
    6527. 

  6527. 

  6528. /* Slot definitions (= instances of <slot-definition>, see clos-slotdef1.lisp */
    6529. 

  6529. typedef struct {
    6530. 

  6530.   SRECORD_HEADER
    6531. 

  6531.   gcv_object_t inst_class_version         _attribute_aligned_object_;
    6532. 

  6532.   gcv_object_t slotdef_name               _attribute_aligned_object_;
    6533. 

  6533.   gcv_object_t slotdef_initargs           _attribute_aligned_object_;
    6534. 

  6534.   gcv_object_t slotdef_type               _attribute_aligned_object_;
    6535. 

  6535.   gcv_object_t slotdef_allocation         _attribute_aligned_object_;
    6536. 

  6536.   gcv_object_t slotdef_inheritable_initer _attribute_aligned_object_;
    6537. 

  6537.   gcv_object_t slotdef_inheritable_doc    _attribute_aligned_object_;
    6538. 

  6538.   /* from here on only for class ⊆ <effective-slot-definition> */
    6539. 

  6539.   gcv_object_t slotdef_location           _attribute_aligned_object_;
    6540. 

  6540.   gcv_object_t slotdef_efm_svuc           _attribute_aligned_object_;
    6541. 

  6541.   gcv_object_t slotdef_efm_ssvuc          _attribute_aligned_object_;
    6542. 

  6542.   gcv_object_t slotdef_efm_sbuc           _attribute_aligned_object_;
    6543. 

  6543.   gcv_object_t slotdef_efm_smuc           _attribute_aligned_object_;
    6544. 

  6544. } *  SlotDefinition;
    6545. 

  6545. 

  6546. /* CLOS-Classes (= instances of <class>), see clos-class1.lisp */
    6547. 

  6547. typedef struct {
    6548. 

  6548.   SRECORD_HEADER
    6549. 

  6549.   gcv_object_t inst_class_version       _attribute_aligned_object_; /* indirect pointer to a CLOS-class */
    6550. 

  6550.   gcv_object_t hashcode                 _attribute_aligned_object_; /* GC invariant hash code */
    6551. 

  6551.   gcv_object_t direct_methods           _attribute_aligned_object_; /* set of methods that use this specializer */
    6552. 

  6552.   gcv_object_t classname                _attribute_aligned_object_; /* a symbol */
    6553. 

  6553.   gcv_object_t direct_subclasses        _attribute_aligned_object_; /* weak-list or weak-hash-table of all direct subclasses */
    6554. 

  6554.   /* from here on only for metaclass ⊆ <defined-class> */
    6555. 

  6555.   gcv_object_t direct_superclasses      _attribute_aligned_object_; /* direct superclasses */
    6556. 

  6556.   gcv_object_t all_superclasses         _attribute_aligned_object_; /* all superclasses, including itself */
    6557. 

  6557.   gcv_object_t precedence_list          _attribute_aligned_object_; /* ordered list of all superclasses */
    6558. 

  6558.   gcv_object_t direct_slots             _attribute_aligned_object_;
    6559. 

  6559.   gcv_object_t slots                    _attribute_aligned_object_;
    6560. 

  6560.   gcv_object_t slot_location_table      _attribute_aligned_object_; /* hashtable slotname -> where the slot is located */
    6561. 

  6561.   gcv_object_t direct_default_initargs  _attribute_aligned_object_;
    6562. 

  6562.   gcv_object_t default_initargs         _attribute_aligned_object_;
    6563. 

  6563.   gcv_object_t documentation            _attribute_aligned_object_; /* string or NIL */
    6564. 

  6564.   gcv_object_t listeners                _attribute_aligned_object_; /* list of objects to be notified upon a change */
    6565. 

  6565.   gcv_object_t initialized              _attribute_aligned_object_; /* describes which parts of the class are initialized */
    6566. 

  6566.   /* from here on only for metaclass ⊆ <standard-class> or metaclass ⊆ <funcallable-standard-class> or metaclass ⊆ <structure-class> */
    6567. 

  6567.   gcv_object_t subclass_of_stablehash_p _attribute_aligned_object_; /* true if <standard-stablehash> or <structure-stablehash> is among the superclasses */
    6568. 

  6568.   gcv_object_t generic_accessors        _attribute_aligned_object_;
    6569. 

  6569.   gcv_object_t direct_accessors         _attribute_aligned_object_;
    6570. 

  6570.   gcv_object_t valid_initargs_from_slots _attribute_aligned_object_;
    6571. 

  6571.   gcv_object_t instance_size            _attribute_aligned_object_;
    6572. 

  6572.   /* from here on only for metaclass ⊆ <standard-class> or metaclass ⊆ <funcallable-standard-class> */
    6573. 

  6573.   gcv_object_t current_version          _attribute_aligned_object_; /* most recent class-version, points back to this class */
    6574. 

  6574.   gcv_object_t funcallablep             _attribute_aligned_object_;
    6575. 

  6575.   gcv_object_t fixed_slot_locations     _attribute_aligned_object_;
    6576. 

  6576.   gcv_object_t instantiated             _attribute_aligned_object_;
    6577. 

  6577.   gcv_object_t direct_instance_specializers _attribute_aligned_object_;
    6578. 

  6578.   gcv_object_t finalized_direct_subclasses _attribute_aligned_object_; /* weak-list or weak-hash-table of all finalized direct subclasses */
    6579. 

  6579.   gcv_object_t prototype                _attribute_aligned_object_; /* class prototype - an instance or NIL */
    6580. 

  6580.   /* from here on only for metaclass ⊆ <standard-class> */
    6581. 

  6581.   gcv_object_t other[unspecified]       _attribute_aligned_object_;
    6582. 

  6582. } *  Class;
    6583. 

  6583. 

  6584. /* Length of a <defined-class>. */
    6585. 

  6585. #define defined_class_length ((((aint)&((Class)0)->initialized-offsetofa(record_,recdata))/sizeof(gcv_object_t))+1)
    6586. 

  6586. /* Length of a <built-in-class>. */
    6587. 

  6587. #define built_in_class_length  (defined_class_length+1) /* = clos::*<built-in-class>-instance-size* */
    6588. 

  6588. 

  6589. /* Closures */
    6590. 

  6590. typedef struct {
    6591. 

  6591.   SRECORD_HEADER
    6592. 

  6592.   gcv_object_t clos_name_or_class_version _attribute_aligned_object_;
    6593. 

  6593.   gcv_object_t clos_codevec               _attribute_aligned_object_;
    6594. 

  6594.   gcv_object_t other[unspecified]         _attribute_aligned_object_;
    6595. 

  6595. } *  Closure;
    6596. 

  6596. /* interpreted Closure: */
    6597. 

  6597. typedef struct {
    6598. 

  6598.   SRECORD_HEADER
    6599. 

  6599.   gcv_object_t clos_name       _attribute_aligned_object_;
    6600. 

  6600.   gcv_object_t clos_form       _attribute_aligned_object_;
    6601. 

  6601.   gcv_object_t clos_docstring  _attribute_aligned_object_;
    6602. 

  6602.   gcv_object_t clos_body       _attribute_aligned_object_;
    6603. 

  6603.   gcv_object_t clos_var_env    _attribute_aligned_object_;
    6604. 

  6604.   gcv_object_t clos_fun_env    _attribute_aligned_object_;
    6605. 

  6605.   gcv_object_t clos_block_env  _attribute_aligned_object_;
    6606. 

  6606.   gcv_object_t clos_go_env     _attribute_aligned_object_;
    6607. 

  6607.   gcv_object_t clos_decl_env   _attribute_aligned_object_;
    6608. 

  6608.   gcv_object_t clos_vars       _attribute_aligned_object_;
    6609. 

  6609.   gcv_object_t clos_varflags   _attribute_aligned_object_;
    6610. 

  6610.   gcv_object_t clos_spec_count _attribute_aligned_object_;
    6611. 

  6611.   gcv_object_t clos_req_count  _attribute_aligned_object_;
    6612. 

  6612.   gcv_object_t clos_opt_count  _attribute_aligned_object_;
    6613. 

  6613.   gcv_object_t clos_opt_inits  _attribute_aligned_object_;
    6614. 

  6614.   gcv_object_t clos_key_count  _attribute_aligned_object_;
    6615. 

  6615.   gcv_object_t clos_keywords   _attribute_aligned_object_;
    6616. 

  6616.   gcv_object_t clos_key_inits  _attribute_aligned_object_;
    6617. 

  6617.   gcv_object_t clos_allow_flag _attribute_aligned_object_;
    6618. 

  6618.   gcv_object_t clos_rest_flag  _attribute_aligned_object_;
    6619. 

  6619.   gcv_object_t clos_aux_count  _attribute_aligned_object_;
    6620. 

  6620.   gcv_object_t clos_aux_inits  _attribute_aligned_object_;
    6621. 

  6621. } *  Iclosure;
    6622. 

  6622. #define iclos_length  ((sizeof(*(Iclosure)0)-offsetofa(record_,recdata))/sizeof(gcv_object_t))
    6623. 

  6623. /* compiled Closure: */
    6624. 

  6624. typedef struct {
    6625. 

  6625.   SRECORD_HEADER
    6626. 

  6626.   gcv_object_t clos_name_or_class_version _attribute_aligned_object_;
    6627. 

  6627.   gcv_object_t clos_codevec               _attribute_aligned_object_;
    6628. 

  6628.   gcv_object_t clos_consts[unspecified]   _attribute_aligned_object_; /* Closure-constants */
    6629. 

  6629. } *  Cclosure;
    6630. 

  6630. #define cclosure_length(ptr)  srecord_length(ptr)
    6631. 

  6631. #define Cclosure_length(obj)  cclosure_length(TheCclosure(obj))
    6632. 

  6632. /* Flags in a closure. They must be disjoint from the instflags_* bits. */
    6633. 

  6633. #ifdef TYPECODES
    6634. 

  6634.   #define closure_flags(ptr)  ((ptr)->recflags)
    6635. 

  6635. #else
    6636. 

  6636.   #define closure_flags(ptr)  record_flags(ptr)
    6637. 

  6637. #endif
    6638. 

  6638. #define Closure_flags(obj)  closure_flags(TheClosure(obj))
    6639. 

  6639. #define Cclosure_seclass(obj)  ((Closure_flags(obj) >> 4) & 0x07)
    6640. 

  6640. #define Cclosure_set_seclass(obj,se)  \
    6641. 

  6641.   (record_flags_clr(TheCclosure(obj),0x07<<4), \
    6642. 

  6642.    record_flags_set(TheCclosure(obj),(se)<<4))
    6643. 

  6643. #define closflags_instance_B  bit(7)
    6644. 

  6644. #define closure_instancep(ptr)  (closure_flags(ptr) & closflags_instance_B)
    6645. 

  6645. #define Closure_instancep(obj)  closure_instancep(TheClosure(obj))
    6646. 

  6646. /* Closed-over environment, as a set of nested simple-vectors. */
    6647. 

  6647. #define clos_venv  clos_consts[0]
    6648. 

  6648. /* The function's name. Depends on whether instancep or not. */
    6649. 

  6649. #define Closure_name(obj)  \
    6650. 

  6650.   (Closure_instancep(obj)             \
    6651. 

  6651.    ? TheCclosure(obj)->clos_consts[1] \
    6652. 

  6652.    : TheClosure(obj)->clos_name_or_class_version)
    6653. 

  6653. typedef struct {
    6654. 

  6654.   VRECORD_HEADER               /* self-pointer for GC, length in bits */
    6655. 

  6655.   /* Here: Content of the Bitvector. */
    6656. 

  6656.   uintW  ccv_spdepth_1;          /* maximal SP-depth, 1-part */
    6657. 

  6657.   uintW  ccv_spdepth_jmpbufsize; /* maximal SP-depth, jmpbufsize-part */
    6658. 

  6658.   uintW  ccv_numreq;             /* number of required parameters */
    6659. 

  6659.   uintW  ccv_numopt;             /* number of optional parameters */
    6660. 

  6660.   uintB  ccv_flags; /* Flags: Bit 0: &REST - parameter given?
    6661. 

  6661.                               Bit 1: full lambda list at the end of const vec
    6662. 

  6662.                               Bit 2: docstring at the end of const vec
    6663. 

  6663.                               Bit 3: generic function with call-inhibition?
    6664. 

  6664.                               Bit 4: generic function?
    6665. 

  6665.                               Bit 5: JITC code at the end of const vec
    6666. 

  6666.                               Bit 6: &ALLOW-OTHER-KEYS-Flag
    6667. 

  6667.                               Bit 7: keyword-parameter given? */
    6668. 

  6668.   uintB  ccv_signature; /* abbreviated argument type, for faster FUNCALL */
    6669. 

  6669.   /* If keyword-parameters are given: */
    6670. 

  6670.   uintW  ccv_numkey;    /* Number of keyword-parameters */
    6671. 

  6671.   uintW  ccv_keyconsts; /* Offset in FUNC of the keywords */
    6672. 

  6672. } *  Codevec;
    6673. 

  6673. #define CCV_SPDEPTH_1           0
    6674. 

  6674. #define CCV_SPDEPTH_JMPBUFSIZE  2
    6675. 

  6675. #define CCV_NUMREQ              4
    6676. 

  6676. #define CCV_NUMOPT              6
    6677. 

  6677. #define CCV_FLAGS               8
    6678. 

  6678. #define CCV_SIGNATURE           9
    6679. 

  6679. #define CCV_NUMKEY             10
    6680. 

  6680. #define CCV_KEYCONSTS          12
    6681. 

  6681. #define CCV_START_NONKEY       10
    6682. 

  6682. #define CCV_START_KEY          14
    6683. 

  6683. /* Compiled closures, where Bit 4 has been set in the flags of clos_codevec
    6684. 

  6684.    are generic functions. */
    6685. 

  6685. %% export_def(closure_flags(ptr));
    6686. 

  6686. %% export_def(closure_instancep(ptr));
    6687. 

  6687. %% export_def(Closure_instancep(obj));
    6688. 

  6688. 

  6689. /* the position of the last const (or doc or lalist!) */
    6690. 

  6690. #define Cclosure_last_const(obj)  (Cclosure_length(obj) - 1 -           \
    6691. 

  6691.    (sizeof(*(Cclosure)0) - offsetofa(srecord_,recdata))/sizeof(gcv_object_t))
    6692. 

  6692. #define ccv_flags_lambda_list_p(ccv_flags)    (((ccv_flags) & bit(1)) != 0)
    6693. 

  6693. #define ccv_flags_documentation_p(ccv_flags)  (((ccv_flags) & bit(2)) != 0)
    6694. 

  6694. #define ccv_flags_jitc_p(ccv_flags)           (((ccv_flags) & bit(5)) != 0)
    6695. 

  6695. #define cclosure_jitc(closure)  TheCclosure(closure)->clos_consts[Cclosure_last_const(closure)]
    6696. 

  6696. #define cclosure_jitc_p(closure)  ccv_flags_jitc_p(TheCodevec(TheCclosure(closure)->clos_codevec)->ccv_flags)
    6697. 

  6697. 

  6698. /* A compiled LISP-function gets its arguments on the STACK
    6699. 

  6699.  and returns its values in MULTIPLE_VALUE_SPACE.
    6700. 

  6700.  It does not return a value as a C-function. */
    6701. 

  6701.   /* Return of multiple values is completely done through
    6702. 

  6702.    MULTIPLE_VALUE_SPACE. As C-function: result-type Values. */
    6703. 

  6703.   #ifndef Values
    6704. 

  6704.     typedef void Values;
    6705. 

  6705.   #endif
    6706. 

  6706.   /* To pass a type of the value Values: return_Values(...); */
    6707. 

  6707.   #define return_Values  return_void
    6708. 

  6708.   /* A Lisp-function is a pointer to a C-function without returned value. */
    6709. 

  6709.   typedef Values (*lisp_function_t)();
    6710. 

  6710. /* If this is changed, every call of a C-function with the result type
    6711. 

  6711.  'Values' (especially 'funcall', 'apply', 'eval') is to be checked. */
    6712. 

  6712. %% puts("typedef void Values;"); /* emit_typedef useless: no sizeof(void) */
    6713. 

  6713. %% emit_typedef_f("Values (*%s)()","lisp_function_t");
    6714. 

  6714. 

  6715. /* FSUBRs
    6716. 

  6716.  As C-functions: of type fsubr_function_t (no arguments, no value): */
    6717. 

  6717. typedef Values fsubr_function_t (void);
    6718. 

  6718. /* The addesses of these C-functions are jumped to directly
    6719. 

  6719.  For SAVEMEM/LOADMEM there is a table containing all FSUBRs. */
    6720. 

  6720. typedef fsubr_function_t * fsubr_t;
    6721. 

  6721. /* Signature of FSUBRs in the Lisp-way:
    6722. 

  6722.          argtype          short for the argument type     fsubr_argtype_t
    6723. 

  6723.          req_count        number of required parameters   uintW
    6724. 

  6724.          opt_count        number of optional parameters   uintW
    6725. 

  6725.          body_flag        Body-Flag                       fsubr_body_t
    6726. 

  6726.  The component body_flag contains one uintW, but we mean: */
    6727. 

  6727. typedef enum {
    6728. 

  6728.   fsubr_nobody,
    6729. 

  6729.   fsubr_body
    6730. 

  6730. } fsubr_body_t;
    6731. 

  6731. /* The component argtype contains a Fixnum, but it's supposed to be: */
    6732. 

  6732. typedef enum {
    6733. 

  6733.   fsubr_argtype_1_0_nobody,
    6734. 

  6734.   fsubr_argtype_2_0_nobody,
    6735. 

  6735.   fsubr_argtype_1_1_nobody,
    6736. 

  6736.   fsubr_argtype_2_1_nobody,
    6737. 

  6737.   fsubr_argtype_0_body,
    6738. 

  6738.   fsubr_argtype_1_body,
    6739. 

  6739.   fsubr_argtype_2_body
    6740. 

  6740. } fsubr_argtype_t;
    6741. 

  6741. /* conversion: see SPVW:
    6742. 

  6742.  extern fsubr_argtype_t fsubr_argtype (uintW req_count, uintW opt_count, fsubr_body_t body_flag); */
    6743. 

  6743. 

  6744. /* SUBRs
    6745. 

  6745.  SUBR table entry: */
    6746. 

  6746. typedef struct {
    6747. 

  6747.   XRECORD_HEADER
    6748. 

  6748.   gcv_object_t name     _attribute_aligned_object_; /* name */
    6749. 

  6749.   gcv_object_t keywords _attribute_aligned_object_; /* NIL or vector with the keywords */
    6750. 

  6750.   lisp_function_t function;     /* function */
    6751. 

  6751.   uintW argtype;                /* short for the argument-type */
    6752. 

  6752.   uintW req_count;              /* number of required parameters */
    6753. 

  6753.   uintW opt_count;              /* number of optional parameters */
    6754. 

  6754.   uintB rest_flag;              /* flag for arbitrary number of arguments */
    6755. 

  6755.   uintB key_flag;               /* flag for keywords */
    6756. 

  6756.   uintW key_count;              /* number of keyword parameter */
    6757. 

  6757.   uintB seclass;                /* side-effect class */
    6758. 

  6758.   uintB fastcmp;                /* fast comparison method */
    6759. 

  6759.   /* If necessary, add fillers here to ensure sizeof(subr_t)
    6760. 

  6760.      is a multiple of varobject_alignment. */
    6761. 

  6761. } subr_t
    6762. 

  6762. #if defined(HEAPCODES) && (alignment_long < 4) && defined(GNU)
    6763. 

  6763. /* Force all Subrs to be allocated with a 4-byte alignment. GC needs this. */
    6764. 

  6764.   __attribute__ ((aligned (4)))
    6765. 

  6765. #endif
    6766. 

  6766. ;
    6767. 

  6767. typedef subr_t *  Subr;
    6768. 

  6768. /* Compile-time check: sizeof(subr_t) is a multiple of varobject_alignment. */
    6769. 

  6769. typedef int subr_size_check[1 - 2 * (int)(sizeof(subr_t) % varobject_alignment)];
    6770. 

  6770. /* GC needs information where objects are in here: */
    6771. 

  6771. #define subr_length  2
    6772. 

  6772. #define subr_xlength  (sizeof(*(Subr)0)-offsetofa(record_,recdata)-subr_length*sizeof(gcv_object_t))
    6773. 

  6773. /* the rest_flag component is a uintB, while we really mean: */
    6774. 

  6774. typedef enum {
    6775. 

  6775.   subr_norest,
    6776. 

  6776.   subr_rest
    6777. 

  6777. } subr_rest_t;
    6778. 

  6778. /* the key_flag component is a uintB, while we really mean: */
    6779. 

  6779. typedef enum {
    6780. 

  6780.   subr_nokey,
    6781. 

  6781.   subr_key,
    6782. 

  6782.   subr_key_allow
    6783. 

  6783. } subr_key_t;
    6784. 

  6784. /* the argtype component is a uintW, while we really mean: */
    6785. 

  6785. typedef enum {
    6786. 

  6786.   subr_argtype_0_0,
    6787. 

  6787.   subr_argtype_1_0,
    6788. 

  6788.   subr_argtype_2_0,
    6789. 

  6789.   subr_argtype_3_0,
    6790. 

  6790.   subr_argtype_4_0,
    6791. 

  6791.   subr_argtype_5_0,
    6792. 

  6792.   subr_argtype_6_0,
    6793. 

  6793.   subr_argtype_0_1,
    6794. 

  6794.   subr_argtype_1_1,
    6795. 

  6795.   subr_argtype_2_1,
    6796. 

  6796.   subr_argtype_3_1,
    6797. 

  6797.   subr_argtype_4_1,
    6798. 

  6798.   subr_argtype_0_2,
    6799. 

  6799.   subr_argtype_1_2,
    6800. 

  6800.   subr_argtype_2_2,
    6801. 

  6801.   subr_argtype_3_2,
    6802. 

  6802.   subr_argtype_0_3,
    6803. 

  6803.   subr_argtype_1_3,
    6804. 

  6804.   subr_argtype_2_3,
    6805. 

  6805.   subr_argtype_0_4,
    6806. 

  6806.   subr_argtype_0_5,
    6807. 

  6807.   subr_argtype_0_0_rest,
    6808. 

  6808.   subr_argtype_1_0_rest,
    6809. 

  6809.   subr_argtype_2_0_rest,
    6810. 

  6810.   subr_argtype_3_0_rest,
    6811. 

  6811.   subr_argtype_0_0_key,
    6812. 

  6812.   subr_argtype_1_0_key,
    6813. 

  6813.   subr_argtype_2_0_key,
    6814. 

  6814.   subr_argtype_3_0_key,
    6815. 

  6815.   subr_argtype_4_0_key,
    6816. 

  6816.   subr_argtype_0_1_key,
    6817. 

  6817.   subr_argtype_1_1_key,
    6818. 

  6818.   subr_argtype_1_2_key
    6819. 

  6819. } subr_argtype_t;
    6820. 

  6820. /* Conversion: see SPVW:
    6821. 

  6821.  extern subr_argtype_t subr_argtype (uintW req_count, uintW opt_count, subr_rest_t rest_flag, subr_key_t key_flag); */
    6822. 

  6822. %% 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);
    6823. 

  6823. %% #if defined(HEAPCODES) && (alignment_long < 4) && defined(GNU)
    6824. 

  6824. %%   strcat(buf," __attribute__ ((aligned (4)))");
    6825. 

  6825. %% #endif
    6826. 

  6826. %% emit_typedef_f(buf,"subr_t");
    6827. 

  6827. %% emit_typedef("subr_t *","Subr");
    6828. 

  6828. %% emit_typedef("enum { subr_norest, subr_rest }","subr_rest_t");
    6829. 

  6829. %% emit_typedef("enum { subr_nokey, subr_key, subr_key_allow }","subr_key_t");
    6830. 

  6830. 

  6831. /* side-effect class is really seclass_t: */
    6832. 

  6832. typedef enum {
    6833. 

  6833.   seclass_foldable, /* the function allows Constant-Folding:
    6834. 

  6834.      two calls with identical arguments give the same result,
    6835. 

  6835.      and calls with constant arguments can be evaluated at compile time.
    6836. 

  6836.      In particular, no side effects, do not depend on global variables or such,
    6837. 

  6837.      do not even look "inside" their arguments */
    6838. 

  6838.   seclass_no_se, /* no side effects, do not depend on global variables or such,
    6839. 

  6839.      do not even look "inside" their arguments, but not "foldable". */
    6840. 

  6840.   seclass_read, /* no side effects, but depend on global variables
    6841. 

  6841.      or look "inside" their arguments. */
    6842. 

  6842.   seclass_write, /* only side effects: does not read anything,
    6843. 

  6843.      just sets some global variables. */
    6844. 

  6844.   seclass_default /* may do side effects */
    6845. 

  6845. } seclass_t;
    6846. 

  6846. %% puts("enum { seclass_foldable, seclass_no_se, seclass_read, seclass_write, seclass_default};");
    6847. 

  6847. 

  6848. /* fast comparison method is really fastcmp_t:
    6849. 

  6849.  when you want to make another comparison function bypass FUNCALL in
    6850. 

  6850.  :TEST/:TEST-NOT sequence functions, you need to
    6851. 

  6851.  -- add fastcmp_FOO here and
    6852. 

  6852.  -- augment funarg.d:check_test_args(), and
    6853. 

  6853.  -- add call_test_FOO and call_test_not_FOO in funarg.d */
    6854. 

  6854. typedef enum {
    6855. 

  6855.   fastcmp_none=0,   /* no special tricks */
    6856. 

  6856.   fastcmp_eq,       /* EQ */
    6857. 

  6857.   fastcmp_eql,      /* EQL */
    6858. 

  6858.   fastcmp_equal,    /* EQUAL */
    6859. 

  6859.   fastcmp_equalp,   /* EQUALP */
    6860. 

  6860.   fastcmp_for_broken_compilers_that_dont_like_trailing_commas
    6861. 

  6861. } fastcmp_t;
    6862. 

  6862. 

  6863. /* Small-Read-Label */
    6864. 

  6864. #ifdef TYPECODES
    6865. 

  6865.   #define make_small_read_label(n)  \
    6866. 

  6866.     type_data_object(system_type, ((uintV)(n)<<1) + bit(0))
    6867. 

  6867.   #define small_read_label_integer_p(obj)  \
    6868. 

  6868.     (posfixnump(obj) && (posfixnum_to_V(obj) < vbit(oint_data_len-2)))
    6869. 

  6869.   #define small_read_label_value(obj)  \
    6870. 

  6870.     fixnum((as_oint(obj) >> (oint_data_shift+1)) & (vbit(oint_data_len-2)-1))
    6871. 

  6871. #else
    6872. 

  6872.   #define make_small_read_label(n)  \
    6873. 

  6873.     type_data_object(small_read_label_type, (uintV)(n))
    6874. 

  6874.   #define small_read_label_integer_p(obj)  posfixnump(obj)
    6875. 

  6875.   #define small_read_label_value(obj)  \
    6876. 

  6876.     fixnum((as_oint(obj) >> oint_data_shift) & (vbit(oint_data_len)-1))
    6877. 

  6877. #endif
    6878. 

  6878. 

  6879. /* Machine pointers:
    6880. 

  6880.  make_machine(ptr) */
    6881. 

  6881. #ifdef TYPECODES
    6882. 

  6882.   #define make_machine(ptr)  type_pointer_object(machine_type,ptr)
    6883. 

  6883. #else
    6884. 

  6884.   #if defined(WIDE_AUXI)
    6885. 

  6885.     #define make_machine(ptr)  as_object_with_auxi((aint)(ptr)+machine_bias)
    6886. 

  6886.   #else
    6887. 

  6887.     #define make_machine(ptr)  as_object((oint)(ptr)+machine_bias)
    6888. 

  6888.   #endif
    6889. 

  6889. #endif
    6890. 

  6890. %% export_def(make_machine(ptr));
    6891. 

  6891. 

  6892. #ifdef MULTITHREAD
    6893. 

  6893. 

  6894. typedef struct {
    6895. 

  6895.   XRECORD_HEADER
    6896. 

  6896.   gcv_object_t xth_name _attribute_aligned_object_; /* name */
    6897. 

  6897.   gcv_object_t xth_next _attribute_aligned_object_; /* next thread */
    6898. 

  6898.   gcv_object_t xth_prev _attribute_aligned_object_; /* previous thread */
    6899. 

  6899.   gcv_object_t *xth_tlvs;              /* thread-local values */
    6900. 

  6900.   gcv_object_t *xth_stack;             /* the thread stack */
    6901. 

  6901.   struct backtrace_t *xth_bt;          /* the backtrace */
    6902. 

  6902.   xthread_t xth_system;                /* OS object */
    6903. 

  6903. } * Thread;
    6904. 

  6904. #define thread_length  2
    6905. 

  6905. #define thread_xlength (sizeof(*(Thread)0)-offsetofa(record_,recdata)-thread_length*sizeof(gcv_object_t))
    6906. 

  6906. 

  6907. typedef struct {
    6908. 

  6908.   XRECORD_HEADER
    6909. 

  6909.   gcv_object_t xmu_name _attribute_aligned_object_; /* name */
    6910. 

  6910.   xmutex_t xmu_system;                              /* OS object */
    6911. 

  6911. } * Mutex;
    6912. 

  6912. #define mutex_length  1
    6913. 

  6913. #define mutex_xlength (sizeof(*(Mutex)0)-offsetofa(record_,recdata)-mutex_length*sizeof(gcv_object_t))
    6914. 

  6914. 

  6915. typedef struct {
    6916. 

  6916.   XRECORD_HEADER
    6917. 

  6917.   gcv_object_t xco_name _attribute_aligned_object_; /* name */
    6918. 

  6918.   xcondition_t xco_system;                          /* OS object */
    6919. 

  6919. } * Exemption;
    6920. 

  6920. #define exemption_length  1
    6921. 

  6921. #define exemption_xlength (sizeof(*(Exemption)0)-offsetofa(record_,recdata)-exemption_length*sizeof(gcv_object_t))
    6922. 

  6922. 

  6923. #endif
    6924. 

  6924. 

  6925. /* Pointer to machine code
    6926. 

  6926.  make_machine_code(ptr) */
    6927. 

  6927. #if defined(TYPECODES) || (log2_C_CODE_ALIGNMENT >= 2)
    6928. 

  6928.   #define make_machine_code(ptr)  make_machine(ptr)
    6929. 

  6929. #elif defined(HPPA)
    6930. 

  6930.   #define make_machine_code(ptr)  make_machine((uintP)(ptr)&~(uintP)3)
    6931. 

  6931. #else
    6932. 

  6932.   #define make_machine_code(ptr)  make_machine((uintP)(ptr)<<(2-log2_C_CODE_ALIGNMENT))
    6933. 

  6933. #endif
    6934. 

  6934. 

  6935. /* System-Pointer */
    6936. 

  6936. #define make_system(data)  \
    6937. 

  6937.   type_data_object(system_type, vbit(oint_data_len-1) | bit(0) | ((vbitm(oint_data_len)-1) & (data)))
    6938. 

  6938. /* all such go into the special print routine io.d:pr_system() */
    6939. 

  6939. %% export_def(make_system(data));
    6940. 

  6940. 

  6941. /* missing value */
    6942. 

  6942. #define unbound  make_system(0xFFFFFFUL)
    6943. 

  6943. %% export_def(unbound);
    6944. 

  6944. 

  6945. /* missing object (internal use only): */
    6946. 

  6946. #define nullobj  make_machine(0)  /* = as_object((oint)0) */
    6947. 

  6947. #ifdef DEBUG_GCSAFETY
    6948. 

  6948.   #define gcv_nullobj  (gcv_object_t)nullobj
    6949. 

  6949. #else
    6950. 

  6950.   #define gcv_nullobj  nullobj
    6951. 

  6951. #endif
    6952. 

  6952. %% export_def(nullobj);
    6953. 

  6953. %% export_def(gcv_nullobj);
    6954. 

  6954. 

  6955. 

  6956. /* cgci_pointable(obj)  converts a certainly GC-invariant object to an aint.
    6957. 

  6957.  pgci_pointable(obj)  converts a possibly GC-invariant object to an aint.
    6958. 

  6958.  ngci_pointable(obj)  converts a not GC-invariant object to an aint. */
    6959. 

  6959. #if defined(DEBUG_GCSAFETY)
    6960. 

  6960.   static inline aint cgci_pointable (object obj) {
    6961. 

  6961.     return obj.one_o;
    6962. 

  6962.   }
    6963. 

  6963.   static inline aint cgci_pointable (gcv_object_t obj) {
    6964. 

  6964.     return obj.one_o;
    6965. 

  6965.   }
    6966. 

  6966.   static inline aint pgci_pointable (object obj) {
    6967. 

  6967.     if (!(gcinvariant_object_p(obj) || gcinvariant_symbol_p(obj)
    6968. 

  6968.           || obj.allocstamp == alloccount || nonimmsubrp(obj)))
    6969. 

  6969.       abort();
    6970. 

  6970.     nonimmprobe(obj.one_o);
    6971. 

  6971.     return obj.one_o;
    6972. 

  6972.   }
    6973. 

  6973.   static inline aint pgci_pointable (gcv_object_t obj) {
    6974. 

  6974.     nonimmprobe(obj.one_o);
    6975. 

  6975.     return obj.one_o;
    6976. 

  6976.   }
    6977. 

  6977.   static inline aint ngci_pointable (object obj) {
    6978. 

  6978.     if (!(gcinvariant_symbol_p(obj)
    6979. 

  6979.           || obj.allocstamp == alloccount || nonimmsubrp(obj)))
    6980. 

  6980.       abort();
    6981. 

  6981.     nonimmprobe(obj.one_o);
    6982. 

  6982.     return obj.one_o;
    6983. 

  6983.   }
    6984. 

  6984.   static inline aint ngci_pointable (gcv_object_t obj) {
    6985. 

  6985.     nonimmprobe(obj.one_o);
    6986. 

  6986.     return obj.one_o;
    6987. 

  6987.   }
    6988. 

  6988. #elif defined(WIDE_AUXI)
    6989. 

  6989.   #define cgci_pointable(obj)  (obj).one_o
    6990. 

  6990.   #define pgci_pointable(obj)  (obj).one_o
    6991. 

  6991.   #define ngci_pointable(obj)  (obj).one_o
    6992. 

  6992. #else
    6993. 

  6993.   #define cgci_pointable(obj)  as_oint(obj)
    6994. 

  6994.   #define pgci_pointable(obj)  as_oint(obj)
    6995. 

  6995.   #define ngci_pointable(obj)  as_oint(obj)
    6996. 

  6996. #endif
    6997. 

  6997. %% #if defined(DEBUG_GCSAFETY)
    6998. 

  6998. %%   puts("static inline aint cgci_pointable (object obj) { return obj.one_o; }");
    6999. 

  6999. %%   puts("static inline aint cgci_pointable (gcv_object_t obj) { return obj.one_o; }");
    7000. 

  7000. %%   puts("static inline aint pgci_pointable (object obj) { if (!(gcinvariant_object_p(obj) || gcinvariant_symbol_p(obj) || obj.allocstamp == alloccount || nonimmsubrp(obj))) abort(); nonimmprobe(obj.one_o); return obj.one_o; }");
    7001. 

  7001. %%   puts("static inline aint pgci_pointable (gcv_object_t obj) { nonimmprobe(obj.one_o); return obj.one_o; }");
    7002. 

  7002. %%   puts("static inline aint ngci_pointable (object obj) { if (!(gcinvariant_symbol_p(obj) || obj.allocstamp == alloccount || nonimmsubrp(obj))) abort(); nonimmprobe(obj.one_o); return obj.one_o; }");
    7003. 

  7003. %%   puts("static inline aint ngci_pointable (gcv_object_t obj) { nonimmprobe(obj.one_o); return obj.one_o; }");
    7004. 

  7004. %% #else
    7005. 

  7005. %%   export_def(cgci_pointable(obj));
    7006. 

  7006. %%   export_def(pgci_pointable(obj));
    7007. 

  7007. %%   export_def(ngci_pointable(obj));
    7008. 

  7008. %% #endif
    7009. 

  7009. 

  7010. /* TheCons(object) yields the Cons that's equivalent to object.
    7011. 

  7011.  The information that it is a Cons has to be put into it.
    7012. 

  7012.  The other type conversions are similar. */
    7013. 

  7013. #ifdef TYPECODES
    7014. 

  7014.   #ifdef DEBUG_GCSAFETY
    7015. 

  7015.     #define cgci_types_pointable(ORed_types,obj)  cgci_pointable(obj)
    7016. 

  7016.     #define pgci_types_pointable(ORed_types,obj)  pgci_pointable(obj)
    7017. 

  7017.     #define ngci_types_pointable(ORed_types,obj)  ngci_pointable(obj)
    7018. 

  7018.   #else
    7019. 

  7019.     #define cgci_types_pointable(ORed_types,obj)  types_pointable(ORed_types,obj)
    7020. 

  7020.     #define pgci_types_pointable(ORed_types,obj)  types_pointable(ORed_types,obj)
    7021. 

  7021.     #define ngci_types_pointable(ORed_types,obj)  types_pointable(ORed_types,obj)
    7022. 

  7022.   #endif
    7023. 

  7023.   #define TheCons(obj)  ((Cons)(ngci_types_pointable(cons_type,obj)))
    7024. 

  7024.   #define TheRatio(obj)  ((Ratio)(ngci_types_pointable(ratio_type|bit(sign_bit_t),obj)))
    7025. 

  7025.   #define TheComplex(obj)  ((Complex)(ngci_types_pointable(complex_type,obj)))
    7026. 

  7026.   #define TheSymbol(obj)  ((Symbol)(ngci_types_pointable(symbol_type,obj)))
    7027. 

  7027.   #if (oint_symbolflags_shift==oint_type_shift)
    7028. 

  7028.   #define TheSymbolflagged(obj)  ((Symbol)(ngci_types_pointable(symbol_type|bit(active_bit)|bit(dynam_bit)|bit(svar_bit),obj)))
    7029. 

  7029.   #else
    7030. 

  7030.   #define TheSymbolflagged(obj)  TheSymbol(symbol_without_flags(obj))
    7031. 

  7031.   #endif
    7032. 

  7032.   #define TheBignum(obj)  ((Bignum)(ngci_types_pointable(bignum_type|bit(sign_bit_t),obj)))
    7033. 

  7033.   #ifndef IMMEDIATE_FFLOAT
    7034. 

  7034.   #define TheFfloat(obj)  ((Ffloat)(ngci_types_pointable(ffloat_type|bit(sign_bit_t),obj)))
    7035. 

  7035.   #endif
    7036. 

  7036.   #define TheDfloat(obj)  ((Dfloat)(ngci_types_pointable(dfloat_type|bit(sign_bit_t),obj)))
    7037. 

  7037.   #define TheLfloat(obj)  ((Lfloat)(ngci_types_pointable(lfloat_type|bit(sign_bit_t),obj)))
    7038. 

  7038.   #define TheSarray(obj)  ((Sarray)(ngci_types_pointable(sbvector_type|sb2vector_type|sb4vector_type|sb8vector_type|sb16vector_type|sb32vector_type|sstring_type|svector_type,obj)))
    7039. 

  7039.   #define TheSbvector(obj)  ((Sbvector)(ngci_types_pointable(sbvector_type|sb2vector_type|sb4vector_type|sb8vector_type|sb16vector_type|sb32vector_type,obj)))
    7040. 

  7040.   #define TheCodevec(obj)  ((Codevec)(ngci_types_pointable(sb8vector_type,obj)))
    7041. 

  7041.   #define TheS8string(obj)  ((S8string)(ngci_types_pointable(sstring_type,obj)))
    7042. 

  7042.   #define TheS16string(obj)  ((S16string)(ngci_types_pointable(sstring_type,obj)))
    7043. 

  7043.   #define TheS32string(obj)  ((S32string)(ngci_types_pointable(sstring_type,obj)))
    7044. 

  7044.   #define TheSnstring(obj)  ((Snstring)(ngci_types_pointable(sstring_type,obj)))
    7045. 

  7045.   #define TheSistring(obj)  ((Sistring)(ngci_types_pointable(sstring_type,obj)))
    7046. 

  7046.   #define TheSstring(obj)  ((Sstring)(ngci_types_pointable(sstring_type,obj)))
    7047. 

  7047.   #define TheSvector(obj)  ((Svector)(ngci_types_pointable(svector_type,obj)))
    7048. 

  7048.   #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)))
    7049. 

  7049.   #define TheRecord(obj)  ((Record)(ngci_types_pointable(closure_type|structure_type|stream_type|orecord_type|instance_type|lrecord_type,obj)))
    7050. 

  7050.   #define TheLrecord(obj)  ((Lrecord)(ngci_types_pointable(lrecord_type,obj)))
    7051. 

  7051.   #define TheSrecord(obj)  ((Srecord)(ngci_types_pointable(closure_type|structure_type|orecord_type|instance_type,obj)))
    7052. 

  7052.   #define TheXrecord(obj)  ((Xrecord)(ngci_types_pointable(stream_type|orecord_type,obj)))
    7053. 

  7053.   #define ThePackage(obj)  ((Package)(ngci_types_pointable(orecord_type,obj)))
    7054. 

  7054.   #define TheHashtable(obj)  ((Hashtable)(ngci_types_pointable(orecord_type,obj)))
    7055. 

  7055.   #define TheReadtable(obj)  ((Readtable)(ngci_types_pointable(orecord_type,obj)))
    7056. 

  7056.   #define ThePathname(obj)  ((Pathname)(ngci_types_pointable(orecord_type,obj)))
    7057. 

  7057.   #ifdef LOGICAL_PATHNAMES
    7058. 

  7058.   #define TheLogpathname(obj)  ((Logpathname)(ngci_types_pointable(orecord_type,obj)))
    7059. 

  7059.   #endif
    7060. 

  7060.   #define The_Random_state(obj)  ((Random_state)(ngci_types_pointable(orecord_type,obj)))
    7061. 

  7061.   #define TheByte(obj)  ((Byte)(ngci_types_pointable(orecord_type,obj)))
    7062. 

  7062.   #define TheFsubr(obj)  ((Fsubr)(ngci_types_pointable(orecord_type,obj)))
    7063. 

  7063.   #define TheLoadtimeeval(obj)  ((Loadtimeeval)(ngci_types_pointable(orecord_type,obj)))
    7064. 

  7064.   #define TheSymbolmacro(obj)  ((Symbolmacro)(ngci_types_pointable(orecord_type,obj)))
    7065. 

  7065.   #define TheGlobalSymbolmacro(obj)  ((GlobalSymbolmacro)(ngci_types_pointable(orecord_type,obj)))
    7066. 

  7066.   #define TheMacro(obj)  ((Macro)(ngci_types_pointable(orecord_type,obj)))
    7067. 

  7067.   #define TheFunctionMacro(obj)  ((FunctionMacro)(ngci_types_pointable(orecord_type,obj)))
    7068. 

  7068.   #define TheBigReadLabel(obj)  ((BigReadLabel)(ngci_types_pointable(orecord_type,obj)))
    7069. 

  7069.   #define TheEncoding(obj)  ((Encoding)(ngci_types_pointable(orecord_type,obj)))
    7070. 

  7070.   #ifdef FOREIGN
    7071. 

  7071.   #define TheFpointer(obj)  ((Fpointer)(ngci_types_pointable(orecord_type,obj)))
    7072. 

  7072.   #endif
    7073. 

  7073.   #ifdef DYNAMIC_FFI
    7074. 

  7074.   #define TheFaddress(obj)  ((Faddress)(ngci_types_pointable(orecord_type,obj)))
    7075. 

  7075.   #define TheFvariable(obj)  ((Fvariable)(ngci_types_pointable(orecord_type,obj)))
    7076. 

  7076.   #define TheFfunction(obj)  ((Ffunction)(ngci_types_pointable(orecord_type,obj)))
    7077. 

  7077.   #endif
    7078. 

  7078.   #define TheWeakpointer(obj)  ((Weakpointer)(ngci_types_pointable(orecord_type,obj)))
    7079. 

  7079.   #define TheMutableWeakList(obj)  ((MutableWeakList)(ngci_types_pointable(orecord_type,obj)))
    7080. 

  7080.   #define TheWeakList(obj)  ((WeakList)(ngci_types_pointable(lrecord_type,obj)))
    7081. 

  7081.   #define TheWeakAnd(obj)  ((WeakAnd)(ngci_types_pointable(lrecord_type,obj)))
    7082. 

  7082.   #define TheWeakOr(obj)  ((WeakOr)(ngci_types_pointable(lrecord_type,obj)))
    7083. 

  7083.   #define TheWeakmapping(obj)  ((Weakmapping)(ngci_types_pointable(orecord_type,obj)))
    7084. 

  7084.   #define TheWeakAndMapping(obj)  ((WeakAndMapping)(ngci_types_pointable(lrecord_type,obj)))
    7085. 

  7085.   #define TheWeakOrMapping(obj)  ((WeakOrMapping)(ngci_types_pointable(lrecord_type,obj)))
    7086. 

  7086.   #define TheMutableWeakAlist(obj)  ((MutableWeakAlist)(ngci_types_pointable(orecord_type,obj)))
    7087. 

  7087.   #define TheWeakAlist(obj)  ((WeakAlist)(ngci_types_pointable(lrecord_type,obj)))
    7088. 

  7088.   #define TheWeakHashedAlist(obj)  ((WeakHashedAlist)(ngci_types_pointable(lrecord_type,obj)))
    7089. 

  7089.   #define TheFinalizer(obj)  ((Finalizer)(ngci_types_pointable(orecord_type,obj)))
    7090. 

  7090.   #ifdef SOCKET_STREAMS
    7091. 

  7091.   #define TheSocketServer(obj) ((Socket_server)(ngci_types_pointable(orecord_type,obj)))
    7092. 

  7092.   #endif
    7093. 

  7093.   #ifdef YET_ANOTHER_RECORD
    7094. 

  7094.   #define TheYetanother(obj)  ((Yetanother)(ngci_types_pointable(orecord_type,obj)))
    7095. 

  7095.   #endif
    7096. 

  7096.   #define TheStream(obj)  ((Stream)(ngci_types_pointable(stream_type,obj)))
    7097. 

  7097.   #define TheStructure(obj)  ((Structure)(ngci_types_pointable(structure_type,obj)))
    7098. 

  7098.   #define TheClosure(obj)  ((Closure)(ngci_types_pointable(closure_type,obj)))
    7099. 

  7099.   #define TheIclosure(obj)  ((Iclosure)(ngci_types_pointable(closure_type,obj)))
    7100. 

  7100.   #define TheCclosure(obj)  ((Cclosure)(ngci_types_pointable(closure_type,obj)))
    7101. 

  7101.   #define TheInstance(obj)  ((Instance)(ngci_types_pointable(instance_type|closure_type,obj)))
    7102. 

  7102.   #define TheSubr(obj)  ((Subr)(cgci_types_pointable(subr_type,obj)))
    7103. 

  7103.   #define TheFramepointer(obj)  ((gcv_object_t*)(cgci_types_pointable(system_type,obj)))
    7104. 

  7104.   #define TheMachine(obj)  ((void*)(cgci_types_pointable(machine_type,obj)))
    7105. 

  7105.   #define TheMachineCode(obj)  TheMachine(obj)
    7106. 

  7106.   #define ThePseudofun(obj)  ((Pseudofun)TheMachineCode(obj))
    7107. 

  7107.   #ifdef FOREIGN_HANDLE
    7108. 

  7108.   /* pack Handle in Sbvector */
    7109. 

  7109.   #define TheHandle(obj)  (*(Handle*)(&TheSbvector(obj)->data[0]))
    7110. 

  7110.   #else
    7111. 

  7111.   /* pack Handle in Fixnum>=0 */
    7112. 

  7112.   #define TheHandle(obj)  ((Handle)posfixnum_to_V(obj))
    7113. 

  7113.   #endif
    7114. 

  7114.   /* variable length object: */
    7115. 

  7115.   #define TheVarobject(obj)                                              \
    7116. 

  7116.     ((Varobject)                                                         \
    7117. 

  7117.      (ngci_types_pointable                                               \
    7118. 

  7118.       (sbvector_type|sb2vector_type|sb4vector_type|sb8vector_type        \
    7119. 

  7119.          |sb16vector_type|sb32vector_type                                \
    7120. 

  7120.        |sstring_type|svector_type                                        \
    7121. 

  7121.        |mdarray_type                                                     \
    7122. 

  7122.        |bvector_type|b2vector_type|b4vector_type|b8vector_type           \
    7123. 

  7123.          |b16vector_type|b32vector_type                                  \
    7124. 

  7124.        |string_type|vector_type                                          \
    7125. 

  7125.        |closure_type|structure_type|stream_type|orecord_type             \
    7126. 

  7126.        |instance_type|lrecord_type|symbol_type                           \
    7127. 

  7127.        |bignum_type|ffloat_type|dfloat_type|lfloat_type|bit(sign_bit_t), \
    7128. 

  7128.        obj                                                               \
    7129. 

  7129.     )))
    7130. 

  7130.   /* Object that represents a pointer into the memory: */
    7131. 

  7131.   #define ThePointer(obj)                                               \
    7132. 

  7132.     (pgci_types_pointable                                               \
    7133. 

  7133.      (sbvector_type|sb2vector_type|sb4vector_type|sb8vector_type        \
    7134. 

  7134.         |sb16vector_type|sb32vector_type                                \
    7135. 

  7135.       |sstring_type|svector_type                                        \
    7136. 

  7136.       |mdarray_type                                                     \
    7137. 

  7137.       |bvector_type|b2vector_type|b4vector_type|b8vector_type           \
    7138. 

  7138.         |b16vector_type|b32vector_type                                  \
    7139. 

  7139.       |string_type|vector_type                                          \
    7140. 

  7140.       |closure_type|structure_type|stream_type|orecord_type             \
    7141. 

  7141.       |instance_type|lrecord_type|symbol_type                           \
    7142. 

  7142.       |cons_type                                                        \
    7143. 

  7143.       |bignum_type|ffloat_type|dfloat_type|lfloat_type                  \
    7144. 

  7144.       |ratio_type|complex_type|bit(sign_bit_t),                         \
    7145. 

  7145.       obj                                                               \
    7146. 

  7146.     ))
    7147. 

  7147.  #ifdef MULTITHREAD
    7148. 

  7148.   #define TheThread(obj)  ((Thread)(ngci_types_pointable(orecord_type,obj)))
    7149. 

  7149.   #define TheMutex(obj)   ((Mutex)(ngci_types_pointable(orecord_type,obj)))
    7150. 

  7150.   #define TheExemption(obj) ((Exemption)(ngci_types_pointable(orecord_type,obj)))
    7151. 

  7151.  #endif
    7152. 

  7152. #else /* no TYPECODES */
    7153. 

  7153.   #define TheCons(obj)  ((Cons)(ngci_pointable(obj)-cons_bias))
    7154. 

  7154.   #define TheRatio(obj)  ((Ratio)(ngci_pointable(obj)-varobject_bias))
    7155. 

  7155.   #define TheComplex(obj)  ((Complex)(ngci_pointable(obj)-varobject_bias))
    7156. 

  7156.   #define TheSymbol(obj)  ((Symbol)(ngci_pointable(obj)-varobject_bias))
    7157. 

  7157.   #define TheSymbolflagged(obj)  TheSymbol(symbol_without_flags(obj))
    7158. 

  7158.   #define TheBignum(obj)  ((Bignum)(ngci_pointable(obj)-varobject_bias))
    7159. 

  7159.   #define TheFfloat(obj)  ((Ffloat)(ngci_pointable(obj)-varobject_bias))
    7160. 

  7160.   #define TheDfloat(obj)  ((Dfloat)(ngci_pointable(obj)-varobject_bias))
    7161. 

  7161.   #define TheLfloat(obj)  ((Lfloat)(ngci_pointable(obj)-varobject_bias))
    7162. 

  7162.   #define TheSarray(obj)  ((Sarray)(ngci_pointable(obj)-varobject_bias))
    7163. 

  7163.   #define TheSbvector(obj)  ((Sbvector)(ngci_pointable(obj)-varobject_bias))
    7164. 

  7164.   #define TheCodevec(obj)  ((Codevec)TheSbvector(obj))
    7165. 

  7165.   #define TheS8string(obj)  ((S8string)(ngci_pointable(obj)-varobject_bias))
    7166. 

  7166.   #define TheS16string(obj)  ((S16string)(ngci_pointable(obj)-varobject_bias))
    7167. 

  7167.   #define TheS32string(obj)  ((S32string)(ngci_pointable(obj)-varobject_bias))
    7168. 

  7168.   #define TheSnstring(obj)  ((Snstring)(ngci_pointable(obj)-varobject_bias))
    7169. 

  7169.   #define TheSistring(obj)  ((Sistring)(ngci_pointable(obj)-varobject_bias))
    7170. 

  7170.   #define TheSstring(obj)  ((Sstring)(ngci_pointable(obj)-varobject_bias))
    7171. 

  7171.   #define TheSvector(obj)  ((Svector)(ngci_pointable(obj)-varobject_bias))
    7172. 

  7172.   #define TheIarray(obj)  ((Iarray)(ngci_pointable(obj)-varobject_bias))
    7173. 

  7173.   #define TheRecord(obj)  ((Record)(ngci_pointable(obj)-varobject_bias))
    7174. 

  7174.   #define TheLrecord(obj)  ((Lrecord)(ngci_pointable(obj)-varobject_bias))
    7175. 

  7175.   #define TheSrecord(obj)  ((Srecord)(ngci_pointable(obj)-varobject_bias))
    7176. 

  7176.   #define TheXrecord(obj)  ((Xrecord)(ngci_pointable(obj)-varobject_bias))
    7177. 

  7177.   #define ThePackage(obj)  ((Package)(ngci_pointable(obj)-varobject_bias))
    7178. 

  7178.   #define TheHashtable(obj)  ((Hashtable)(ngci_pointable(obj)-varobject_bias))
    7179. 

  7179.   #define TheReadtable(obj)  ((Readtable)(ngci_pointable(obj)-varobject_bias))
    7180. 

  7180.   #define ThePathname(obj)  ((Pathname)(ngci_pointable(obj)-varobject_bias))
    7181. 

  7181.   #ifdef LOGICAL_PATHNAMES
    7182. 

  7182.   #define TheLogpathname(obj)  ((Logpathname)(ngci_pointable(obj)-varobject_bias))
    7183. 

  7183.   #endif
    7184. 

  7184.   #define The_Random_state(obj)  ((Random_state)(ngci_pointable(obj)-varobject_bias))
    7185. 

  7185.   #define TheByte(obj)  ((Byte)(ngci_pointable(obj)-varobject_bias))
    7186. 

  7186.   #define TheFsubr(obj)  ((Fsubr)(ngci_pointable(obj)-varobject_bias))
    7187. 

  7187.   #define TheLoadtimeeval(obj)  ((Loadtimeeval)(ngci_pointable(obj)-varobject_bias))
    7188. 

  7188.   #define TheSymbolmacro(obj)  ((Symbolmacro)(ngci_pointable(obj)-varobject_bias))
    7189. 

  7189.   #define TheGlobalSymbolmacro(obj)  ((GlobalSymbolmacro)(ngci_pointable(obj)-varobject_bias))
    7190. 

  7190.   #define TheMacro(obj)  ((Macro)(ngci_pointable(obj)-varobject_bias))
    7191. 

  7191.   #define TheFunctionMacro(obj)  ((FunctionMacro)(ngci_pointable(obj)-varobject_bias))
    7192. 

  7192.   #define TheBigReadLabel(obj)  ((BigReadLabel)(ngci_pointable(obj)-varobject_bias))
    7193. 

  7193.   #define TheEncoding(obj)  ((Encoding)(ngci_pointable(obj)-varobject_bias))
    7194. 

  7194.   #ifdef FOREIGN
    7195. 

  7195.   #define TheFpointer(obj)  ((Fpointer)(ngci_pointable(obj)-varobject_bias))
    7196. 

  7196.   #endif
    7197. 

  7197.   #ifdef DYNAMIC_FFI
    7198. 

  7198.   #define TheFaddress(obj)  ((Faddress)(ngci_pointable(obj)-varobject_bias))
    7199. 

  7199.   #define TheFvariable(obj)  ((Fvariable)(ngci_pointable(obj)-varobject_bias))
    7200. 

  7200.   #define TheFfunction(obj)  ((Ffunction)(ngci_pointable(obj)-varobject_bias))
    7201. 

  7201.   #endif
    7202. 

  7202.   #define TheWeakpointer(obj)  ((Weakpointer)(ngci_pointable(obj)-varobject_bias))
    7203. 

  7203.   #define TheMutableWeakList(obj)  ((MutableWeakList)(ngci_pointable(obj)-varobject_bias))
    7204. 

  7204.   #define TheWeakList(obj)  ((WeakList)(ngci_pointable(obj)-varobject_bias))
    7205. 

  7205.   #define TheWeakAnd(obj)  ((WeakAnd)(ngci_pointable(obj)-varobject_bias))
    7206. 

  7206.   #define TheWeakOr(obj)  ((WeakOr)(ngci_pointable(obj)-varobject_bias))
    7207. 

  7207.   #define TheWeakmapping(obj)  ((Weakmapping)(ngci_pointable(obj)-varobject_bias))
    7208. 

  7208.   #define TheWeakAndMapping(obj)  ((WeakAndMapping)(ngci_pointable(obj)-varobject_bias))
    7209. 

  7209.   #define TheWeakOrMapping(obj)  ((WeakOrMapping)(ngci_pointable(obj)-varobject_bias))
    7210. 

  7210.   #define TheMutableWeakAlist(obj)  ((MutableWeakAlist)(ngci_pointable(obj)-varobject_bias))
    7211. 

  7211.   #define TheWeakAlist(obj)  ((WeakAlist)(ngci_pointable(obj)-varobject_bias))
    7212. 

  7212.   #define TheWeakHashedAlist(obj)  ((WeakHashedAlist)(ngci_pointable(obj)-varobject_bias))
    7213. 

  7213.   #define TheFinalizer(obj)  ((Finalizer)(ngci_pointable(obj)-varobject_bias))
    7214. 

  7214.   #ifdef SOCKET_STREAMS
    7215. 

  7215.   #define TheSocketServer(obj) ((Socket_server)(ngci_pointable(obj)-varobject_bias))
    7216. 

  7216.   #endif
    7217. 

  7217.   #ifdef YET_ANOTHER_RECORD
    7218. 

  7218.   #define TheYetanother(obj)  ((Yetanother)(ngci_pointable(obj)-varobject_bias))
    7219. 

  7219.   #endif
    7220. 

  7220.   #define TheStream(obj)  ((Stream)(ngci_pointable(obj)-varobject_bias))
    7221. 

  7221.   #define TheStructure(obj)  ((Structure)(ngci_pointable(obj)-varobject_bias))
    7222. 

  7222.   #define TheClosure(obj)  ((Closure)(ngci_pointable(obj)-varobject_bias))
    7223. 

  7223.   #define TheIclosure(obj)  ((Iclosure)(ngci_pointable(obj)-varobject_bias))
    7224. 

  7224.   #define TheCclosure(obj)  ((Cclosure)(ngci_pointable(obj)-varobject_bias))
    7225. 

  7225.   #define TheInstance(obj)  ((Instance)(ngci_pointable(obj)-varobject_bias))
    7226. 

  7226.   #define TheSubr(obj)  ((Subr)(cgci_pointable(obj)-subr_bias))
    7227. 

  7227.   #define TheFramepointer(obj)  ((gcv_object_t*)(cgci_pointable(obj)-machine_bias))
    7228. 

  7228.   #define TheMachine(obj)  ((void*)(cgci_pointable(obj)-machine_bias))
    7229. 

  7229.   #if (log2_C_CODE_ALIGNMENT >= 2)
    7230. 

  7230.     #define TheMachineCode(obj)  TheMachine(obj)
    7231. 

  7231.   #elif defined(HPPA)
    7232. 

  7232.     #define TheMachineCode(obj)  ((void*)((uintP)TheMachine(obj)+2))
    7233. 

  7233.   #else
    7234. 

  7234.     #define TheMachineCode(obj)  ((void*)(((uintP)TheMachine(obj)>>(2-log2_C_CODE_ALIGNMENT))|(CODE_ADDRESS_RANGE&~((~(uintP)0)>>(2-log2_C_CODE_ALIGNMENT)))))
    7235. 

  7235.   #endif
    7236. 

  7236.   #define ThePseudofun(obj)  ((Pseudofun)TheMachineCode(obj))
    7237. 

  7237.   #ifdef FOREIGN_HANDLE
    7238. 

  7238.   /* pack Handle in Sbvector */
    7239. 

  7239.   #define TheHandle(obj)  (*(Handle*)(&TheSbvector(obj)->data[0]))
    7240. 

  7240.   #else
    7241. 

  7241.   /* pack Handle in Fixnum>=0 */
    7242. 

  7242.   #define TheHandle(obj)  ((Handle)posfixnum_to_V(obj))
    7243. 

  7243.   #endif
    7244. 

  7244.   /* Object of variable length: */
    7245. 

  7245.   #define TheVarobject(obj)  ((Varobject)(ngci_pointable(obj)-varobject_bias))
    7246. 

  7246.   /* Object, represents a pointer into the memory: */
    7247. 

  7247.   #define ThePointer(obj)  ((void*)(pgci_pointable(obj) & ~(aint)nonimmediate_bias_mask))
    7248. 

  7248.  #ifdef MULTITHREAD
    7249. 

  7249.   #define TheThread(obj)    ((Thread)(ngci_pointable(obj)-varobject_bias))
    7250. 

  7250.   #define TheMutex(obj)     ((Mutex)(ngci_pointable(obj)-varobject_bias))
    7251. 

  7251.   #define TheExemption(obj) ((Exemption)(ngci_pointable(obj)-varobject_bias))
    7252. 

  7252.  #endif
    7253. 

  7253. #endif
    7254. 

  7254. #define TheClassVersion(obj)  ((ClassVersion)TheSvector(obj))
    7255. 

  7255. #define TheSlotDefinition(obj)  ((SlotDefinition)TheInstance(obj))
    7256. 

  7256. #define TheClass(obj)  ((Class)TheInstance(obj))
    7257. 

  7257. %% export_def(TheCons(obj));
    7258. 

  7258. %% #if notused
    7259. 

  7259. %%   export_def(TheRatio(obj));
    7260. 

  7260. %%   export_def(TheComplex(obj));
    7261. 

  7261. %% #endif
    7262. 

  7262. %% export_def(TheSymbol(obj));
    7263. 

  7263. %% export_def(TheBignum(obj));
    7264. 

  7264. %% #if notused
    7265. 

  7265. %%   export_def(TheSarray(obj));
    7266. 

  7266. %% #endif
    7267. 

  7267. %% export_def(TheSbvector(obj));
    7268. 

  7268. %% #ifdef HAVE_SMALL_SSTRING
    7269. 

  7269. %%   export_def(TheS8string(obj));
    7270. 

  7270. %%   export_def(TheS16string(obj));
    7271. 

  7271. %%   export_def(TheS32string(obj));
    7272. 

  7272. %% #endif
    7273. 

  7273. %% export_def(TheSstring(obj));
    7274. 

  7274. %% export_def(TheSvector(obj));
    7275. 

  7275. %% export_def(TheRecord(obj));
    7276. 

  7276. %% export_def(TheSrecord(obj));
    7277. 

  7277. %% #if notused
    7278. 

  7278. %%   export_def(TheXrecord(obj));
    7279. 

  7279. %%   export_def(ThePackage(obj));
    7280. 

  7280. %% #endif
    7281. 

  7281. %% export_def(TheEncoding(obj));
    7282. 

  7282. %% #ifdef FOREIGN
    7283. 

  7283. %%   export_def(TheFpointer(obj));
    7284. 

  7284. %% #endif
    7285. 

  7285. %% export_def(TheStructure(obj));
    7286. 

  7286. %% export_def(TheClosure(obj));
    7287. 

  7287. %% export_def(TheInstance(obj));
    7288. 

  7288. %% export_def(TheSubr(obj));
    7289. 

  7289. %% export_def(TheMachine(obj));
    7290. 

  7290. %% export_def(TheMachineCode(obj));
    7291. 

  7291. %% export_def(ThePseudofun(obj));
    7292. 

  7292. 

  7293. /* Some acronyms
    7294. 

  7294.  Access to objects that are conses: */
    7295. 

  7295. #define Car(obj)  (TheCons(obj)->car)
    7296. 

  7296. #define Cdr(obj)  (TheCons(obj)->cdr)
    7297. 

  7297. /* Access to objects that are symbols: */
    7298. 

  7298. #define Symbol_value(obj)  (TheSymbol(obj)->symvalue)
    7299. 

  7299. #define Symbol_function(obj)  (TheSymbol(obj)->symfunction)
    7300. 

  7300. #define Symbol_plist(obj)  (TheSymbol(obj)->proplist)
    7301. 

  7301. #define Symbol_name(obj)  (TheSymbol(obj)->pname)
    7302. 

  7302. #define Symbol_package(obj)  (TheSymbol(obj)->homepackage)
    7303. 

  7303. /* Length (number of objects) of a record, obj has to be a Srecord/Xrecord: */
    7304. 

  7304. #define SXrecord_length(obj)  \
    7305. 

  7305.   (Record_type(obj) < rectype_limit ? Srecord_length(obj) : Xrecord_length(obj))
    7306. 

  7306. /* Likewise, but ignoring weak pointers: */
    7307. 

  7307. #define SXrecord_nonweak_length(obj)  \
    7308. 

  7308.   (Record_type(obj) < rectype_limit              \
    7309. 

  7309.    ? Srecord_length(obj)                         \
    7310. 

  7310.    : ((Record_type(obj)==Rectype_Weakpointer     \
    7311. 

  7311.        || Record_type(obj)==Rectype_Weakmapping) \
    7312. 

  7312.       ? 0                                        \
    7313. 

  7313.       : Xrecord_length(obj)))
    7314. 

  7314. /* Length of an Lrecord, ignoring weak pointers: */
    7315. 

  7315. #define Lrecord_nonweak_length(obj)  \
    7316. 

  7316.   ((Record_type(obj) >= Rectype_WeakList                 \
    7317. 

  7317.     && Record_type(obj) <= Rectype_WeakHashedAlist_Both) \
    7318. 

  7318.    ? 0                                                   \
    7319. 

  7319.    : Lrecord_length(obj))
    7320. 

  7320. /* Length (number of objects) of a record, obj has to be a Record: */
    7321. 

  7321. #define Record_length(obj)  \
    7322. 

  7322.   (Record_type(obj) >= rectype_longlimit \
    7323. 

  7323.    ? Lrecord_length(obj)                 \
    7324. 

  7324.    : SXrecord_length(obj))
    7325. 

  7325. /* Likewise, but ignoring weak pointers: */
    7326. 

  7326. #define Record_nonweak_length(obj)  \
    7327. 

  7327.   (Record_type(obj) >= rectype_longlimit \
    7328. 

  7328.    ? Lrecord_nonweak_length(obj)         \
    7329. 

  7329.    : SXrecord_nonweak_length(obj))
    7330. 

  7330. %% export_def(Car(obj));
    7331. 

  7331. %% export_def(Cdr(obj));
    7332. 

  7332. %% export_def(Symbol_value(obj));
    7333. 

  7333. %% export_def(Symbol_function(obj));
    7334. 

  7334. %% export_def(Symbol_plist(obj));
    7335. 

  7335. %% export_def(Symbol_name(obj));
    7336. 

  7336. %% export_def(Symbol_package(obj));
    7337. 

  7337. 

  7338. 

  7339. /* ####################### type test predicates ########################### #
    7340. 

  7340.  There are two kinds of predicates:
    7341. 

  7341.  1.  ???p, query with 'if':  if ???p(object)
    7342. 

  7342.  2.  if_???p, called as
    7343. 

  7343.          if_???p(object, statement1, statement2)
    7344. 

  7344.        instead of
    7345. 

  7345.          if ???p(object) statement1 else statement2
    7346. 

    7347. 

  7347.  UP: tests for equality of pointers EQ
    7348. 

  7348.  eq(obj1,obj2)
    7349. 

  7349.  > obj1,obj2: Lisp-objects
    7350. 

  7350.  < result: true, if objects are equal */
    7351. 

  7351. #if defined(DEBUG_GCSAFETY)
    7352. 

  7352.   #define eq(obj1,obj2)  (pgci_pointable(obj1) == pgci_pointable(obj2))
    7353. 

  7353. #elif defined(WIDE_STRUCT) || defined(OBJECT_STRUCT)
    7354. 

  7354.   #define eq(obj1,obj2)  (as_oint(obj1) == as_oint(obj2))
    7355. 

  7355. #elif defined(WIDE_AUXI)
    7356. 

  7356.   #define eq(obj1,obj2)  ((obj1).one_o == (obj2).one_o)
    7357. 

  7357. #else
    7358. 

  7358.   #define eq(obj1,obj2)  ((obj1) == (obj2))
    7359. 

  7359. #endif
    7360. 

  7360. %% export_def(eq(obj1,obj2));
    7361. 

  7361. 

  7362. /* Test for NIL */
    7363. 

  7363. #define nullp(obj)  (eq(obj,NIL))
    7364. 

  7364. %% export_def(nullp(obj));
    7365. 

  7365. 

  7366. /* Shorthand: Test a fixed symbol's value for NIL */
    7367. 

  7367. #define nullpSv(sym) ( nullp(Symbol_value(S(sym))))
    7368. 

  7368. 

  7369. /* Test for an argument's value, whether the argument was provided. */
    7370. 

  7370. #define boundp(obj)  (!eq(obj,unbound))
    7371. 

  7371. %% export_def(boundp(obj));
    7372. 

  7372. 

  7373. /* Test for an argument's value, whether the argument was not provided or NIL. */
    7374. 

  7374. #define missingp(obj)  (!boundp(obj) || nullp(obj))
    7375. 

  7375. %% export_def(missingp(obj));
    7376. 

  7376. 

  7377. /* Test for Cons */
    7378. 

  7378. #ifdef TYPECODES
    7379. 

  7379.   #if defined(cons_bit_o)
    7380. 

  7380.     /* define consp(obj)  (as_oint(obj) & wbit(cons_bit_o)) */
    7381. 

  7381.     #define consp(obj)  (wbit_test(as_oint(obj),cons_bit_o))
    7382. 

  7382.     #ifdef fast_mtypecode
    7383. 

  7383.       #ifdef WIDE_STRUCT
    7384. 

  7384.         #undef consp
    7385. 

  7385.         #define consp(obj)  (typecode(obj) & bit(cons_bit_t))
    7386. 

  7386.       #endif
    7387. 

  7387.       #define mconsp(obj)  (mtypecode(obj) & bit(cons_bit_t))
    7388. 

  7388.     #else
    7389. 

  7389.       #define mconsp(obj)  consp(obj)
    7390. 

  7390.     #endif
    7391. 

  7391.   #else
    7392. 

  7392.     #define consp(obj)  (typecode(obj) == cons_type)
    7393. 

  7393.     #define mconsp(obj)  (mtypecode(obj) == cons_type)
    7394. 

  7394.   #endif
    7395. 

  7395. #else
    7396. 

  7396.   #define consp(obj)  ((as_oint(obj) & 7) == (cons_bias+conses_misaligned))
    7397. 

  7397.   #define mconsp(obj)  consp(obj)
    7398. 

  7398. #endif
    7399. 

  7399. %% export_def(consp(obj));
    7400. 

  7400. %% export_def(mconsp(obj));
    7401. 

  7401. 

  7402. /* Test for Atom */
    7403. 

  7403. #ifdef TYPECODES
    7404. 

  7404.   #if defined(cons_bit_o)
    7405. 

  7405.     /* define atomp(obj)  ((as_oint(obj) & wbit(cons_bit_o))==0) */
    7406. 

  7406.     #define atomp(obj)  (!wbit_test(as_oint(obj),cons_bit_o))
    7407. 

  7407.     #ifdef fast_mtypecode
    7408. 

  7408.       #ifdef WIDE_STRUCT
    7409. 

  7409.         #undef atomp
    7410. 

  7410.         #define atomp(obj)  ((typecode(obj) & bit(cons_bit_t))==0)
    7411. 

  7411.       #endif
    7412. 

  7412.       #define matomp(obj)  ((mtypecode(obj) & bit(cons_bit_t))==0)
    7413. 

  7413.     #else
    7414. 

  7414.       #define matomp(obj)  atomp(obj)
    7415. 

  7415.     #endif
    7416. 

  7416.   #else
    7417. 

  7417.     #define atomp(obj)  (!(typecode(obj) == cons_type))
    7418. 

  7418.     #define matomp(obj)  (!(mtypecode(obj) == cons_type))
    7419. 

  7419.   #endif
    7420. 

  7420. #else
    7421. 

  7421.   #define atomp(obj)  (!consp(obj))
    7422. 

  7422.   #define matomp(obj)  atomp(obj)
    7423. 

  7423. #endif
    7424. 

  7424. %% export_def(atomp(obj));
    7425. 

  7425. %% export_def(matomp(obj));
    7426. 

  7426. 

  7427. /* For all type tests below this line, the argument must be side-effect-free.
    7428. 

  7428.  Ideally a variable, but a STACK_(n) reference works as well. */
    7429. 

  7429. 

  7430. /* Test for List */
    7431. 

  7431. #define listp(obj)  (nullp(obj) || consp(obj))
    7432. 

  7432. %% export_def(listp(obj));
    7433. 

  7433. 

  7434. #ifndef TYPECODES
    7435. 

  7435.   /* Test for Object with variable length */
    7436. 

  7436.   #define varobjectp(obj)  ((as_oint(obj) & nonimmediate_heapcode_mask) == (varobject_bias+varobjects_misaligned))
    7437. 

  7437. #endif
    7438. 

  7438. %% #ifndef TYPECODES
    7439. 

  7439. %%   export_def(varobjectp(obj));
    7440. 

  7440. %% #endif
    7441. 

  7441. 

  7442. /* Test for Symbol */
    7443. 

  7443. #ifdef TYPECODES
    7444. 

  7444.   #if defined(symbol_bit_o)
    7445. 

  7445.     /* define symbolp(obj)  (as_oint(obj) & wbit(symbol_bit_o)) */
    7446. 

  7446.     #define symbolp(obj)  (wbit_test(as_oint(obj),symbol_bit_o))
    7447. 

  7447.     #ifdef WIDE_STRUCT
    7448. 

  7448.       #undef symbolp
    7449. 

  7449.       #define symbolp(obj)  (typecode(obj) & bit(symbol_bit_t))
    7450. 

  7450.     #endif
    7451. 

  7451.   #else
    7452. 

  7452.     #define symbolp(obj)  (typecode(obj) == symbol_type)
    7453. 

  7453.   #endif
    7454. 

  7454. #else
    7455. 

  7455.   #define symbolp(obj)  \
    7456. 

  7456.     (varobjectp(obj) && (Record_type(obj) == Rectype_Symbol))
    7457. 

  7457. #endif
    7458. 

  7458. %% export_def(symbolp(obj));
    7459. 

  7459. 

  7460. /* Test for number */
    7461. 

  7461. #ifdef TYPECODES
    7462. 

  7462.   /* define numberp(obj)  (as_oint(obj) & wbit(number_bit_o)) */
    7463. 

  7463.   #define numberp(obj)  (wbit_test(as_oint(obj),number_bit_o))
    7464. 

  7464.   #ifdef WIDE_STRUCT
    7465. 

  7465.     #undef numberp
    7466. 

  7466.     #define numberp(obj)  (typecode(obj) & bit(number_bit_t))
    7467. 

  7467.   #endif
    7468. 

  7468. #else
    7469. 

  7469.   #define immediate_number_p(obj)  \
    7470. 

  7470.     ((as_oint(obj) & ((4 << imm_type_shift) | immediate_bias)) == (fixnum_type&sfloat_type))
    7471. 

  7471.   #define numberp(obj)  \
    7472. 

  7472.     (immediate_number_p(obj) \
    7473. 

  7473.      || (varobjectp(obj)     \
    7474. 

  7474.          && ((uintB)(Record_type(obj)-Rectype_Bignum) <= Rectype_Complex-Rectype_Bignum)))
    7475. 

  7475. #endif
    7476. 

  7476. %% #if notused
    7477. 

  7477. %% #ifdef TYPECODES
    7478. 

  7478. %%  export_def(numberp(obj));
    7479. 

  7479. %% #else
    7480. 

  7480. %%  export_def(immediate_number_p(obj));
    7481. 

  7481. %% #endif
    7482. 

  7482. %% #endif
    7483. 

  7483. 

  7484. /* Test for Vector (typebytes %001,%010,%011,%101,%110,%111) */
    7485. 

  7485. #ifdef TYPECODES
    7486. 

  7486.   #define vectorp(obj)  \
    7487. 

  7487.     ((tint)(typecode(obj) - sbvector_type) <= (tint)(vector_type - sbvector_type))
    7488. 

  7488. #else
    7489. 

  7489.   /* cases: Rectype_Sbvector, Rectype_Sb[2|4|8|16|32]vector, Rectype_Svector, Rectype_[Imm_]S[8|16|32]string,
    7490. 

  7490.           Rectype_bvector, Rectype_b[2|4|8|16|32]vector, Rectype_vector, Rectype_reallocstring, Rectype_string */
    7491. 

  7491.   #define vectorp(obj)  \
    7492. 

  7492.     (varobjectp(obj) && ((uintB)(Record_type(obj) - Rectype_vector) \
    7493. 

  7493.                          <= Rectype_string - Rectype_vector))
    7494. 

  7494. #endif
    7495. 

  7495. %% export_def(vectorp(obj));
    7496. 

  7496. 

  7497. /* Test for simple-vector or simple-bit-vector or simple-string */
    7498. 

  7498. #ifdef TYPECODES
    7499. 

  7499.   #define simplep(obj)  \
    7500. 

  7500.     ((tint)(typecode(obj) - sbvector_type) <= (tint)(svector_type - sbvector_type))
    7501. 

  7501. #else
    7502. 

  7502.   /* cases: Rectype_Sbvector, Rectype_Sb[2|4|8|16|32]vector, Rectype_Svector, Rectype_[Imm_]S[8|16|32]string,
    7503. 

  7503.           Rectype_reallocstring */
    7504. 

  7504.   #define simplep(obj)  \
    7505. 

  7505.     (varobjectp(obj) && ((uintB)(Record_type(obj) - Rectype_Svector) \
    7506. 

  7506.                          <= Rectype_reallocstring - Rectype_Svector))
    7507. 

  7507. #endif
    7508. 

  7508. 

  7509. /* Tests an Array for simple-vector or simple-bit-vector or simple-string */
    7510. 

  7510. #ifdef TYPECODES
    7511. 

  7511.   #define array_simplep(obj)  \
    7512. 

  7512.     ((typecode(obj) & bit(notsimple_bit_t)) == 0)
    7513. 

  7513. #else
    7514. 

  7514.   /* cases: Rectype_Sbvector, Rectype_Sb[2|4|8|16|32]vector, Rectype_Svector, Rectype_[Imm_]S[8|16|32]string,
    7515. 

  7515.           Rectype_reallocstring */
    7516. 

  7516.   #define array_simplep(obj)  \
    7517. 

  7517.     ((uintB)(Record_type(obj) - Rectype_Svector) \
    7518. 

  7518.      <= Rectype_reallocstring - Rectype_Svector)
    7519. 

  7519. #endif
    7520. 

  7520. 

  7521. /* Test for simple-vector */
    7522. 

  7522. #ifdef TYPECODES
    7523. 

  7523.   #define simple_vector_p(obj)  \
    7524. 

  7524.     (typecode(obj) == svector_type)
    7525. 

  7525. #else
    7526. 

  7526.   /* cases: Rectype_Svector */
    7527. 

  7527.   #define simple_vector_p(obj)  \
    7528. 

  7528.     (varobjectp(obj) && (Record_type(obj) == Rectype_Svector))
    7529. 

  7529. #endif
    7530. 

  7530. %% export_def(simple_vector_p(obj));
    7531. 

  7531. 

  7532. /* Test for general-vector=(vector t) */
    7533. 

  7533. #ifdef TYPECODES
    7534. 

  7534.   #define general_vector_p(obj)  \
    7535. 

  7535.     ((typecode(obj) & ~bit(notsimple_bit_t)) == svector_type)
    7536. 

  7536. #else
    7537. 

  7537.   /* cases: Rectype_Svector, Rectype_vector */
    7538. 

  7538.   #define general_vector_p(obj)  \
    7539. 

  7539.     (varobjectp(obj) \
    7540. 

  7540.      && ((Record_type(obj) & ~(Rectype_Svector ^ Rectype_vector)) == (Rectype_Svector & Rectype_vector)) \
    7541. 

  7541.     )
    7542. 

  7542. #endif
    7543. 

  7543. %% export_def(general_vector_p(obj));
    7544. 

  7544. 

  7545. /* Test for simple-string */
    7546. 

  7546. #ifdef TYPECODES
    7547. 

  7547.   #define simple_string_p(obj)  \
    7548. 

  7548.     (typecode(obj) == sstring_type)
    7549. 

  7549. #else
    7550. 

  7550.   /* cases: Rectype_[Imm_]S[8|16|32]string, Rectype_reallocstring */
    7551. 

  7551.   #define simple_string_p(obj)  \
    7552. 

  7552.     (varobjectp(obj) && ((uintB)(Record_type(obj) - Rectype_S8string) \
    7553. 

  7553.                          <= Rectype_reallocstring - Rectype_S8string))
    7554. 

  7554. #endif
    7555. 

  7555. %% export_def(simple_string_p(obj));
    7556. 

  7556. 

  7557. /* Test for string */
    7558. 

  7558. #ifdef TYPECODES
    7559. 

  7559.   #define stringp(obj)  \
    7560. 

  7560.     ((typecode(obj) & ~bit(notsimple_bit_t)) == sstring_type)
    7561. 

  7561. #else
    7562. 

  7562.   /* cases: Rectype_[Imm_]S[8|16|32]string, Rectype_reallocstring, Rectype_string */
    7563. 

  7563.   #define stringp(obj)  \
    7564. 

  7564.     (varobjectp(obj) && ((uintB)(Record_type(obj) - Rectype_S8string) \
    7565. 

  7565.                          <= Rectype_string - Rectype_S8string))
    7566. 

  7566. #endif
    7567. 

  7567. %% export_def(stringp(obj));
    7568. 

  7568. 

  7569. /* test for (VECTOR NIL) */
    7570. 

  7570. #ifdef TYPECODES
    7571. 

  7571.   #define nil_vector_p(obj)  \
    7572. 

  7572.     (typecode(obj) == vector_type \
    7573. 

  7573.      && (Iarray_flags(obj) & arrayflags_atype_mask) == Atype_NIL \
    7574. 

  7574.     )
    7575. 

  7575. #else
    7576. 

  7576.   /* cases: Rectype_Svector, Rectype_vector */
    7577. 

  7577.   #define nil_vector_p(obj)  \
    7578. 

  7578.     (varobjectp(obj) \
    7579. 

  7579.      && (Record_type(obj) == Rectype_vector \
    7580. 

  7580.          && (Iarray_flags(obj) & arrayflags_atype_mask) == Atype_NIL \
    7581. 

  7581.     )   )
    7582. 

  7582. #endif
    7583. 

  7583. 

  7584. /* Test for simple-bit[n]-vector */
    7585. 

  7585. #ifdef TYPECODES
    7586. 

  7586.   #define simple_bit_vector_p(atype,obj)  \
    7587. 

  7587.     (typecode(obj) == Array_type_simple_bit_vector(atype))
    7588. 

  7588. #else
    7589. 

  7589.   /* cases: Rectype_Sb[2^n]vector */
    7590. 

  7590.   #define simple_bit_vector_p(atype,obj)  \
    7591. 

  7591.     (varobjectp(obj) && (Record_type(obj) == Rectype_Sbvector+(atype)))
    7592. 

  7592. #endif
    7593. 

  7593. %% export_def(simple_bit_vector_p(atype,obj));
    7594. 

  7594. 

  7595. /* Test for bit[n]-vector */
    7596. 

  7596. #ifdef TYPECODES
    7597. 

  7597.   #define bit_vector_p(atype,obj)  \
    7598. 

  7598.     ((typecode(obj) & ~bit(notsimple_bit_t)) == Array_type_simple_bit_vector(atype))
    7599. 

  7599. #else
    7600. 

  7600.   /* cases: Rectype_Sb[2^n]vector, Rectype_b[2^n]vector */
    7601. 

  7601.   #define bit_vector_p(atype,obj)  \
    7602. 

  7602.     (varobjectp(obj) \
    7603. 

  7603.      && ((Record_type(obj) & ~(Rectype_Sbvector ^ Rectype_bvector)) == (Rectype_Sbvector & Rectype_bvector) + (atype)) \
    7604. 

  7604.     )
    7605. 

  7605. #endif
    7606. 

  7606. %% export_def(bit_vector_p(atype,obj));
    7607. 

  7607. 

  7608. /* Test for Array (general) */
    7609. 

  7609. #ifdef TYPECODES
    7610. 

  7610.   #define arrayp(obj)  \
    7611. 

  7611.     ((tint)(typecode(obj) - mdarray_type) <= (tint)(vector_type - mdarray_type))
    7612. 

  7612. #else
    7613. 

  7613.   /* cases: Rectype_Sbvector, Rectype_Sb[2|4|8|16|32]vector, Rectype_Svector, Rectype_[Imm_]S[8|16|32]string,
    7614. 

  7614.           Rectype_bvector, Rectype_b[2|4|8|16|32]vector, Rectype_vector, Rectype_reallocstring, Rectype_string,
    7615. 

  7615.           Rectype_mdarray */
    7616. 

  7616.   #define arrayp(obj)  \
    7617. 

  7617.     (varobjectp(obj) && ((uintB)(Record_type(obj) - Rectype_vector) \
    7618. 

  7618.                          <= Rectype_mdarray - Rectype_vector))
    7619. 

  7619. #endif
    7620. 

  7620. %% export_def(arrayp(obj));
    7621. 

  7621. 

  7622. /* Test for Array, that isn't a Vector (type byte %100) */
    7623. 

  7623. #ifdef TYPECODES
    7624. 

  7624.   #define mdarrayp(obj)  \
    7625. 

  7625.     (typecode(obj) == mdarray_type)
    7626. 

  7626. #else
    7627. 

  7627.   /* cases: Rectype_mdarray */
    7628. 

  7628.   #define mdarrayp(obj)  \
    7629. 

  7629.     (varobjectp(obj) && (Record_type(obj) == Rectype_mdarray))
    7630. 

  7630. #endif
    7631. 

  7631. 

  7632. #ifdef TYPECODES
    7633. 

  7633.   /* Test for Closure/Structure/Stream/Instance/OtherRecord/LongRecord */
    7634. 

  7634.     #define if_recordp(obj,statement1,statement2)  \
    7635. 

  7635.       switch (typecode(obj)) {          \
    7636. 

  7636.         case_record: statement1; break; \
    7637. 

  7637.         default: statement2; break;     \
    7638. 

  7638.       }
    7639. 

  7639. #else
    7640. 

  7640.   /* Test for Lrecord/Srecord/Xrecord */
    7641. 

  7641.     #define if_recordp(obj,statement1,statement2)  \
    7642. 

  7642.       if (orecordp(obj))                                                     \
    7643. 

  7643.         switch (Record_type(obj)) {                                          \
    7644. 

  7644.           case Rectype_Sbvector:                                             \
    7645. 

  7645.           case Rectype_S8string: case Rectype_Imm_S8string:                  \
    7646. 

  7646.           case Rectype_S16string: case Rectype_Imm_S16string:                \
    7647. 

  7647.           case Rectype_S32string: case Rectype_Imm_S32string:                \
    7648. 

  7648.           case Rectype_Svector:                                              \
    7649. 

  7649.           case Rectype_mdarray:                                              \
    7650. 

  7650.           case Rectype_bvector: case Rectype_string: case Rectype_vector:    \
    7651. 

  7651.           case Rectype_reallocstring:                                        \
    7652. 

  7652.           case Rectype_Bignum: case Rectype_Lfloat:                          \
    7653. 

  7653.             goto not_record;                                                 \
    7654. 

  7654.           default: { statement1 } break;                                     \
    7655. 

  7655.         }                                                                    \
    7656. 

  7656.       else                                                                   \
    7657. 

  7657.         not_record: { statement2 }
    7658. 

  7658. #endif
    7659. 

  7659. 

  7660. /* Test for Closure */
    7661. 

  7661. #ifdef TYPECODES
    7662. 

  7662.   #define closurep(obj)  (typecode(obj)==closure_type)
    7663. 

  7663. #else
    7664. 

  7664.   #define closurep(obj)  \
    7665. 

  7665.     (varobjectp(obj) && (Record_type(obj) == Rectype_Closure))
    7666. 

  7666. #endif
    7667. 

  7667. 

  7668. /* Test for compiled Closure
    7669. 

  7669.  The second component of a closure is either a list
    7670. 

  7670.  (the Lambdabody for interpreted Closures)
    7671. 

  7671.  or a Simple-Bit-Vector (the code vector for compiled Closures). */
    7672. 

  7672. #define cclosurep(obj)  \
    7673. 

  7673.   (closurep(obj)        \
    7674. 

  7674.    && simple_bit_vector_p(Atype_8Bit,TheClosure(obj)->clos_codevec))
    7675. 

  7675. 

  7676. /* Test for a function with a code vector produced by %GENERIC-FUNCTION-LAMBDA. */
    7677. 

  7677. #define genericlambda_function_p(obj)  \
    7678. 

  7678.   (cclosurep(obj) \
    7679. 

  7679.    && (TheCodevec(TheClosure(obj)->clos_codevec)->ccv_flags & bit(4)))
    7680. 

  7680. 

  7681. /* Test for CLOS-Instance */
    7682. 

  7682. #ifdef TYPECODES
    7683. 

  7683.   #define instancep(obj)  \
    7684. 

  7684.     (typecode(obj)==instance_type                                \
    7685. 

  7685.      || (typecode(obj)==closure_type && Closure_instancep(obj)))
    7686. 

  7686. #else
    7687. 

  7687.   #define instancep(obj)  \
    7688. 

  7688.     (varobjectp(obj)                                                  \
    7689. 

  7689.      && (Record_type(obj) == Rectype_Instance                         \
    7690. 

  7690.          || (Record_type(obj) == Rectype_Closure && Closure_instancep(obj))))
    7691. 

  7691. #endif
    7692. 

  7692. /* Test for non-funcallable CLOS-Instance */
    7693. 

  7693. #ifdef TYPECODES
    7694. 

  7694.   #define regular_instance_p(obj)  (typecode(obj)==instance_type)
    7695. 

  7695. #else
    7696. 

  7696.   #define regular_instance_p(obj)  \
    7697. 

  7697.     (varobjectp(obj) && (Record_type(obj) == Rectype_Instance))
    7698. 

  7698. #endif
    7699. 

  7699. /* Test for funcallable CLOS-Instance */
    7700. 

  7700. #define funcallable_instance_p(obj)  \
    7701. 

  7701.   (closurep(obj) && Closure_instancep(obj))
    7702. 

  7702. %% export_def(instancep(obj));
    7703. 

  7703. 

  7704. /* Test for CLOS-class or forward-reference.
    7705. 

  7705.  Our CLOS implements all classes as instances of a
    7706. 

  7706.  (not necessarily direct) subclass of <class>. */
    7707. 

  7707. #define if_potential_class_p(obj,statement1,statement2)  \
    7708. 

  7708.   if (instancep(obj)) {                                               \
    7709. 

  7709.     {                                                                 \
    7710. 

  7710.       var object obj_forwarded = obj;                                 \
    7711. 

  7711.       instance_un_realloc(obj_forwarded);                             \
    7712. 

  7712.       /*instance_update(obj,obj_forwarded); - not needed since we don't access a slot */ \
    7713. 

  7713.      {var object cv = TheInstance(obj_forwarded)->inst_class_version; \
    7714. 

  7714.       /* Treat the most frequent cases first, for speed. */           \
    7715. 

  7715.       if (eq(cv,O(class_version_standard_class))) /* direct instance of STANDARD-CLASS?  */\
    7716. 

  7716.         goto obj##_classp_yes;                                        \
    7717. 

  7717.       if (eq(cv,O(class_version_structure_class))) /* direct instance of STRUCTURE-CLASS?  */\
    7718. 

  7718.         goto obj##_classp_yes;                                        \
    7719. 

  7719.       if (eq(cv,O(class_version_built_in_class))) /* direct instance of BUILT-IN-CLASS?  */\
    7720. 

  7720.         goto obj##_classp_yes;                                        \
    7721. 

  7721.       /* Now a slow, but general instanceof test. */                  \
    7722. 

  7722.       {var object objclas = TheClassVersion(cv)->cv_newest_class;     \
    7723. 

  7723.        if (eq(gethash(O(class_potential_class),TheClass(objclas)->all_superclasses,false),nullobj)) \
    7724. 

  7724.          goto obj##_classp_no;                                        \
    7725. 

  7725.     }}}                                                               \
    7726. 

  7726.    obj##_classp_yes: statement1;                                      \
    7727. 

  7727.   } else {                                                            \
    7728. 

  7728.    obj##_classp_no: statement2;                                       \
    7729. 

  7729.   }
    7730. 

  7730. 

  7731. /* Test for CLOS-class.
    7732. 

  7732.  Our CLOS implements all classes as instances of a
    7733. 

  7733.  (not necessarily direct) subclass of <defined-class>. */
    7734. 

  7734. #define if_defined_class_p(obj,statement1,statement2)  \
    7735. 

  7735.   if (instancep(obj)) {                                               \
    7736. 

  7736.     {                                                                 \
    7737. 

  7737.       var object obj_forwarded = obj;                                 \
    7738. 

  7738.       instance_un_realloc(obj_forwarded);                             \
    7739. 

  7739.       /*instance_update(obj,obj_forwarded); - not needed since we don't access a slot */ \
    7740. 

  7740.      {var object cv = TheInstance(obj_forwarded)->inst_class_version; \
    7741. 

  7741.       /* Treat the most frequent cases first, for speed. */           \
    7742. 

  7742.       if (eq(cv,O(class_version_standard_class))) /* direct instance of STANDARD-CLASS?  */\
    7743. 

  7743.         goto obj##_classp_yes;                                        \
    7744. 

  7744.       if (eq(cv,O(class_version_structure_class))) /* direct instance of STRUCTURE-CLASS?  */\
    7745. 

  7745.         goto obj##_classp_yes;                                        \
    7746. 

  7746.       if (eq(cv,O(class_version_built_in_class))) /* direct instance of BUILT-IN-CLASS?  */\
    7747. 

  7747.         goto obj##_classp_yes;                                        \
    7748. 

  7748.       /* Now a slow, but general instanceof test. */                  \
    7749. 

  7749.       {var object objclas = TheClassVersion(cv)->cv_newest_class;     \
    7750. 

  7750.        if (eq(gethash(O(class_defined_class),TheClass(objclas)->all_superclasses,false),nullobj)) \
    7751. 

  7751.          goto obj##_classp_no;                                        \
    7752. 

  7752.     }}}                                                               \
    7753. 

  7753.    obj##_classp_yes: statement1;                                      \
    7754. 

  7754.   } else {                                                            \
    7755. 

  7755.    obj##_classp_no: statement2;                                       \
    7756. 

  7756.   }
    7757. 

  7757. 

  7758. /* Test for Other-Record
    7759. 

  7759.  This is not really a type test (because there is no well-defined type
    7760. 

  7760.  Other-Record). It's just a precondition for calling Record_type(obj). */
    7761. 

  7761. #ifdef TYPECODES
    7762. 

  7762.   #define orecordp(obj)  (typecode(obj)==orecord_type)
    7763. 

  7763. #else
    7764. 

  7764.   #define orecordp(obj)  varobjectp(obj)
    7765. 

  7765. #endif
    7766. 

  7766. %% export_def(orecordp(obj));
    7767. 

  7767. 

  7768. /* Test for Long-Record
    7769. 

  7769.  This is not really a type test (because there is no well-defined type
    7770. 

  7770.  Long-Record). It's just a precondition for calling Record_type(obj). */
    7771. 

  7771. #ifdef TYPECODES
    7772. 

  7772.   #define lrecordp(obj)  (typecode(obj)==lrecord_type)
    7773. 

  7773. #else
    7774. 

  7774.   #define lrecordp(obj)  varobjectp(obj)
    7775. 

  7775. #endif
    7776. 

  7776. 

  7777. /* Test for Structure */
    7778. 

  7778. #ifdef case_structure
    7779. 

  7779.   #define structurep(obj)  (typecode(obj)==structure_type)
    7780. 

  7780. #else
    7781. 

  7781.   #define structurep(obj)  \
    7782. 

  7782.     (orecordp(obj) && (Record_type(obj) == Rectype_Structure))
    7783. 

  7783. #endif
    7784. 

  7784. %% export_def(structurep(obj));
    7785. 

  7785. 

  7786. /* Test for Builtin-Stream */
    7787. 

  7787. #ifdef case_stream
    7788. 

  7788.   #define builtin_stream_p(obj)  (typecode(obj)==stream_type)
    7789. 

  7789. #else
    7790. 

  7790.   #define builtin_stream_p(obj)  \
    7791. 

  7791.     (orecordp(obj) && (Record_type(obj) == Rectype_Stream))
    7792. 

  7792. #endif
    7793. 

  7793. %% export_def(builtin_stream_p(obj));
    7794. 

  7794. 

  7795. /* Test for Stream */
    7796. 

  7796. #define streamp(obj)  \
    7797. 

  7797.   (builtin_stream_p(obj) || instanceof(obj,O(class_fundamental_stream)))
    7798. 

  7798. 

  7799. /* Test for Package */
    7800. 

  7800. #define packagep(obj)  \
    7801. 

  7801.   (orecordp(obj) && (Record_type(obj) == Rectype_Package))
    7802. 

  7802. %% #if notused
    7803. 

  7803. %% export_def(packagep(obj));
    7804. 

  7804. %% #endif
    7805. 

  7805. 

  7806. /* Test for Hash-Table */
    7807. 

  7807. #define hash_table_p(obj)  \
    7808. 

  7808.   (orecordp(obj) && (Record_type(obj) == Rectype_Hashtable))
    7809. 

  7809. 

  7810. /* Test for Readtable */
    7811. 

  7811. #define readtablep(obj)  \
    7812. 

  7812.   (orecordp(obj) && (Record_type(obj) == Rectype_Readtable))
    7813. 

  7813. 

  7814. /* Test for Pathname */
    7815. 

  7815. #define pathnamep(obj)  \
    7816. 

  7816.   (orecordp(obj) && (Record_type(obj) == Rectype_Pathname))
    7817. 

  7817. 

  7818. /* Test for Logical Pathname */
    7819. 

  7819. #ifdef LOGICAL_PATHNAMES
    7820. 

  7820.   #define logpathnamep(obj)  \
    7821. 

  7821.     (orecordp(obj) && (Record_type(obj) == Rectype_Logpathname))
    7822. 

  7822. #else
    7823. 

  7823.   #define logpathnamep(obj)  false
    7824. 

  7824. #endif
    7825. 

  7825. 

  7826. /* Test for Extended Pathname (i.e., Pathname or Logical Pathname)
    7827. 

  7827.  define xpathnamep(obj)  (pathnamep(obj) || logpathnamep(obj)) */
    7828. 

  7828. #ifdef LOGICAL_PATHNAMES
    7829. 

  7829.   #define xpathnamep(obj)  \
    7830. 

  7830.     (orecordp(obj)                                    \
    7831. 

  7831.      && ((Record_type(obj) == Rectype_Pathname)       \
    7832. 

  7832.          || (Record_type(obj) == Rectype_Logpathname)))
    7833. 

  7833. #else
    7834. 

  7834.   #define xpathnamep(obj)  pathnamep(obj)
    7835. 

  7835. #endif
    7836. 

  7836. 

  7837. /* Test for Random-State */
    7838. 

  7838. #define random_state_p(obj)  \
    7839. 

  7839.   (orecordp(obj) && (Record_type(obj) == Rectype_Random_State))
    7840. 

  7840. 

  7841. /* Test for Byte */
    7842. 

  7842. #define bytep(obj)  \
    7843. 

  7843.   (orecordp(obj) && (Record_type(obj) == Rectype_Byte))
    7844. 

  7844. 

  7845. /* Test for Fsubr */
    7846. 

  7846. #define fsubrp(obj)  \
    7847. 

  7847.   (orecordp(obj) && (Record_type(obj) == Rectype_Fsubr))
    7848. 

  7848. 

  7849. /* Test for Loadtimeeval */
    7850. 

  7850. #define loadtimeevalp(obj)  \
    7851. 

  7851.   (orecordp(obj) && (Record_type(obj) == Rectype_Loadtimeeval))
    7852. 

  7852. 

  7853. /* Test for Symbolmacro */
    7854. 

  7854. #define symbolmacrop(obj)  \
    7855. 

  7855.   (orecordp(obj) && (Record_type(obj) == Rectype_Symbolmacro))
    7856. 

  7856. 

  7857. /* Test for GlobalSymbolmacro */
    7858. 

  7858. #define globalsymbolmacrop(obj)  \
    7859. 

  7859.   (orecordp(obj) && (Record_type(obj) == Rectype_GlobalSymbolmacro))
    7860. 

  7860. 

  7861. /* Test for Macro */
    7862. 

  7862. #define macrop(obj)  \
    7863. 

  7863.   (orecordp(obj) && (Record_type(obj) == Rectype_Macro))
    7864. 

  7864. 

  7865. /* Test for FunctionMacro */
    7866. 

  7866. #define functionmacrop(obj)  \
    7867. 

  7867.   (orecordp(obj) && (Record_type(obj) == Rectype_FunctionMacro))
    7868. 

  7868. 

  7869. /* Test for BigReadLabel */
    7870. 

  7870. #define big_read_label_p(obj)  \
    7871. 

  7871.   (orecordp(obj) && (Record_type(obj) == Rectype_BigReadLabel))
    7872. 

  7872. 

  7873. /* Test for Encoding */
    7874. 

  7874. #define encodingp(obj)  \
    7875. 

  7875.   (orecordp(obj) && (Record_type(obj) == Rectype_Encoding))
    7876. 

  7876. 

  7877. /* Test for Fpointer */
    7878. 

  7878. #define fpointerp(obj)  \
    7879. 

  7879.   (orecordp(obj) && (Record_type(obj) == Rectype_Fpointer))
    7880. 

  7880. %% #ifdef FOREIGN
    7881. 

  7881. %%   export_def(fpointerp(obj));
    7882. 

  7882. %% #endif
    7883. 

  7883. 

  7884. /* Test for Faddress */
    7885. 

  7885. #define faddressp(obj)  \
    7886. 

  7886.   (orecordp(obj) && (Record_type(obj) == Rectype_Faddress))
    7887. 

  7887. 

  7888. /* Test for Fvariable */
    7889. 

  7889. #define fvariablep(obj)  \
    7890. 

  7890.   (orecordp(obj) && (Record_type(obj) == Rectype_Fvariable))
    7891. 

  7891. 

  7892. /* Test for Ffunction */
    7893. 

  7893. #ifdef DYNAMIC_FFI
    7894. 

  7894.   #define ffunctionp(obj)  \
    7895. 

  7895.     (orecordp(obj) && (Record_type(obj) == Rectype_Ffunction))
    7896. 

  7896. #else
    7897. 

  7897.   #define ffunctionp(obj)  ((void)(obj), 0)
    7898. 

  7898. #endif
    7899. 

  7899. 

  7900. /* Test for Function */
    7901. 

  7901. #define functionp(obj) (subrp(obj) || closurep(obj) || ffunctionp(obj))
    7902. 

  7902. 

  7903. /* Test for Weakpointer */
    7904. 

  7904. #define weakpointerp(obj)  \
    7905. 

  7905.   (orecordp(obj) && (Record_type(obj) == Rectype_Weakpointer))
    7906. 

  7906. 

  7907. /* test for socket-server and for socket-stream */
    7908. 

  7908. #ifdef SOCKET_STREAMS
    7909. 

  7909.   #define socket_server_p(obj)  \
    7910. 

  7910.     (orecordp(obj) && (Record_type(obj) == Rectype_Socket_Server))
    7911. 

  7911.   #define socket_stream_p(obj)  \
    7912. 

  7912.     (builtin_stream_p(obj) && (TheStream(obj)->strmtype==strmtype_socket))
    7913. 

  7913. #endif
    7914. 

  7914. 

  7915. #ifdef YET_ANOTHER_RECORD
    7916. 

  7916.   /* Test for Yetanother */
    7917. 

  7917.   #define yetanotherp(obj)  \
    7918. 

  7918.     (orecordp(obj) && (Record_type(obj) == Rectype_Yetanother))
    7919. 

  7919. #endif
    7920. 

  7920. 

  7921. /* Test for Character */
    7922. 

  7922. #ifdef TYPECODES
    7923. 

  7923.   #define charp(obj)  (typecode(obj)==char_type)
    7924. 

  7924. #else
    7925. 

  7925.   #define charp(obj)  ((as_oint(obj) & ((7 << imm_type_shift) | immediate_bias)) == char_type)
    7926. 

  7926. #endif
    7927. 

  7927. %% export_def(charp(obj));
    7928. 

  7928. 

  7929. #if (base_char_code_limit < char_code_limit)
    7930. 

  7930. /* Test for base character */
    7931. 

  7931.   #define base_char_p(obj)  \
    7932. 

  7932.     ((as_oint(obj) & ~((oint)(bit(base_char_int_len)-1)<<oint_data_shift)) == type_zero_oint(char_type))
    7933. 

  7933. #endif
    7934. 

  7934. 

  7935. /* Test for SUBR (compiled functional object) */
    7936. 

  7936. #ifdef TYPECODES
    7937. 

  7937.   #define subrp(obj)  (typecode(obj)==subr_type)
    7938. 

  7938. #else
    7939. 

  7939.   #ifdef STANDARD_HEAPCODES
    7940. 

  7940.     #define subrp(obj)  ((as_oint(obj) & 3) == subr_bias)
    7941. 

  7941.     #define immsubrp(obj)  subrp(obj)
    7942. 

  7942.   #endif
    7943. 

  7943.   #ifdef LINUX_NOEXEC_HEAPCODES
    7944. 

  7944.     #define subrp(obj)  (orecordp(obj) && (Record_type(obj) == Rectype_Subr))
    7945. 

  7945.     #define immsubrp(obj)  false
    7946. 

  7946.     #ifdef DEBUG_GCSAFETY
    7947. 

  7947.       /* This is used by pgci_pointable, so it cannot use pgci_pointable itself. */
    7948. 

  7948.       static inline bool nonimmsubrp (object obj) {
    7949. 

  7949.         return (varobjectp(obj)
    7950. 

  7950.                 && (inside_gc /* Avoid doing memory accesses during GC. */
    7951. 

  7951.                     || (varobject_type((Record)(cgci_pointable(obj)-varobject_bias)) == Rectype_Subr)));
    7952. 

  7952.       }
    7953. 

  7953.     #endif
    7954. 

  7954.   #endif
    7955. 

  7955. #endif
    7956. 

  7956. %% #ifndef TYPECODES
    7957. 

  7957. %%   #ifdef LINUX_NOEXEC_HEAPCODES
    7958. 

  7958. %%     #ifdef DEBUG_GCSAFETY
    7959. 

  7959. %%       printf2("static inline bool nonimmsubrp (object obj) { return (varobjectp(obj) && (varobject_type((Record)(cgci_pointable(obj)-%d)) == %d)); }\n",varobject_bias,Rectype_Subr);
    7960. 

  7960. %%     #endif
    7961. 

  7961. %%   #endif
    7962. 

  7962. %% #endif
    7963. 

  7963. 

  7964. /* Test for pointer into the STACK (usually at a frame) */
    7965. 

  7965. #ifdef TYPECODES
    7966. 

  7966.   #define framepointerp(obj)  (typecode(obj)==system_type) /* other cases?? */
    7967. 

  7967. #else
    7968. 

  7968.   #define framepointerp(obj)  ((as_oint(obj) & 3) == machine_bias) /* other cases?? */
    7969. 

  7969. #endif
    7970. 

  7970. 

  7971. #ifndef TYPECODES
    7972. 

  7972. 

  7973.   /* Test for Machine-Pointer */
    7974. 

  7974.   #ifdef STANDARD_HEAPCODES
    7975. 

  7975.     #define machinep(obj)  ((as_oint(obj) & 3) == machine_bias)
    7976. 

  7976.   #endif
    7977. 

  7977.   #ifdef LINUX_NOEXEC_HEAPCODES
    7978. 

  7978.     #define machinep(obj)  \
    7979. 

  7979.       ((as_oint(obj) & 3) == machine_bias            \
    7980. 

  7980.        && (as_oint(obj) & 0xE0000000) != 0xC0000000)
    7981. 

  7981.   #endif
    7982. 

  7982. 

  7983.   /* Test for Small-Read-Label */
    7984. 

  7984.   #define small_read_label_p(obj)  ((as_oint(obj) & ((7 << imm_type_shift) | immediate_bias)) == small_read_label_type)
    7985. 

  7985. 

  7986.   /* Test for System-Pointer */
    7987. 

  7987.   #define systemp(obj)  ((as_oint(obj) & ((7 << imm_type_shift) | immediate_bias)) == system_type)
    7988. 

  7988. 

  7989. #endif
    7990. 

  7990. 

  7991. /* Test for real number */
    7992. 

  7992. #ifdef TYPECODES
    7993. 

  7993.   #define if_realp(obj,statement1,statement2)                           \
    7994. 

  7994.     do {                                                                \
    7995. 

  7995.       var object obj_from_if_realp = (obj);                             \
    7996. 

  7996.       var tint type_from_if_realp = typecode(obj_from_if_realp);        \
    7997. 

  7997.       if ( (type_from_if_realp & bit(number_bit_t))                     \
    7998. 

  7998.            && !(type_from_if_realp==complex_type) )                     \
    7999. 

  7999.         { statement1 } else { statement2 }                              \
    8000. 

  8000.     } while(0)
    8001. 

  8001. #else
    8002. 

  8002.   #define if_realp(obj,statement1,statement2)                           \
    8003. 

  8003.     do { if (((as_oint(obj) & ((4 << imm_type_shift) | immediate_bias)) \
    8004. 

  8004.               == fixnum_type)                                           \
    8005. 

  8005.              || (varobjectp(obj)                                        \
    8006. 

  8006.                  && ((uintB)(Record_type(obj)-Rectype_Bignum) <=        \
    8007. 

  8007.                      Rectype_Ratio-Rectype_Bignum)))                    \
    8008. 

  8008.            { statement1 } else { statement2 }                           \
    8009. 

  8009.     } while(0)
    8010. 

  8010. #endif
    8011. 

  8011. 

  8012. /* Test for rational number */
    8013. 

  8013. #ifdef TYPECODES
    8014. 

  8014.   #define if_rationalp(obj,statement1,statement2)                        \
    8015. 

  8015.     do {                                                                 \
    8016. 

  8016.       var object obj_from_if_rationalp = (obj);                          \
    8017. 

  8017.       var tint type_from_if_rationalp = typecode(obj_from_if_rationalp); \
    8018. 

  8018.       if ((type_from_if_rationalp != complex_type)                       \
    8019. 

  8019.            && ((type_from_if_rationalp &                                 \
    8020. 

  8020.                 ~((fixnum_type|bignum_type|ratio_type|bit(sign_bit_t))   \
    8021. 

  8021.                   & ~(fixnum_type&bignum_type&ratio_type)))              \
    8022. 

  8022.                == (fixnum_type&bignum_type&ratio_type)))                 \
    8023. 

  8023.         { statement1 } else { statement2 }                               \
    8024. 

  8024.     } while(0)
    8025. 

  8025. #else
    8026. 

  8026.   #define if_rationalp(obj,statement1,statement2)                        \
    8027. 

  8027.     do { if (((as_oint(obj) & ((6 << imm_type_shift) | immediate_bias))  \
    8028. 

  8028.               == fixnum_type)                                            \
    8029. 

  8029.              || (varobjectp(obj)                                         \
    8030. 

  8030.                  && ((Record_type(obj) == Rectype_Bignum)                \
    8031. 

  8031.                      || (Record_type(obj) == Rectype_Ratio))))           \
    8032. 

  8032.            { statement1 } else { statement2 }                            \
    8033. 

  8033.     } while(0)
    8034. 

  8034. 

  8035. #endif
    8036. 

  8036. 

  8037. /* Test for Integer */
    8038. 

  8038. #ifdef TYPECODES
    8039. 

  8039.   #define integerp(obj)  \
    8040. 

  8040.     ((typecode(obj) &                                                        \
    8041. 

  8041.       ~((fixnum_type|bignum_type|bit(sign_bit_t)) & ~(fixnum_type&bignum_type)) \
    8042. 

  8042.      ) == (fixnum_type&bignum_type))
    8043. 

  8043. #else
    8044. 

  8044.   #define integerp(obj)  \
    8045. 

  8045.    (((as_oint(obj) & ((6 << imm_type_shift) | immediate_bias)) == fixnum_type) \
    8046. 

  8046.     || (varobjectp(obj) && (Record_type(obj) == Rectype_Bignum)))
    8047. 

  8047. #endif
    8048. 

  8048. %% export_def(integerp(obj));
    8049. 

  8049. 

  8050. /* Test for Fixnum */
    8051. 

  8051. #ifdef TYPECODES
    8052. 

  8052.   #define fixnump(obj)  ((typecode(obj) & ~bit(sign_bit_t)) == fixnum_type)
    8053. 

  8053. #else
    8054. 

  8054.   #define fixnump(obj)  ((as_oint(obj) & ((6 << imm_type_shift) | immediate_bias)) == fixnum_type)
    8055. 

  8055. #endif
    8056. 

  8056. %% export_def(fixnump(obj));
    8057. 

  8057. 

  8058. /* Test for Fixnum >=0 */
    8059. 

  8059. #ifdef TYPECODES
    8060. 

  8060.   #define posfixnump(obj)  (typecode(obj) == fixnum_type)
    8061. 

  8061. #else
    8062. 

  8062.   #define posfixnump(obj)  ((as_oint(obj) & ((7 << imm_type_shift) | immediate_bias)) == fixnum_type)
    8063. 

  8063. #endif
    8064. 

  8064. %% export_def(posfixnump(obj));
    8065. 

  8065. 

  8066. /* Test for Bignum */
    8067. 

  8067. #ifdef TYPECODES
    8068. 

  8068.   #define bignump(obj)  ((typecode(obj) & ~bit(sign_bit_t)) == bignum_type)
    8069. 

  8069. #else
    8070. 

  8070.   #define bignump(obj)  \
    8071. 

  8071.     (varobjectp(obj) && (Record_type(obj) == Rectype_Bignum))
    8072. 

  8072. #endif
    8073. 

  8073. %% export_def(bignump(obj));
    8074. 

  8074. 

  8075. /* Test for Bignum >=0 */
    8076. 

  8076. #ifdef TYPECODES
    8077. 

  8077.   #define posbignump(obj)  (typecode(obj) == bignum_type)
    8078. 

  8078. #else
    8079. 

  8079.   #define posbignump(obj)  \
    8080. 

  8080.     (varobjectp(obj)                         \
    8081. 

  8081.      && (Record_type(obj) == Rectype_Bignum) \
    8082. 

  8082.      && ((Record_flags(obj) & bit(7)) == 0))
    8083. 

  8083. #endif
    8084. 

  8084. %% export_def(posbignump(obj));
    8085. 

  8085. 

  8086. /* Test for Ratio */
    8087. 

  8087. #ifdef TYPECODES
    8088. 

  8088.   #define ratiop(obj)  ((typecode(obj) & ~bit(sign_bit_t)) == ratio_type)
    8089. 

  8089. #else
    8090. 

  8090.   #define ratiop(obj)  (varobjectp(obj) && (Record_type(obj) == Rectype_Ratio))
    8091. 

  8091. #endif
    8092. 

  8092. %% #if notused
    8093. 

  8093. %%   export_def(ratiop(obj));
    8094. 

  8094. %% #endif
    8095. 

  8095. 

  8096. /* Test for Float */
    8097. 

  8097. #ifdef TYPECODES
    8098. 

  8098.   #define floatp(obj)  \
    8099. 

  8099.     ((typecode(obj) &  \
    8100. 

  8100.      ~((sfloat_type|ffloat_type|dfloat_type|lfloat_type|bit(sign_bit_t)) & ~(sfloat_type&ffloat_type&dfloat_type&lfloat_type)) \
    8101. 

  8101.      ) == (sfloat_type&ffloat_type&dfloat_type&lfloat_type))
    8102. 

  8102. #else
    8103. 

  8103.   #define floatp(obj)  \
    8104. 

  8104.     (((as_oint(obj) & ((6 << imm_type_shift) | immediate_bias)) == sfloat_type) \
    8105. 

  8105.      || (varobjectp(obj)                    \
    8106. 

  8106.          && ((uintB)(Record_type(obj)-Rectype_Lfloat) <= Rectype_Ffloat-Rectype_Lfloat)))
    8107. 

  8107. #endif
    8108. 

  8108. %% #if notused
    8109. 

  8109. %%   export_def(floatp(obj));
    8110. 

  8110. %% #endif
    8111. 

  8111. 

  8112. /* Test for Short-Float */
    8113. 

  8113. #ifdef TYPECODES
    8114. 

  8114.   #define short_float_p(obj)  ((typecode(obj) & ~bit(sign_bit_t)) == sfloat_type)
    8115. 

  8115. #else
    8116. 

  8116.   #define short_float_p(obj)  ((as_oint(obj) & ((6 << imm_type_shift) | immediate_bias)) == sfloat_type)
    8117. 

  8117. #endif
    8118. 

  8118. %% #if notused
    8119. 

  8119. %%   export_def(short_float_p(obj));
    8120. 

  8120. %% #endif
    8121. 

  8121. 

  8122. /* Test for Single-Float */
    8123. 

  8123. #ifdef TYPECODES
    8124. 

  8124.   #define single_float_p(obj)  ((typecode(obj) & ~bit(sign_bit_t)) == ffloat_type)
    8125. 

  8125. #else
    8126. 

  8126.   #define single_float_p(obj)  (varobjectp(obj) && (Record_type(obj) == Rectype_Ffloat))
    8127. 

  8127. #endif
    8128. 

  8128. %% export_def(single_float_p(obj));
    8129. 

  8129. 

  8130. /* Test for Double-Float */
    8131. 

  8131. #ifdef TYPECODES
    8132. 

  8132.   #define double_float_p(obj)  ((typecode(obj) & ~bit(sign_bit_t)) == dfloat_type)
    8133. 

  8133. #else
    8134. 

  8134.   #define double_float_p(obj)  (varobjectp(obj) && (Record_type(obj) == Rectype_Dfloat))
    8135. 

  8135. #endif
    8136. 

  8136. %% export_def(double_float_p(obj));
    8137. 

  8137. 

  8138. /* Test for Long-Float */
    8139. 

  8139. #ifdef TYPECODES
    8140. 

  8140.   #define long_float_p(obj)  ((typecode(obj) & ~bit(sign_bit_t)) == lfloat_type)
    8141. 

  8141. #else
    8142. 

  8142.   #define long_float_p(obj)  (varobjectp(obj) && (Record_type(obj) == Rectype_Lfloat))
    8143. 

  8143. #endif
    8144. 

  8144. %% #if notused
    8145. 

  8145. %%   export_def(long_float_p(obj));
    8146. 

  8146. %% #endif
    8147. 

  8147. 

  8148. /* Test for Complex */
    8149. 

  8149. #ifdef TYPECODES
    8150. 

  8150.   #define complexp(obj)  (typecode(obj) == complex_type)
    8151. 

  8151. #else
    8152. 

  8152.   #define complexp(obj)  (varobjectp(obj) && (Record_type(obj) == Rectype_Complex))
    8153. 

  8153. #endif
    8154. 

  8154. %% #if notused
    8155. 

  8155. %%   export_def(complexp(obj));
    8156. 

  8156. %% #endif
    8157. 

  8157. 

  8158. /* Test if a real number is >=0: */
    8159. 

  8159. #ifdef TYPECODES
    8160. 

  8160.   /* define positivep(obj)  ((as_oint(obj) & wbit(sign_bit_o)) == 0) */
    8161. 

  8161.   #define positivep(obj)  (!wbit_test(as_oint(obj),sign_bit_o))
    8162. 

  8162.   #ifdef WIDE_STRUCT
    8163. 

  8163.     #undef positivep
    8164. 

  8164.     #define positivep(obj)  ((typecode(obj) & bit(sign_bit_t)) == 0)
    8165. 

  8165.   #endif
    8166. 

  8166. #else
    8167. 

  8167.   #define positivep(obj)  \
    8168. 

  8168.     (number_immediatep(obj)                                        \
    8169. 

  8169.      ? /* fixnum, sfloat */ (as_oint(obj) & wbit(sign_bit_o)) == 0 \
    8170. 

  8170.      : /* bignum, [fdl]float */ (Record_flags(obj) & bit(7)) == 0)
    8171. 

  8171. #endif
    8172. 

  8172. %% export_def(positivep(obj));
    8173. 

  8173. 

  8174. 

  8175. /* switch with typcodes:
    8176. 

  8176.  example:
    8177. 

  8177.    switch (typecode(obj)) {
    8178. 

  8178.      case_symbol: ....
    8179. 

  8179.      case_orecord:
    8180. 

  8180.        switch (Record_type(obj)) {
    8181. 

  8181.          case_Rectype_Symbol_above;
    8182. 

  8182.          ...
    8183. 

  8183.        }
    8184. 

  8184.    } */
    8185. 

  8185. 

  8186. #ifdef case_structure
    8187. 

  8187.   #define case_Rectype_Structure_above
    8188. 

  8188. #else
    8189. 

  8189.   #define case_Rectype_Structure_above  \
    8190. 

  8190.     case Rectype_Structure: goto case_structure;
    8191. 

  8191. #endif
    8192. 

  8192. 

  8193. #ifdef case_stream
    8194. 

  8194.   #define case_Rectype_Stream_above
    8195. 

  8195. #else
    8196. 

  8196.   #define case_Rectype_Stream_above  \
    8197. 

  8197.     case Rectype_Stream: goto case_stream;
    8198. 

  8198. #endif
    8199. 

  8199. 

  8200. #ifdef TYPECODES
    8201. 

  8201.   #define case_Rectype_Closure_above
    8202. 

  8202.   #define case_Rectype_Instance_above
    8203. 

  8203.   #define case_Rectype_Sbvector_above
    8204. 

  8204.   #define case_Rectype_Sb2vector_above
    8205. 

  8205.   #define case_Rectype_Sb4vector_above
    8206. 

  8206.   #define case_Rectype_Sb8vector_above
    8207. 

  8207.   #define case_Rectype_Sb16vector_above
    8208. 

  8208.   #define case_Rectype_Sb32vector_above
    8209. 

  8209.   #define case_Rectype_Sstring_above
    8210. 

  8210.   #define case_Rectype_Svector_above
    8211. 

  8211.   #define case_Rectype_mdarray_above
    8212. 

  8212.   #define case_Rectype_obvector_above
    8213. 

  8213.   #define case_Rectype_ob2vector_above
    8214. 

  8214.   #define case_Rectype_ob4vector_above
    8215. 

  8215.   #define case_Rectype_ob8vector_above
    8216. 

  8216.   #define case_Rectype_ob16vector_above
    8217. 

  8217.   #define case_Rectype_ob32vector_above
    8218. 

  8218.   #define case_Rectype_ostring_above
    8219. 

  8219.   #define case_Rectype_ovector_above
    8220. 

  8220.   #define case_Rectype_Bignum_above
    8221. 

  8221.   #define case_Rectype_Lfloat_above
    8222. 

  8222.   #define case_Rectype_Dfloat_above
    8223. 

  8223.   #define case_Rectype_Ffloat_above
    8224. 

  8224.   #define case_Rectype_Ratio_above
    8225. 

  8225.   #define case_Rectype_Complex_above
    8226. 

  8226.   #define case_Rectype_Symbol_above
    8227. 

  8227.   /* Composite cases: */
    8228. 

  8228.   #define case_Rectype_string_above
    8229. 

  8229.   #define case_Rectype_bvector_above
    8230. 

  8230.   #define case_Rectype_b2vector_above
    8231. 

  8231.   #define case_Rectype_b4vector_above
    8232. 

  8232.   #define case_Rectype_b8vector_above
    8233. 

  8233.   #define case_Rectype_b16vector_above
    8234. 

  8234.   #define case_Rectype_b32vector_above
    8235. 

  8235.   #define case_Rectype_vector_above
    8236. 

  8236.   #define case_Rectype_array_above
    8237. 

  8237.   #define case_Rectype_number_above
    8238. 

  8238.   #define case_Rectype_float_above
    8239. 

  8239.   #define case_Rectype_integer_above
    8240. 

  8240. #else
    8241. 

  8241.   #define case_Rectype_Closure_above  \
    8242. 

  8242.     case Rectype_Closure: goto case_closure;
    8243. 

  8243.   #define case_Rectype_Instance_above  \
    8244. 

  8244.     case Rectype_Instance: goto case_instance;
    8245. 

  8245.   #define case_Rectype_Sbvector_above  \
    8246. 

  8246.     case Rectype_Sbvector: goto case_sbvector;
    8247. 

  8247.   #define case_Rectype_Sb2vector_above  \
    8248. 

  8248.     case Rectype_Sb2vector: goto case_sb2vector;
    8249. 

  8249.   #define case_Rectype_Sb4vector_above  \
    8250. 

  8250.     case Rectype_Sb4vector: goto case_sb4vector;
    8251. 

  8251.   #define case_Rectype_Sb8vector_above  \
    8252. 

  8252.     case Rectype_Sb8vector: goto case_sb8vector;
    8253. 

  8253.   #define case_Rectype_Sb16vector_above  \
    8254. 

  8254.     case Rectype_Sb16vector: goto case_sb16vector;
    8255. 

  8255.   #define case_Rectype_Sb32vector_above  \
    8256. 

  8256.     case Rectype_Sb32vector: goto case_sb32vector;
    8257. 

  8257.   #define case_Rectype_Sstring_above  \
    8258. 

  8258.     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;
    8259. 

  8259.   #define case_Rectype_Svector_above  \
    8260. 

  8260.     case Rectype_Svector: goto case_svector;
    8261. 

  8261.   #define case_Rectype_mdarray_above  \
    8262. 

  8262.     case Rectype_mdarray: goto case_mdarray;
    8263. 

  8263.   #define case_Rectype_obvector_above  \
    8264. 

  8264.     case Rectype_bvector: goto case_obvector;
    8265. 

  8265.   #define case_Rectype_ob2vector_above  \
    8266. 

  8266.     case Rectype_b2vector: goto case_ob2vector;
    8267. 

  8267.   #define case_Rectype_ob4vector_above  \
    8268. 

  8268.     case Rectype_b4vector: goto case_ob4vector;
    8269. 

  8269.   #define case_Rectype_ob8vector_above  \
    8270. 

  8270.     case Rectype_b8vector: goto case_ob8vector;
    8271. 

  8271.   #define case_Rectype_ob16vector_above  \
    8272. 

  8272.     case Rectype_b16vector: goto case_ob16vector;
    8273. 

  8273.   #define case_Rectype_ob32vector_above  \
    8274. 

  8274.     case Rectype_b32vector: goto case_ob32vector;
    8275. 

  8275.   #define case_Rectype_ostring_above  \
    8276. 

  8276.     case Rectype_string: goto case_ostring;
    8277. 

  8277.   #define case_Rectype_ovector_above  \
    8278. 

  8278.     case Rectype_vector: goto case_ovector;
    8279. 

  8279.   #define case_Rectype_Bignum_above  \
    8280. 

  8280.     case Rectype_Bignum: goto case_bignum;
    8281. 

  8281.   #define case_Rectype_Lfloat_above  \
    8282. 

  8282.     case Rectype_Lfloat: goto case_lfloat;
    8283. 

  8283.   #define case_Rectype_Dfloat_above  \
    8284. 

  8284.     case Rectype_Dfloat: goto case_dfloat;
    8285. 

  8285.   #define case_Rectype_Ffloat_above  \
    8286. 

  8286.     case Rectype_Ffloat: goto case_ffloat;
    8287. 

  8287.   #define case_Rectype_Ratio_above  \
    8288. 

  8288.     case Rectype_Ratio: goto case_ratio;
    8289. 

  8289.   #define case_Rectype_Complex_above  \
    8290. 

  8290.     case Rectype_Complex: goto case_complex;
    8291. 

  8291.   #define case_Rectype_Symbol_above  \
    8292. 

  8292.     case Rectype_Symbol: goto case_symbol;
    8293. 

  8293.   /* Composite cases: */
    8294. 

  8294.   #define case_Rectype_string_above  \
    8295. 

  8295.     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;
    8296. 

  8296.   #define case_Rectype_bvector_above  \
    8297. 

  8297.     case Rectype_Sbvector: case Rectype_bvector: goto case_bvector;
    8298. 

  8298.   #define case_Rectype_b2vector_above  \
    8299. 

  8299.     case Rectype_Sb2vector: case Rectype_b2vector: goto case_b2vector;
    8300. 

  8300.   #define case_Rectype_b4vector_above  \
    8301. 

  8301.     case Rectype_Sb4vector: case Rectype_b4vector: goto case_b4vector;
    8302. 

  8302.   #define case_Rectype_b8vector_above  \
    8303. 

  8303.     case Rectype_Sb8vector: case Rectype_b8vector: goto case_b8vector;
    8304. 

  8304.   #define case_Rectype_b16vector_above  \
    8305. 

  8305.     case Rectype_Sb16vector: case Rectype_b16vector: goto case_b16vector;
    8306. 

  8306.   #define case_Rectype_b32vector_above  \
    8307. 

  8307.     case Rectype_Sb32vector: case Rectype_b32vector: goto case_b32vector;
    8308. 

  8308.   #define case_Rectype_vector_above  \
    8309. 

  8309.     case Rectype_Svector: case Rectype_vector: goto case_vector;
    8310. 

  8310.   #define case_Rectype_array_above                            \
    8311. 

  8311.     case Rectype_S8string: case Rectype_Imm_S8string:         \
    8312. 

  8312.     case Rectype_S16string: case Rectype_Imm_S16string:       \
    8313. 

  8313.     case Rectype_S32string: case Rectype_Imm_S32string:       \
    8314. 

  8314.     case Rectype_reallocstring: case Rectype_string:          \
    8315. 

  8315.     case Rectype_Sbvector: case Rectype_bvector:              \
    8316. 

  8316.     case Rectype_Sb2vector: case Rectype_b2vector:            \
    8317. 

  8317.     case Rectype_Sb4vector: case Rectype_b4vector:            \
    8318. 

  8318.     case Rectype_Sb8vector: case Rectype_b8vector:            \
    8319. 

  8319.     case Rectype_Sb16vector: case Rectype_b16vector:          \
    8320. 

  8320.     case Rectype_Sb32vector: case Rectype_b32vector:          \
    8321. 

  8321.     case Rectype_Svector: case Rectype_vector:                \
    8322. 

  8322.     case Rectype_mdarray:                                     \
    8323. 

  8323.       goto case_array;
    8324. 

  8324.   #define case_Rectype_number_above  /* don't forget immediate_number_p */ \
    8325. 

  8325.     case Rectype_Complex: case Rectype_Ratio:                      \
    8326. 

  8326.     case Rectype_Ffloat: case Rectype_Dfloat: case Rectype_Lfloat: \
    8327. 

  8327.     case Rectype_Bignum:                                           \
    8328. 

  8328.       goto case_number;
    8329. 

  8329.   #define case_Rectype_float_above  /* don't forget short_float_p */ \
    8330. 

  8330.     case Rectype_Ffloat: case Rectype_Dfloat: case Rectype_Lfloat: \
    8331. 

  8331.       goto case_float;
    8332. 

  8332.   #define case_Rectype_integer_above  /* don't forget fixnump */ \
    8333. 

  8333.     case Rectype_Bignum: goto case_integer;
    8334. 

  8334. #endif
    8335. 

  8335. 

  8336. #if defined(TYPECODES) || defined(STANDARD_HEAPCODES)
    8337. 

  8337.   #define case_Rectype_Subr_above
    8338. 

  8338. #else /* LINUX_NOEXEC_HEAPCODES */
    8339. 

  8339.   #define case_Rectype_Subr_above  \
    8340. 

  8340.     case Rectype_Subr: goto case_subr;
    8341. 

  8341. #endif
    8342. 

  8342. 

  8343. 

  8344. /* ################# Declarations for the arithmetics #######################
    8345. 

    8346. 

  8346.  Type hierachy :
    8347. 

  8347.  Number (N) =
    8348. 

  8348.     Real (R) =
    8349. 

  8349.        Float (F) =
    8350. 

  8350.           Short float (SF)
    8351. 

  8351.           Single float (FF)
    8352. 

  8352.           Double float (DF)
    8353. 

  8353.           Long float (LF)
    8354. 

  8354.        Rational (RA) =
    8355. 

  8355.           Integer (I) =
    8356. 

  8356.              Fixnum (FN)
    8357. 

  8357.              Bignum (BN)
    8358. 

  8358.           Ratio (RT)
    8359. 

  8359.     Complex (C)
    8360. 

    8361. 

  8361.  Type field:
    8362. 

  8362.  Bytes for testing whether it's that type (Bit set, is yes).
    8363. 

  8363.  _bit_t to test in the type byte (tint)
    8364. 

  8364.  _bit_o to test in the object (oint) */
    8365. 

  8365. 

  8366. #ifndef NUMBER_BITS_INVERTED
    8367. 

  8367.   #define number_wbit_test  wbit_test
    8368. 

  8368. #else
    8369. 

  8369.   #define number_wbit_test  !wbit_test
    8370. 

  8370. #endif
    8371. 

  8371. 

  8372. #ifdef TYPECODES
    8373. 

  8373. 

  8374. /* see above:
    8375. 

  8375.  #define number_bit_t  4  -- set only for numbers
    8376. 

  8376.  #define number_bit_o  (number_bit_t+oint_type_shift)  -- set only for numbers
    8377. 

    8378. 

  8378.  float_bit:
    8379. 

  8379.  in a number : Bit set, if it's a Float.
    8380. 

  8380.                Bit unset, if it's a rational or complex number.
    8381. 

  8381.  (For NUMBER_BITS_INVERTED it's exactly the other way around.)
    8382. 

  8382.  #define float_bit_t      1
    8383. 

  8383.  #define float_bit_o      (float_bit_t+oint_type_shift)
    8384. 

    8385. 

  8385.  float1_bit:
    8386. 

  8386.  In a floating-point: discriminates further: */
    8387. 

  8387. #ifndef NUMBER_BITS_INVERTED
    8388. 

  8388. /* Float-Bit   1 2
    8389. 

  8389.              0 0    Short Float (SF)
    8390. 

  8390.              0 1    Single Float (FF)
    8391. 

  8391.              1 0    Double Float (DF)
    8392. 

  8392.              1 1    Long Float (LF) */
    8393. 

  8393. #else
    8394. 

  8394. /* Float-Bit   1 2
    8395. 

  8395.              0 0    Long Float (LF)
    8396. 

  8396.              0 1    Double Float (DF)
    8397. 

  8397.              1 0    Single Float (FF)
    8398. 

  8398.              1 1    Short Float (SF) */
    8399. 

  8399. #endif
    8400. 

  8400. /* #define float1_bit_t     3
    8401. 

  8401.  #define float1_bit_o     (float1_bit_t+oint_type_shift)
    8402. 

  8402.  #define float2_bit_t     2
    8403. 

  8403.  #define float2_bit_o     (float2_bit_t+oint_type_shift) */
    8404. 

  8404. 

  8405. /* ratio_bit:
    8406. 

  8406.  For rational numbers: Bit set , if it's a real fraction.
    8407. 

  8407.                        Bit unset, if it's an Integer.
    8408. 

  8408.  (For NUMBER_BITS_INVERTED it's exactly the other way around..)
    8409. 

  8409.  #define ratio_bit_t      3
    8410. 

  8410.  #define ratio_bit_o      (ratio_bit_t+oint_type_shift) */
    8411. 

  8411. 

  8412. /* bignum_bit:
    8413. 

  8413.  For Integers:     Bit set, if it's a Bignum.
    8414. 

  8414.                    Bit unset, if it's a Fixnum.
    8415. 

  8415.  (For NUMBER_BITS_INVERTED it's exactly the other way around..)
    8416. 

  8416.  #define bignum_bit_t     2
    8417. 

  8417.  #define bignum_bit_o     (bignum_bit_t+oint_type_shift) */
    8418. 

  8418. 

  8419. /* vorz_bit: (sign bit)
    8420. 

  8420.  For Reals:
    8421. 

  8421.  returns the sign of the number.
    8422. 

  8422.  Bit set, if number < 0,
    8423. 

  8423.  Bit unset, if number >=0. */
    8424. 

  8424.   #define vorz_bit_t       sign_bit_t
    8425. 

  8425.                            /* should be = 0, so the sign-extend
    8426. 

  8426.                             is easier for Fixnums. */
    8427. 

  8427.   #define vorz_bit_o       (vorz_bit_t+oint_type_shift)
    8428. 

  8428. 

  8429. #endif
    8430. 

  8430. 

  8431. /* return the sign of a real number (0 if >=0, -1 if <0) */
    8432. 

  8432. #ifdef TYPECODES
    8433. 

  8433.   #if (vorz_bit_o<32) && !defined(WIDE_STRUCT)
    8434. 

  8434.     #define R_sign(obj)  ((signean)sign_of_sint32( (sint32)((uint32)as_oint(obj) << (31-vorz_bit_o)) ))
    8435. 

  8435.   #else
    8436. 

  8436.     /* define R_sign(obj)  ((signean)sign_of_sint32( (sint32)(uint32)(as_oint(obj) >> (vorz_bit_o-31)) )) */
    8437. 

  8437.     #define R_sign(obj)  ((signean)sign_of_sint32( (sint32)((uint32)typecode(obj) << (31-vorz_bit_t)) ))
    8438. 

  8438.   #endif
    8439. 

  8439. #else
    8440. 

  8440.   #define R_sign(obj)  ((signean)sign_of_sint32(_R_sign(obj)))
    8441. 

  8441.   #define _R_sign(obj)  \
    8442. 

  8442.     (number_immediatep(obj)                                         \
    8443. 

  8443.      ? /* fixnum, sfloat */ (sint32)as_oint(obj) << (31-sign_bit_o) \
    8444. 

  8444.      : /* [fdl]float */ (sint32)(sintB)Record_flags(obj))
    8445. 

  8445. #endif
    8446. 

  8446. 

  8447. /* Gives the sign of a Fixnum/Bignum/Ratio/
    8448. 

  8448.  Short-/Single-/Double-/Long-Float. */
    8449. 

  8449. #ifdef TYPECODES
    8450. 

  8450.   #define FN_sign(obj)  R_sign(obj)
    8451. 

  8451.   #define BN_sign(obj)  R_sign(obj)
    8452. 

  8452.   #define RT_sign(obj)  R_sign(obj)
    8453. 

  8453.   #define SF_sign(obj)  R_sign(obj)
    8454. 

  8454.   #define FF_sign(obj)  R_sign(obj)
    8455. 

  8455.   #define DF_sign(obj)  R_sign(obj)
    8456. 

  8456.   #define LF_sign(obj)  R_sign(obj)
    8457. 

  8457. #else
    8458. 

  8458.   #define FN_sign(obj)  \
    8459. 

  8459.     ((signean)sign_of_sint32((sint32)as_oint(obj) << (31-sign_bit_o)))
    8460. 

  8460.   #define BN_sign(obj)  \
    8461. 

  8461.     ((signean)sign_of_sint32((sint32)(sintB)Record_flags(obj)))
    8462. 

  8462.   #define RT_sign(obj)  \
    8463. 

  8463.     ((signean)sign_of_sint32((sint32)(sintB)Record_flags(obj)))
    8464. 

  8464.   #define SF_sign(obj)  \
    8465. 

  8465.     ((signean)sign_of_sint32((sint32)as_oint(obj) << (31-sign_bit_o)))
    8466. 

  8466.   #define FF_sign(obj)  \
    8467. 

  8467.     ((signean)sign_of_sint32((sint32)(sintB)Record_flags(obj)))
    8468. 

  8468.   #define DF_sign(obj)  \
    8469. 

  8469.     ((signean)sign_of_sint32((sint32)(sintB)Record_flags(obj)))
    8470. 

  8470.   #define LF_sign(obj)  \
    8471. 

  8471.     ((signean)sign_of_sint32((sint32)(sintB)Record_flags(obj)))
    8472. 

  8472. #endif
    8473. 

  8473. 

  8474. /* Checks whether two real numbers have the same sign: */
    8475. 

  8475. #ifdef TYPECODES
    8476. 

  8476.   #define same_sign_p(obj1,obj2)  \
    8477. 

  8477.     (wbit_test(as_oint(obj1)^as_oint(obj2),vorz_bit_o)==0)
    8478. 

  8478. #else
    8479. 

  8479.   #define same_sign_p(obj1,obj2)  \
    8480. 

  8480.     ((sint32)(_R_sign(obj1) ^ _R_sign(obj2)) >= 0)
    8481. 

  8481. #endif
    8482. 

  8482. 

  8483. 

  8484. /* Type test macros:
    8485. 

  8485.  (Return /=0, if satisfied. Prefix 'm', if argument is in memory) */
    8486. 

  8486. 

  8487. /* Tests an objects whether it's a number: (see above)
    8488. 

  8488.  define numberp(obj)  ... */
    8489. 

  8489. 

  8490. /* Tests a number whether it's a Float. */
    8491. 

  8491. #ifdef TYPECODES
    8492. 

  8492.   #ifndef NUMBER_BITS_INVERTED
    8493. 

  8493.     /* define N_floatp(obj)  ( as_oint(obj) & wbit(float_bit_o) ) */
    8494. 

  8494.     #define N_floatp(obj)  (wbit_test(as_oint(obj),float_bit_o))
    8495. 

  8495.   #else
    8496. 

  8496.     #define N_floatp(obj)  (!wbit_test(as_oint(obj),float_bit_o))
    8497. 

  8497.   #endif
    8498. 

  8498. #else
    8499. 

  8499.   #define N_floatp(obj)  floatp(obj)
    8500. 

  8500. #endif
    8501. 

  8501. 

  8502. /* Tests a number whether it's an Integer. */
    8503. 

  8503. #ifdef TYPECODES
    8504. 

  8504.   #ifndef NUMBER_BITS_INVERTED
    8505. 

  8505.     #define N_integerp(obj)  (!( as_oint(obj) & (wbit(float_bit_o)|wbit(ratio_bit_o)) ))
    8506. 

  8506.   #else
    8507. 

  8507.     #define N_integerp(obj)  (!( (wbit(float_bit_o)|wbit(ratio_bit_o)) & ~as_oint(obj) ))
    8508. 

  8508.   #endif
    8509. 

  8509. #else
    8510. 

  8510.   #define N_integerp(obj)  integerp(obj)
    8511. 

  8511. #endif
    8512. 

  8512. 

  8513. /* Tests a real number whether it's rational. */
    8514. 

  8514. #ifdef TYPECODES
    8515. 

  8515.   #ifndef NUMBER_BITS_INVERTED
    8516. 

  8516.     /* define R_rationalp(obj)  (!( as_oint(obj) & wbit(float_bit_o) )) */
    8517. 

  8517.     #define R_rationalp(obj)  (!wbit_test(as_oint(obj),float_bit_o))
    8518. 

  8518.   #else
    8519. 

  8519.     #define R_rationalp(obj)  (wbit_test(as_oint(obj),float_bit_o))
    8520. 

  8520.   #endif
    8521. 

  8521. #else
    8522. 

  8522.   #define R_rationalp(obj)  (!floatp(obj))
    8523. 

  8523. #endif
    8524. 

  8524. 

  8525. /* Tests a real number whether it's a Float. */
    8526. 

  8526. #ifdef TYPECODES
    8527. 

  8527.   #ifndef NUMBER_BITS_INVERTED
    8528. 

  8528.     /* define R_floatp(obj)  ( as_oint(obj) & wbit(float_bit_o) ) */
    8529. 

  8529.     #define R_floatp(obj)  (wbit_test(as_oint(obj),float_bit_o))
    8530. 

  8530.   #else
    8531. 

  8531.     #define R_floatp(obj)  (!wbit_test(as_oint(obj),float_bit_o))
    8532. 

  8532.   #endif
    8533. 

  8533. #else
    8534. 

  8534.   #define R_floatp(obj)  floatp(obj)
    8535. 

  8535. #endif
    8536. 

  8536. 

  8537. /* Tests a real number whether it's <0. */
    8538. 

  8538. #ifdef TYPECODES
    8539. 

  8539.   /* define R_minusp(obj)  ( as_oint(obj) & wbit(vorz_bit_o) ) */
    8540. 

  8540.   #define R_minusp(obj)  (wbit_test(as_oint(obj),vorz_bit_o))
    8541. 

  8541. #else
    8542. 

  8542.   #define R_minusp(obj)  (!positivep(obj))
    8543. 

  8543. #endif
    8544. 

  8544. %% export_def(R_minusp(obj));
    8545. 

  8545. 

  8546. /* Tests a rational number whether it's an Integer. */
    8547. 

  8547. #ifdef TYPECODES
    8548. 

  8548.   #ifndef NUMBER_BITS_INVERTED
    8549. 

  8549.     /* define RA_integerp(obj)  (!( as_oint(obj) & wbit(ratio_bit_o) )) */
    8550. 

  8550.     #define RA_integerp(obj)  (!wbit_test(as_oint(obj),ratio_bit_o))
    8551. 

  8551.   #else
    8552. 

  8552.     #define RA_integerp(obj)  (wbit_test(as_oint(obj),ratio_bit_o))
    8553. 

  8553.   #endif
    8554. 

  8554. #else
    8555. 

  8555.   #define RA_integerp(obj)  (!ratiop(obj))
    8556. 

  8556. #endif
    8557. 

  8557. 

  8558. /* Tests a rational number whether it's a fraction. */
    8559. 

  8559. #ifdef TYPECODES
    8560. 

  8560.   #ifndef NUMBER_BITS_INVERTED
    8561. 

  8561.     /* define RA_ratiop(obj)  ( as_oint(obj) & wbit(ratio_bit_o) ) */
    8562. 

  8562.     #define RA_ratiop(obj)  (wbit_test(as_oint(obj),ratio_bit_o))
    8563. 

  8563.   #else
    8564. 

  8564.     #define RA_ratiop(obj)  (!wbit_test(as_oint(obj),ratio_bit_o))
    8565. 

  8565.   #endif
    8566. 

  8566. #else
    8567. 

  8567.   #define RA_ratiop(obj)  ratiop(obj)
    8568. 

  8568. #endif
    8569. 

  8569. 

  8570. /* Tests an Integer whether it's a Bignum. */
    8571. 

  8571. #ifndef NUMBER_BITS_INVERTED
    8572. 

  8572.   /* define I_bignump(obj)  ( as_oint(obj) & wbit(bignum_bit_o) ) */
    8573. 

  8573.   #define I_bignump(obj)  (wbit_test(as_oint(obj),bignum_bit_o))
    8574. 

  8574. #else
    8575. 

  8575.   #define I_bignump(obj)  (!wbit_test(as_oint(obj),bignum_bit_o))
    8576. 

  8576. #endif
    8577. 

  8577. 

  8578. /* Tests an Integer whether it's a Fixnum. */
    8579. 

  8579. #ifndef NUMBER_BITS_INVERTED
    8580. 

  8580.   /* define I_fixnump(obj)  (!( as_oint(obj) & wbit(bignum_bit_o) )) */
    8581. 

  8581.   #define I_fixnump(obj)  (!wbit_test(as_oint(obj),bignum_bit_o))
    8582. 

  8582. #else
    8583. 

  8583.   #define I_fixnump(obj)  (wbit_test(as_oint(obj),bignum_bit_o))
    8584. 

  8584. #endif
    8585. 

  8585. 

  8586. /* Tests a Fixnum whether it is >=0. */
    8587. 

  8587. #ifdef TYPECODES
    8588. 

  8588.   #define FN_positivep(obj)  positivep(obj)
    8589. 

  8589. #else
    8590. 

  8590.   #define FN_positivep(obj)  ((as_oint(obj) & wbit(sign_bit_o)) == 0)
    8591. 

  8591. #endif
    8592. 

  8592. %% export_def(FN_positivep(obj));
    8593. 

  8593. 

  8594. /* Tests a Bignum whether it is >=0. */
    8595. 

  8595. #ifdef TYPECODES
    8596. 

  8596.   #define BN_positivep(obj)  positivep(obj)
    8597. 

  8597. #else
    8598. 

  8598.   #define BN_positivep(obj)  ((Record_flags(obj) & bit(7)) == 0)
    8599. 

  8599. #endif
    8600. 

  8600. %% export_def(BN_positivep(obj));
    8601. 

  8601. 

  8602. /* Tests a number whether it's a real number */
    8603. 

  8603. #define N_realp(obj)  (!complexp(obj))
    8604. 

  8604. 

  8605. /* Tests a number whether it's a complex number */
    8606. 

  8606. #define N_complexp(obj)  complexp(obj)
    8607. 

  8607. 

  8608. /* Tests two Integers whether both are Bignum. */
    8609. 

  8609. #ifndef NUMBER_BITS_INVERTED
    8610. 

  8610.   #define I_I_bignums_p(obj1,obj2)  \
    8611. 

  8611.     (wbit_test(as_oint(obj1)&as_oint(obj2),bignum_bit_o))
    8612. 

  8612. #else
    8613. 

  8613.   #define I_I_bignums_p(obj1,obj2)  \
    8614. 

  8614.     (!wbit_test(as_oint(obj1)|as_oint(obj2),bignum_bit_o))
    8615. 

  8615. #endif
    8616. 

  8616. 

  8617. /* Tests for an Integer from a given range.
    8618. 

  8618.  obj should be a variable */
    8619. 

  8619. #define uint1_p(obj)  \
    8620. 

  8620.   ((as_oint(obj) & ~((oint)0x01 << oint_data_shift)) == as_oint(Fixnum_0))
    8621. 

  8621. #define uint2_p(obj)  \
    8622. 

  8622.   ((as_oint(obj) & ~((oint)0x03 << oint_data_shift)) == as_oint(Fixnum_0))
    8623. 

  8623. #define uint4_p(obj)  \
    8624. 

  8624.   ((as_oint(obj) & ~((oint)0x0F << oint_data_shift)) == as_oint(Fixnum_0))
    8625. 

  8625. #define uint8_p(obj)  \
    8626. 

  8626.   ((as_oint(obj) & ~((oint)0xFF << oint_data_shift)) == as_oint(Fixnum_0))
    8627. 

  8627. #define sint8_p(obj)  \
    8628. 

  8628.   (((as_oint(obj) ^ (FN_positivep(obj) ? 0 : as_oint(Fixnum_minus1)^as_oint(Fixnum_0))) & ~((oint)0x7F << oint_data_shift)) == as_oint(Fixnum_0))
    8629. 

  8629. #define uint16_p(obj)  \
    8630. 

  8630.   ((as_oint(obj) & ~((oint)0xFFFF << oint_data_shift)) == as_oint(Fixnum_0))
    8631. 

  8631. #define sint16_p(obj)  \
    8632. 

  8632.   (((as_oint(obj) ^ (FN_positivep(obj) ? 0 : as_oint(Fixnum_minus1)^as_oint(Fixnum_0))) & ~((oint)0x7FFF << oint_data_shift)) == as_oint(Fixnum_0))
    8633. 

  8633. #if (oint_data_len>=32)
    8634. 

  8634.   #define uint32_p(obj)  \
    8635. 

  8635.     ((as_oint(obj) & ~((oint)0xFFFFFFFFUL << oint_data_shift)) == as_oint(Fixnum_0))
    8636. 

  8636. #else
    8637. 

  8637.   #define uint32_p(obj)  \
    8638. 

  8638.     (posfixnump(obj) \
    8639. 

  8639.      || (posbignump(obj) \
    8640. 

  8640.          && (Bignum_length(obj) <= ceiling(33,intDsize)) \
    8641. 

  8641.          && ((Bignum_length(obj) < ceiling(33,intDsize)) \
    8642. 

  8642.              || (TheBignum(obj)->data[0] < (uintD)bit(32%intDsize)))))
    8643. 

  8643. #endif
    8644. 

  8644. #if (oint_data_len>=31)
    8645. 

  8645.   #define sint32_p(obj)  \
    8646. 

  8646.     (((as_oint(obj) ^ (FN_positivep(obj) ? 0 : as_oint(Fixnum_minus1)^as_oint(Fixnum_0))) & ~((oint)0x7FFFFFFFUL << oint_data_shift)) == as_oint(Fixnum_0))
    8647. 

  8647. #else
    8648. 

  8648.   #define sint32_p(obj)  \
    8649. 

  8649.     (fixnump(obj) \
    8650. 

  8650.      || (bignump(obj) \
    8651. 

  8651.          && (Bignum_length(obj) <= ceiling(32,intDsize)) \
    8652. 

  8652.          && ((Bignum_length(obj) < ceiling(32,intDsize)) \
    8653. 

  8653.              || ((TheBignum(obj)->data[0] ^ (BN_positivep(obj) ? (uintD)0 : ~(uintD)0)) < (uintD)bit(31%intDsize)))))
    8654. 

  8654. #endif
    8655. 

  8655. #define uint64_p(obj)  \
    8656. 

  8656.   (posfixnump(obj) \
    8657. 

  8657.    || (posbignump(obj) \
    8658. 

  8658.        && (Bignum_length(obj) <= ceiling(65,intDsize)) \
    8659. 

  8659.        && ((Bignum_length(obj) < ceiling(65,intDsize)) \
    8660. 

  8660.            || (TheBignum(obj)->data[0] < (uintD)bit(64%intDsize)))))
    8661. 

  8661. #define sint64_p(obj)  \
    8662. 

  8662.   (fixnump(obj) \
    8663. 

  8663.    || (bignump(obj) \
    8664. 

  8664.        && (Bignum_length(obj) <= ceiling(64,intDsize)) \
    8665. 

  8665.        && ((Bignum_length(obj) < ceiling(64,intDsize)) \
    8666. 

  8666.            || ((TheBignum(obj)->data[0] ^ (BN_positivep(obj) ? (uintD)0 : ~(uintD)0)) < (uintD)bit(63%intDsize)))))
    8667. 

  8667. #if (int_bitsize==16)
    8668. 

  8668.   #define uint_p  uint16_p
    8669. 

  8669.   #define sint_p  sint16_p
    8670. 

  8670. #else /* (int_bitsize==32) */
    8671. 

  8671.   #define uint_p  uint32_p
    8672. 

  8672.   #define sint_p  sint32_p
    8673. 

  8673. #endif
    8674. 

  8674. #if (long_bitsize==32)
    8675. 

  8675.   #define ulong_p  uint32_p
    8676. 

  8676.   #define slong_p  sint32_p
    8677. 

  8677. #else /* (long_bitsize==64) */
    8678. 

  8678.   #define ulong_p  uint64_p
    8679. 

  8679.   #define slong_p  sint64_p
    8680. 

  8680. #endif
    8681. 

  8681. %% export_def(uint8_p(obj));
    8682. 

  8682. %% export_def(sint8_p(obj));
    8683. 

  8683. %% export_def(uint16_p(obj));
    8684. 

  8684. %% export_def(sint16_p(obj));
    8685. 

  8685. %% export_def(uint32_p(obj));
    8686. 

  8686. %% export_def(sint32_p(obj));
    8687. 

  8687. %% export_def(uint64_p(obj));
    8688. 

  8688. %% export_def(sint64_p(obj));
    8689. 

  8689. %% export_def(uint_p);
    8690. 

  8690. %% export_def(sint_p);
    8691. 

  8691. %% export_def(ulong_p);
    8692. 

  8692. %% export_def(slong_p);
    8693. 

  8693. 

  8694. 

  8695. /* ####################### TIMEBIBL in TIME.D #############################
    8696. 

    8697. 

  8697.  (* 25567 24 60 60) => 2208988800
    8698. 

  8698.  the number of seconds from 1900-01-01 to 1970-01-01 */
    8699. 

  8699. #define UNIX_LISP_TIME_DIFF 2208988800UL
    8700. 

  8700. %% export_def(UNIX_LISP_TIME_DIFF);
    8701. 

  8701. 

  8702. /* Type which is used for 'Internal Time': */
    8703. 

  8703. #if TIME_METHOD == 1
    8704. 

  8704. typedef uintL internal_time_t; /* measured value of the ticking counter */
    8705. 

  8705.   #if defined(TIME_UNIX_TIMES)
    8706. 

  8706.     #define ticks_per_second  CLK_TCK
    8707. 

  8707.   #endif
    8708. 

  8708.   #define sub_internal_time(x,y, z)  z = (x) - (y)
    8709. 

  8709.   #define add_internal_time(x,y, z)  z = (x) + (y)
    8710. 

  8710. #elif TIME_METHOD == 2
    8711. 

  8711.   #ifdef TIME_UNIX
    8712. 

  8712. typedef struct {
    8713. 

  8713.   uintL tv_sec;    /* number of seconds since 1.1.1970 00:00 GMT,
    8714. 

  8714.                       'uintL' for tv_sec is good for 136 years. */
    8715. 

  8715.   uintL tv_usec;   /* additional microseconds */
    8716. 

  8716. } internal_time_t;
    8717. 

  8717.     #define ticks_per_second  1000000UL /* 1 Tick = 1 mu-sec */
    8718. 

  8718.     #define sub_internal_time(x,y, z)   /* z:=x-y */ \
    8719. 

  8719.       do { (z).tv_sec = (x).tv_sec - (y).tv_sec;                \
    8720. 

  8720.         if ((x).tv_usec < (y).tv_usec)                          \
    8721. 

  8721.           { (x).tv_usec += ticks_per_second; (z).tv_sec -= 1; } \
    8722. 

  8722.         (z).tv_usec = (x).tv_usec - (y).tv_usec;                \
    8723. 

  8723.       } while(0)
    8724. 

  8724.     #define add_internal_time(x,y, z)   /* z:=x+y */ \
    8725. 

  8725.       do { (z).tv_sec = (x).tv_sec + (y).tv_sec;                \
    8726. 

  8726.         (z).tv_usec = (x).tv_usec + (y).tv_usec;                \
    8727. 

  8727.         if ((z).tv_usec >= ticks_per_second)                    \
    8728. 

  8728.           { (z).tv_usec -= ticks_per_second; (z).tv_sec += 1; } \
    8729. 

  8729.       } while(0)
    8730. 

  8730.   #endif
    8731. 

  8731.   #ifdef TIME_WIN32
    8732. 

  8732. typedef /* struct _FILETIME { DWORD dwLowDateTime; DWORD dwHighDateTime; } */
    8733. 

  8733.   FILETIME /* number of 0.1 mu-sec since 1.1.1601 00:00 GMT. */
    8734. 

  8734.   internal_time_t;
    8735. 

  8735.     #define ticks_per_second  10000000UL /* 1 Tick = 0.1 mu-sec */
    8736. 

  8736.     #define sub_internal_time(x,y, z)    /* z:=x-y */ \
    8737. 

  8737.       do { (z).dwHighDateTime = (x).dwHighDateTime - (y).dwHighDateTime;      \
    8738. 

  8738.         if ((x).dwLowDateTime < (y).dwLowDateTime) { (z).dwHighDateTime -= 1;}\
    8739. 

  8739.         (z).dwLowDateTime = (x).dwLowDateTime - (y).dwLowDateTime;            \
    8740. 

  8740.       } while(0)
    8741. 

  8741.     #define add_internal_time(x,y, z)    /* z:=x+y */ \
    8742. 

  8742.       do { (z).dwHighDateTime = (x).dwHighDateTime + (y).dwHighDateTime;      \
    8743. 

  8743.         (z).dwLowDateTime = (x).dwLowDateTime + (y).dwLowDateTime;            \
    8744. 

  8744.         if ((z).dwLowDateTime < (x).dwLowDateTime) { (z).dwHighDateTime += 1;}\
    8745. 

  8745.       } while(0)
    8746. 

  8746.   #endif
    8747. 

  8747. #endif
    8748. 

  8748. 

  8749. #ifndef HAVE_RUN_TIME
    8750. 

  8750. /* UP: Stops the run-time timer
    8751. 

  8751.    run_time_stop(); */
    8752. 

  8752.   extern void run_time_stop (void);
    8753. 

  8753.   /* is used by STREAM */
    8754. 

  8754. 

  8755.   /* UP: restarts the run-time timer
    8756. 

  8756.    run_time_restart(); */
    8757. 

  8757.   extern void run_time_restart (void);
    8758. 

  8758.   /* is used by STREAM */
    8759. 

  8759. #else
    8760. 

  8760.   /* You don't need a run-time timer */
    8761. 

  8761.   #define run_time_stop()
    8762. 

  8762.   #define run_time_restart()
    8763. 

  8763. #endif
    8764. 

  8764. 

  8765. #if TIME_METHOD == 1
    8766. 

  8766. 

  8767. /* UP: Yields the real-time
    8768. 

  8768.  get_real_time()
    8769. 

  8769.  < uintL result: time since LISP-system-start (in 1/200 sec resp. in 1/50 sec resp. in 1/100 sec resp. in 1/CLK_TCK sec) */
    8770. 

  8770.   extern uintL get_real_time (void);
    8771. 

  8771. /* is used by STREAM, LISPARIT */
    8772. 

  8772. 

  8773. #elif TIME_METHOD == 2
    8774. 

  8774. 

  8775. /* UP: yields the real-time
    8776. 

  8776.  get_real_time()
    8777. 

  8777.  < internal_time_t* result: absolute time */
    8778. 

  8778.   extern void get_real_time (internal_time_t*);
    8779. 

  8779. /* is used by LISPARIT */
    8780. 

  8780. 

  8781. #endif
    8782. 

  8782. 

  8783. /* UP: Yields the run-time
    8784. 

  8784.  get_running_times(&timescore);
    8785. 

  8785.  < timescore.runtime:  Run-time since LISP-system-start (in Ticks)
    8786. 

  8786.  < timescore.realtime: Real-time since LISP-system-start (in Ticks)
    8787. 

  8787.  < timescore.gctime:   GC-Time since LISP-system-start (in Ticks)
    8788. 

  8788.  < timescore.gccount:  Number of GC's since LISP-system-start
    8789. 

  8789.  < timescore.gcfreed:  Size of the space reclaimed by the GC's so far */
    8790. 

  8790. typedef struct {
    8791. 

  8791.   internal_time_t runtime;
    8792. 

  8792.   internal_time_t realtime;
    8793. 

  8793.   internal_time_t gctime;
    8794. 

  8794.   uintL gccount;
    8795. 

  8795.   uintL2 gcfreed;
    8796. 

  8796. } timescore_t;
    8797. 

  8797. extern void get_running_times (timescore_t*);
    8798. 

  8798. /* is used by TIME */
    8799. 

  8799. 

  8800. /* UP: yields the run-time
    8801. 

  8801.  get_running_time(runtime);
    8802. 

  8802.  < runtime: Run-time (in Ticks) */
    8803. 

  8803.   #ifndef HAVE_RUN_TIME
    8804. 

  8804.     #define get_running_time(runtime)  runtime = get_time()
    8805. 

  8805.     extern uintL get_time (void);
    8806. 

  8806.   #endif
    8807. 

  8807.   #if defined(TIME_UNIX) || defined(TIME_WIN32) || defined(TIME_UNIX_TIMES)
    8808. 

  8808.     #define get_running_time(runtime)  get_run_time(&runtime)
    8809. 

  8809.     #if defined(TIME_UNIX) || defined(TIME_WIN32)
    8810. 

  8810.       extern void get_run_time (internal_time_t* runtime);
    8811. 

  8811.     #endif
    8812. 

  8812.     #ifdef TIME_UNIX_TIMES
    8813. 

  8813.       extern uintL get_run_time (internal_time_t* runtime);
    8814. 

  8814.     #endif
    8815. 

  8815.   #endif
    8816. 

  8816. /* is used by SPVW */
    8817. 

  8817. 

  8818. /* Time in decoded-time: */
    8819. 

  8819. typedef struct {
    8820. 

  8820.   object seconds;
    8821. 

  8821.   object minutes;
    8822. 

  8822.   object hours;
    8823. 

  8823.   object day;
    8824. 

  8824.   object month;
    8825. 

  8825.   object year;
    8826. 

  8826. } decoded_time_t;
    8827. 

  8827. 

  8828. #ifdef UNIX
    8829. 

  8829. /* UP: Converts the system-time-format into Decoded-Time.
    8830. 

  8830.  convert_time(&time,&timepoint);
    8831. 

  8831.  > time_t time: time in the system-time-format
    8832. 

  8832.  < timepoint.seconds, timepoint.minutes, timepoint.hours,
    8833. 

  8833.    timepoint.day, timepoint.month, timepoint.year, each a Fixnum */
    8834. 

  8834.   extern void convert_time (const time_t* time, decoded_time_t* timepoint);
    8835. 

  8835. /* is used by PATHNAME */
    8836. 

  8836. #endif
    8837. 

  8837. #ifdef WIN32_NATIVE
    8838. 

  8838. /* UP: Converts the system-time-format into Decoded-Time.
    8839. 

  8839.  convert_time(&time,&timepoint);
    8840. 

  8840.  > FILETIME time: time in the system-time-format
    8841. 

  8841.  < timepoint.seconds, timepoint.minutes, timepoint.hours,
    8842. 

  8842.    timepoint.day, timepoint.month, timepoint.year, each a Fixnum */
    8843. 

  8843.   extern void convert_time (const FILETIME* time, decoded_time_t* timepoint);
    8844. 

  8844. /* is used by PATHNAME */
    8845. 

  8845. #endif
    8846. 

  8846. 

  8847. #ifdef UNIX
    8848. 

  8848. /* UP: Converts the system time-format into Universal-Time.
    8849. 

  8849.  convert_time_to_universal(&time)
    8850. 

  8850.  > time_t time: time in the system time-format
    8851. 

  8851.  < result: integer denoting the seconds since 1900-01-01 00:00 GMT
    8852. 

  8852.  can trigger GC */
    8853. 

  8853.   extern maygc object convert_time_to_universal (const time_t* time);
    8854. 

  8854. /* is used by PATHNAME */
    8855. 

  8855. #endif
    8856. 

  8856. #ifdef WIN32_NATIVE
    8857. 

  8857. /* UP: converts the system time-format into Universal-Time.
    8858. 

  8858.  convert_time_to_universal(&time)
    8859. 

  8859.  > FILETIME time: Time in the system-time-format
    8860. 

  8860.  < result: integer denoting the seconds since 1900-01-01 00:00 GMT
    8861. 

  8861.  can trigger GC */
    8862. 

  8862.   extern maygc object convert_time_to_universal (const FILETIME* time);
    8863. 

  8863. /* is used by PATHNAME */
    8864. 

  8864. #endif
    8865. 

  8865. %% #ifdef UNIX
    8866. 

  8866. %%   puts("extern object convert_time_to_universal (const time_t* time);");
    8867. 

  8867. %% #endif
    8868. 

  8868. %% #ifdef WIN32_NATIVE
    8869. 

  8869. %%   puts("extern object convert_time_to_universal (const FILETIME* time);");
    8870. 

  8870. %% #endif
    8871. 

  8871. 

  8872. #ifdef UNIX
    8873. 

  8873. /* the inverse of convert_time_to_universal() */
    8874. 

  8874. extern void convert_time_from_universal (object universal, time_t* time);
    8875. 

  8875. #endif
    8876. 

  8876. #ifdef WIN32_NATIVE
    8877. 

  8877. /* the inverse of convert_time_to_universal() */
    8878. 

  8878. extern void convert_time_from_universal (object universal, FILETIME* time);
    8879. 

  8879. #endif
    8880. 

  8880. %% #ifdef UNIX
    8881. 

  8881. %%   puts("extern void convert_time_from_universal (object universal, time_t* time);");
    8882. 

  8882. %% #endif
    8883. 

  8883. %% #ifdef WIN32_NATIVE
    8884. 

  8884. %%   puts("extern void convert_time_from_universal (object universal, FILETIME* time);");
    8885. 

  8885. %% #endif
    8886. 

  8886. 

  8887. /* UP: Initializes the time variables upon the LISP-System-Start.
    8888. 

  8888.  init_time(); */
    8889. 

  8889.   extern void init_time (void);
    8890. 

  8890. /* is used by SPVW */
    8891. 

  8891. 

  8892. 

  8893. /* ####################### SPVWBIBL for SPVW.D #############################
    8894. 

    8895. 

  8895.                           The Stacks
    8896. 

  8896.                           ==========
    8897. 

    8898. 

  8898. Two Stacks are being used :
    8899. 

  8899.   - the C-program stack (Stackpointer SP = Register A7),
    8900. 

  8900.   - the LISP-Stack (Stackpointer STACK).
    8901. 

  8901. All calls of sub-programs are done through BSR/JSR via the program stack;
    8902. 

  8902. it's also used to temporarily store data, that is not a LISP-object.
    8903. 

  8903. The LISP-Stack is used to store frames and for the temporary storage
    8904. 

  8904. of LISP-objects.
    8905. 

  8905. For both stacks the limits of growth are controlled by the memory management
    8906. 

  8906. and the following macros:
    8907. 

  8907.   check_SP();             tests the program stack for overflow
    8908. 

  8908.   check_STACK();          tests the LISP-Stack for overflow
    8909. 

  8909.   get_space_on_STACK(n);  tests, whether there are still D0.L
    8910. 

  8910.                           Bytes free on the LISP-Stack
    8911. 

  8911. Basically only long words may be stored on the LISP-Stack.
    8912. 

  8912. If FRAME_BIT is set, it's the lower end of a frame;
    8913. 

  8913. this long word is a pointer above the Frame, together with a
    8914. 

  8914. Frame-type-Byte; if SKIP2_BIT is unset in it, the longword above
    8915. 

  8915. it is not a LISP-object.
    8916. 

  8916. All other long words on the LISP-Stack are LISP-objects.
    8917. 

    8918. 

  8918.  machine stack: SP
    8919. 

  8919.  SP() returns the current value of the  SP.
    8920. 

  8920.  setSP(adresse); sets the SP to a given value. Extremely dangerous!
    8921. 

  8921.  FAST_SP defined, if SP-accesses are fast. */
    8922. 

  8922. #if defined(GNU) && !(__APPLE_CC__ > 1)
    8923. 

  8923.   /* definition of the register, in which the SP resides. */
    8924. 

  8924.   #ifdef MC680X0
    8925. 

  8925.     #define SP_register "sp"  /* %sp = %a7 */
    8926. 

  8926.   #endif
    8927. 

  8927.   #ifdef SPARC
    8928. 

  8928.     #define SP_register "%sp"  /* %sp = %o6 */
    8929. 

  8929.   #endif
    8930. 

  8930.   #ifdef HPPA
    8931. 

  8931.     #define SP_register "%r30"  /* %sp = %r30 */
    8932. 

  8932.   #endif
    8933. 

  8933.   #ifdef MIPS
    8934. 

  8934.     #define SP_register "$sp"  /* $sp = $29 */
    8935. 

  8935.   #endif
    8936. 

  8936.   #ifdef M88000
    8937. 

  8937.     #define SP_register "%r31"  /* %sp = %r31 */
    8938. 

  8938.   #endif
    8939. 

  8939.   #ifdef POWERPC
    8940. 

  8940.     #define SP_register "r1"
    8941. 

  8941.   #endif
    8942. 

  8942.   #ifdef ARM
    8943. 

  8943.     #define SP_register "%sp"  /* %sp = %r13 */
    8944. 

  8944.   #endif
    8945. 

  8945.   #ifdef DECALPHA
    8946. 

  8946.     #define SP_register "$30"  /* $sp = $30 */
    8947. 

  8947.   #endif
    8948. 

  8948.   #ifdef I80386
    8949. 

  8949.     #define SP_register "%esp"
    8950. 

  8950.   #endif
    8951. 

  8951.   #ifdef VAX
    8952. 

  8952.     #define SP_register "sp"
    8953. 

  8953.   #endif
    8954. 

  8954.   #ifdef IA64
    8955. 

  8955.     #define SP_register "r12"
    8956. 

  8956.   #endif
    8957. 

  8957.   #ifdef AMD64
    8958. 

  8958.     #define SP_register "%rsp"
    8959. 

  8959.   #endif
    8960. 

  8960.   #ifdef S390
    8961. 

  8961.     #define SP_register "15"
    8962. 

  8962.   #endif
    8963. 

  8963. #endif
    8964. 

  8964. #if (defined(GNU) || defined(INTEL)) && !defined(NO_ASM)
    8965. 

  8965.   /* Assembler-instruction that copies the SP-register into a variable. */
    8966. 

  8966.   #ifdef MC680X0
    8967. 

  8967.     #ifdef __REGISTER_PREFIX__ /* GNU C Version >= 2.4 has %/ and __REGISTER_PREFIX__ */
    8968. 

  8968.       /* But the value of __REGISTER_PREFIX__ is useless, because we might be
    8969. 

  8969.        cross-compiling. */
    8970. 

  8970.       #define REGISTER_PREFIX  "%/"
    8971. 

  8971.     #else
    8972. 

  8972.       #define REGISTER_PREFIX  "" /* or "%%", depends on the assembler that's being used */
    8973. 

  8973.     #endif
    8974. 

  8974.     #define ASM_get_SP_register(resultvar)  ("movel "REGISTER_PREFIX"sp,%0" : "=g" (resultvar) : )
    8975. 

  8975.   #endif
    8976. 

  8976.   #ifdef SPARC
    8977. 

  8977.     #ifdef SPARC64
    8978. 

  8978.       #define ASM_get_SP_register(resultvar)  ("add %%sp,2048,%0" : "=r" (resultvar) : )
    8979. 

  8979.     #else
    8980. 

  8980.       #define ASM_get_SP_register(resultvar)  ("mov %%sp,%0" : "=r" (resultvar) : )
    8981. 

  8981.     #endif
    8982. 

  8982.   #endif
    8983. 

  8983.   #ifdef HPPA
    8984. 

  8984.     #define ASM_get_SP_register(resultvar)  ("copy %%r30,%0" : "=r" (resultvar) : )
    8985. 

  8985.   #endif
    8986. 

  8986.   #ifdef MIPS
    8987. 

  8987.     #define ASM_get_SP_register(resultvar)  ("move\t%0,$sp" : "=r" (resultvar) : )
    8988. 

  8988.   #endif
    8989. 

  8989.   #ifdef M88000
    8990. 

  8990.     #define ASM_get_SP_register(resultvar)  ("or %0,#r0,#r31" : "=r" (resultvar) : )
    8991. 

  8991.   #endif
    8992. 

  8992.   #ifdef POWERPC
    8993. 

  8993.     #define ASM_get_SP_register(resultvar)  ("mr %0,1" : "=r" (resultvar) : )
    8994. 

  8994.   #endif
    8995. 

  8995.   #ifdef ARM
    8996. 

  8996.     #define ASM_get_SP_register(resultvar)  ("mov\t%0, sp" : "=r" (resultvar) : )
    8997. 

  8997.   #endif
    8998. 

  8998.   #ifdef DECALPHA
    8999. 

  8999.     #define ASM_get_SP_register(resultvar)  ("bis $30,$30,%0" : "=r" (resultvar) : )
    9000. 

  9000.   #endif
    9001. 

  9001.   #ifdef I80386
    9002. 

  9002.     #define ASM_get_SP_register(resultvar)  ("movl %%esp,%0" : "=g" (resultvar) : )
    9003. 

  9003.   #endif
    9004. 

  9004.   #ifdef IA64
    9005. 

  9005.     #define ASM_get_SP_register(resultvar)  ("mov %0 = r12" : "=r" (resultvar) : )
    9006. 

  9006.   #endif
    9007. 

  9007.   #ifdef AMD64
    9008. 

  9008.     #define ASM_get_SP_register(resultvar)  ("movq %%rsp,%0" : "=g" (resultvar) : )
    9009. 

  9009.   #endif
    9010. 

  9010.   #ifdef S390
    9011. 

  9011.     #define ASM_get_SP_register(resultvar)  ("lr %0,%%r15" : "=r" (resultvar) : )
    9012. 

  9012.   #endif
    9013. 

  9013. #endif
    9014. 

  9014. #if defined(GNU) && defined(MC680X0) && !defined(NO_ASM)
    9015. 

  9015.   /* Access to a global register-"variable" SP */
    9016. 

  9016.   #define SP()  \
    9017. 

  9017.     ({var aint __SP;                                                          \
    9018. 

  9018.       __asm__ __volatile__ ("movel "REGISTER_PREFIX"sp,%0" : "=g" (__SP) : ); \
    9019. 

  9019.       __SP;                                                                   \
    9020. 

  9020.      })
    9021. 

  9021.   #define setSP(adresse)  \
    9022. 

  9022.     ({ __asm__ __volatile__ ("movel %0,"REGISTER_PREFIX"sp" : : "g" ((aint)(adresse)) : "sp" ); })
    9023. 

  9023.   #define FAST_SP
    9024. 

  9024. #elif (defined(GNU) || defined(INTEL)) && defined(I80386) && !defined(NO_ASM)
    9025. 

  9025.   /* Access to a register-"variable" %esp */
    9026. 

  9026.   #define SP()  \
    9027. 

  9027.     ({var aint __SP;                                           \
    9028. 

  9028.       __asm__ __volatile__ ("movl %%esp,%0" : "=g" (__SP) : ); \
    9029. 

  9029.       __SP;                                                    \
    9030. 

  9030.      })
    9031. 

  9031.   /* Doesn't work with gcc 3.1 any more. */
    9032. 

  9032.   #if (__GNUC__ < 3) || (__GNUC__ == 3 && __GNUC_MINOR__ < 1)
    9033. 

  9033.     #define setSP(adresse)  \
    9034. 

  9034.       ({ __asm__ __volatile__ ("movl %0,%%esp" : : "g" ((aint)(adresse)) : "sp" ); })
    9035. 

  9035.     #define FAST_SP
    9036. 

  9036.   #endif
    9037. 

  9037. #elif defined(GNU) && defined(SP_register)
    9038. 

  9038.   register __volatile__ aint __SP __asm__(SP_register);
    9039. 

  9039.   #ifdef SPARC64
    9040. 

  9040.     #define SP()  (__SP+2048)
    9041. 

  9041.   #else
    9042. 

  9042.     #define SP()  __SP
    9043. 

  9043.   #endif
    9044. 

  9044.   #if defined(SPARC)
    9045. 

  9045.     /* We must not do a setSP() here without taking care that
    9046. 

  9046.      1. %sp has to pay attention to an alignment of 8 Bytes,
    9047. 

  9047.      2. above %sp 92 Bytes have to be kept free (that's where the
    9048. 

  9048.         register contents are saved, if a 'register window overflow trap'
    9049. 

  9049.         is triggered by a 'save' in a sub-program). */
    9050. 

  9050.   #endif
    9051. 

  9051. #elif defined(MICROSOFT) && defined(I80386) && !defined(NO_ASM)
    9052. 

  9052.   /* access the register %esp */
    9053. 

  9053.   #define SP  getSP
    9054. 

  9054.   static __inline aint getSP () { __asm mov eax,esp }
    9055. 

  9055.   static __inline aint setSP (aint address) { __asm mov esp,address }
    9056. 

  9056. #elif defined(MC680X0) || defined(SPARC) || defined(MIPS) || defined(I80386)
    9057. 

  9057.   /* access functions extern, in assembler */
    9058. 

  9058.   #define SP  getSP
    9059. 

  9059.   extern_C void* SP (void);
    9060. 

  9060.   extern_C void setSP (void* adresse);
    9061. 

  9061. #else
    9062. 

  9062.   /* access function portable in C */
    9063. 

  9063.   #define SP()  getSP()
    9064. 

  9064.   extern void* getSP (void);
    9065. 

  9065.   #define NEED_OWN_GETSP
    9066. 

  9066. #endif
    9067. 

  9067. #if defined(stack_grows_down) /* defined(MC680X0) || defined(I80386) || defined(SPARC) || defined(MIPS) || defined(M88000) || defined(DECALPHA) || defined(IA64) || defined(AMD64) || defined(S390) || ... */
    9068. 

  9068.   #define SP_DOWN /* SP grows downward */
    9069. 

  9069.   #define SPoffset 0 /* top-of-SP ist *(SP+SPoffset) */
    9070. 

  9070. #endif
    9071. 

  9071. #if defined(stack_grows_up) /* defined(HPPA) || ... */
    9072. 

  9072.   #define SP_UP /* SP grows upward */
    9073. 

  9073.   #define SPoffset -1 /* top-of-SP ist *(SP+SPoffset) */
    9074. 

  9074. #endif
    9075. 

  9075. #if (defined(SP_DOWN) && defined(SP_UP)) || (!defined(SP_DOWN) && !defined(SP_UP))
    9076. 

  9076.   #error "Unknown SP direction -- readjust SP_DOWN/SP_UP!"
    9077. 

  9077. #endif
    9078. 

  9078. /* Derived from that:
    9079. 

  9079.  SPint  is the type of the elements on the SP, an Integer type at least as
    9080. 

  9080.         wide as uintL and at least as wide as aint resp. void*.
    9081. 

  9081.  SP_(n) = (n+1)th longword on the SP.
    9082. 

  9082.  _SP_(n) = &SP_(n).
    9083. 

  9083.  pushSP(item)  puts a longword on the SP. Synonym: -(SP).
    9084. 

  9084.  popSP(item=)  returns item=SP_(0) and takes it off the SP.
    9085. 

  9085.  skipSP(n);  takes n long words of the SP. */
    9086. 

  9086. #if (oint_addr_len <= intLsize)
    9087. 

  9087.   typedef uintL  SPint;
    9088. 

  9088. #else
    9089. 

  9089.   typedef aint  SPint;
    9090. 

  9090. #endif
    9091. 

  9091. #ifdef SP_DOWN
    9092. 

  9092.   #define skipSPop  +=
    9093. 

  9093.   #define SPop      +
    9094. 

  9094. #endif
    9095. 

  9095. #ifdef SP_UP
    9096. 

  9096.   #define skipSPop  -=
    9097. 

  9097.   #define SPop      -
    9098. 

  9098. #endif
    9099. 

  9099. #define _SP_(n)  (((SPint*)SP()) + SPoffset SPop (uintP)(n))
    9100. 

  9100. #if !(defined(GNU) && (defined(MC680X0)) && !defined(NO_ASM)) /* generally */
    9101. 

  9101.   #define SP_(n)  (((SPint*)SP())[SPoffset SPop (uintP)(n)])
    9102. 

  9102.   #define skipSP(n)                             \
    9103. 

  9103.     do { var register SPint* sp = (SPint*)SP(); \
    9104. 

  9104.          sp skipSPop (uintP)(n);                \
    9105. 

  9105.          setSP(sp);                             \
    9106. 

  9106.     } while(0)
    9107. 

  9107.   #define pushSP(item)                                                     \
    9108. 

  9108.     do { var register SPint* sp = (SPint*)SP();                            \
    9109. 

  9109.          sp skipSPop -1;                                                   \
    9110. 

  9110.          setSP(sp); /* First decrease SP (because of a possible interrupt!)  */\
    9111. 

  9111.          sp[SPoffset] = (item); /* then insert item as top-of-SP */        \
    9112. 

  9112.     } while(0)
    9113. 

  9113.   #define popSP(item_assignment)                                        \
    9114. 

  9114.     do { var register SPint* sp = (SPint*)SP();                         \
    9115. 

  9115.          item_assignment sp[SPoffset]; /* First fetch top-of-SP           */\
    9116. 

  9116.          sp skipSPop 1;                                                 \
    9117. 

  9117.          setSP(sp); /* then (danger of interrupt!) increase SP            */\
    9118. 

  9118.     } while(0)
    9119. 

  9119. #endif
    9120. 

  9120. #if defined(GNU) && defined(MC680X0) && !defined(NO_ASM)
    9121. 

  9121.   /* With GNU on as 680X0 SP is in a register. Thus access and
    9122. 

  9122.    modification of SP are a unit that cannot be interrupted.
    9123. 

  9123.    And SP_DOWN as well as SPoffset=0 hold. */
    9124. 

  9124.   #define SP_(n)  \
    9125. 

  9125.     ({var register uintL __n = sizeof(SPint) * (n); \
    9126. 

  9126.       var register SPint __item;                    \
    9127. 

  9127.       __asm__ __volatile__ ("movel "REGISTER_PREFIX"sp@(%1:l),%0" : "=g" (__item) : "r" (__n) ); \
    9128. 

  9128.       __item;                                       \
    9129. 

  9129.      })
    9130. 

  9130.   #define skipSP(n)  \
    9131. 

  9131.     do { var register uintL __n = sizeof(SPint) * (n);  \
    9132. 

  9132.      __asm__ __volatile__ ("addl %0,"REGISTER_PREFIX"sp" : : "g" (__n) : "sp" ); \
    9133. 

  9133.     } while(0)
    9134. 

  9134.   #define pushSP(item)  \
    9135. 

  9135.     do { var register SPint __item = (item); \
    9136. 

  9136.      __asm__ __volatile__ ("movel %0,"REGISTER_PREFIX"sp@-" : : "g" (__item) : "sp" ); \
    9137. 

  9137.     } while(0)
    9138. 

  9138.   #define popSP(item_assignment)  \
    9139. 

  9139.     do {  var register SPint __item; \
    9140. 

  9140.      __asm__ __volatile__ ("movel "REGISTER_PREFIX"sp@+,%0" : "=r" (__item) : : "sp" ); \
    9141. 

  9141.      item_assignment __item;                                                 \
    9142. 

  9142.     } while(0)
    9143. 

  9143. #endif
    9144. 

  9144. /* An sp_jmp_buf is exactly the same as a jmp_buf,
    9145. 

  9145.  except that on Irix 6.5 in 32-bit mode, a jmp_buf has alignment 8,
    9146. 

  9146.  whereas an SPint only has alignment 4.
    9147. 

  9147.  Need to add some padding.
    9148. 

  9148.  Then jmpbufsize = sizeof(sp_jmp_buf)/sizeof(SPint). */
    9149. 

  9149. #define sp_jmp_buf_incr  (alignof(jmp_buf)>alignof(SPint)?alignof(jmp_buf)-alignof(SPint):0)
    9150. 

  9150. #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)))
    9151. 

  9151. #define setjmpspl(x)  setjmpl(sp_jmp_buf_to_jmp_buf(x))
    9152. 

  9152. #define longjmpspl(x,y)  longjmpl(sp_jmp_buf_to_jmp_buf(x),y)
    9153. 

  9153. #define jmpbufsize  ceiling(sizeof(jmp_buf)+sp_jmp_buf_incr,sizeof(SPint))
    9154. 

  9154. typedef SPint sp_jmp_buf[jmpbufsize];
    9155. 

  9155. /* The initial value of SP() during main(). */
    9156. 

  9156. extern void* SP_anchor;
    9157. 

  9157. %% #if (defined(GNU) || defined(INTEL)) && defined(I80386) && !defined(NO_ASM)
    9158. 

  9158. %%   printf("%s\n","#define SP()  ({aint __SP; __asm__ __volatile__ (\"movl %%esp,%0\" : \"=g\" (__SP) : ); __SP; })");
    9159. 

  9159. %% #endif
    9160. 

  9160. 

  9161. /* LISP-Stack: STACK */
    9162. 

  9162. #if !defined(STACK_register)
    9163. 

  9163.   /* a global variable */
    9164. 

  9164.   extern per_thread gcv_object_t* STACK;
    9165. 

  9165. #else
    9166. 

  9166.   /* a global register variable */
    9167. 

  9167.   register gcv_object_t* STACK __asm__(STACK_register);
    9168. 

  9168. #endif
    9169. 

  9169. #if defined(SPARC) && !defined(GNU) && !defined(__SUNPRO_C) && !defined(MULTITHREAD) && (SAFETY < 2)
    9170. 

  9170.   /* a global register variable, but access functions externally in assembler */
    9171. 

  9171.   #define STACK  _getSTACK()
    9172. 

  9172.   extern_C gcv_object_t* _getSTACK (void);
    9173. 

  9173.   #define setSTACK(allocation)  /* hem, yuck! */ \
    9174. 

  9174.     do { var gcv_object_t* tempSTACK; _setSTACK(temp##allocation); } while(0)
    9175. 

  9175.   extern_C void _setSTACK (void* new_STACK);
    9176. 

  9176. #else
    9177. 

  9177.   #define setSTACK(allocation)  allocation
    9178. 

  9178. #endif
    9179. 

  9179. #if defined(UNIX) || defined(WIN32) || defined(HYPERSTONE)
    9180. 

  9180.   #define STACK_UP /* STACK grows upward */
    9181. 

  9181. #endif
    9182. 

  9182. #if (defined(STACK_DOWN) && defined(STACK_UP)) || (!defined(STACK_DOWN) && !defined(STACK_UP))
    9183. 

  9183.   #error "Unknown STACK direction -- readjust STACK_DOWN/STACK_UP!"
    9184. 

  9184. #endif
    9185. 

  9185. %% #if !defined(STACK_register)
    9186. 

  9186. %%   puts("extern gcv_object_t* STACK;");
    9187. 

  9187. %% #else
    9188. 

  9188. %%   puts("#ifndef IN_MODULE_CC");
    9189. 

  9189. %%   printf("register gcv_object_t* STACK __asm__(\"%s\");\n",STACK_register);
    9190. 

  9190. %%   puts("#endif");
    9191. 

  9191. %% #endif
    9192. 

  9192. 

  9193. /* A singly-linked list of all currently active function calls.
    9194. 

  9194.    Resides in the C stack. */
    9195. 

  9195. struct backtrace_t {
    9196. 

  9196.   const struct backtrace_t* bt_next; /* Link to the caller */
    9197. 

  9197.   gcv_object_t bt_function;          /* Function or FSUBR being called */
    9198. 

  9198.   gcv_object_t *bt_stack;            /* STACK value where the frame area begins */
    9199. 

  9199.   int bt_num_arg;                    /* Number of arguments, if known, or -1 */
    9200. 

  9200. };
    9201. 

  9201. extern void back_trace_check (const struct backtrace_t *bt,
    9202. 

  9202.                               const char* label, const char* file, int line);
    9203. 

  9203. #ifdef DEBUG_BACKTRACE
    9204. 

  9204. #define BT_CHECK(b,l) back_trace_check(b,l,__FILE__,__LINE__)
    9205. 

  9205. #else
    9206. 

  9206. #define BT_CHECK(b,l)
    9207. 

  9207. #endif
    9208. 

  9208. #define BT_CHECK1(l)  BT_CHECK(back_trace,l)
    9209. 

  9209. %% 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};");
    9210. 

  9210. 

  9211. #if defined(DEBUG_BACKTRACE) && defined(__cplusplus)
    9212. 

  9212. struct p_backtrace_t {
    9213. 

  9213.   const struct backtrace_t * ba_tr_p;
    9214. 

  9214.   p_backtrace_t (void* bt) { ba_tr_p = (struct backtrace_t*)bt; }
    9215. 

  9215.   /* assignment should check for circularities */
    9216. 

  9216.   p_backtrace_t& operator= (const struct backtrace_t *bt) {
    9217. 

  9217.     if (this->ba_tr_p != bt) {
    9218. 

  9218.       BT_CHECK(bt,"=: new value");
    9219. 

  9219.       BT_CHECK(ba_tr_p,"=: current value");
    9220. 

  9220.       this->ba_tr_p = bt;
    9221. 

  9221.     }
    9222. 

  9222.     return *this;
    9223. 

  9223.   };
    9224. 

  9224.   /* back_trace->foo means back_trace.ba_tr_p->foo */
    9225. 

  9225.   const struct backtrace_t* operator-> () {
    9226. 

  9226.     BT_CHECK(ba_tr_p,"->");
    9227. 

  9227.     return this->ba_tr_p;
    9228. 

  9228.   };
    9229. 

  9229.   /* cast p_backtrace_t to struct backtrace_t* */
    9230. 

  9230.   operator const struct backtrace_t* () const {
    9231. 

  9231.     BT_CHECK(ba_tr_p,"(struct backtrace_t*)");
    9232. 

  9232.     return ba_tr_p;
    9233. 

  9233.   }
    9234. 

  9234. };
    9235. 

  9235. #else
    9236. 

  9236. typedef const struct backtrace_t* p_backtrace_t;
    9237. 

  9237. #endif
    9238. 

  9238. %% emit_typedef("struct backtrace_t *","p_backtrace_t");
    9239. 

  9239. 

  9240. /* Returns the top-of-frame of a back_trace element. */
    9241. 

  9241. extern gcv_object_t* top_of_back_trace_frame (const struct backtrace_t *bt);
    9242. 

  9242. 

  9243. #define bt_beyond_stack_p(bt,st) \
    9244. 

  9244.   ((bt) != NULL && !((aint)(st) cmpSTACKop (aint)top_of_back_trace_frame(bt)))
    9245. 

  9245. /* unwind backtrace to the stack location */
    9246. 

  9246. #define unwind_back_trace(bt,st)                                        \
    9247. 

  9247.   do { BT_CHECK(bt,"unwind_back_trace");                                \
    9248. 

  9248.     while (bt_beyond_stack_p(bt,st))                                    \
    9249. 

  9249.       bt = bt->bt_next;                                                 \
    9250. 

  9250.   } while(0)
    9251. 

  9251. 

  9252. /* Evaluate statement, augmenting back_trace with an activation record for
    9253. 

  9253.    the given function.
    9254. 

  9254.    stack permits to locate the top-of-frame, namely
    9255. 

  9255.      - for FSUBRs:
    9256. 

  9256.          stack = top-of-frame - (req + opt + (body-flag ? 1 : 0))
    9257. 

  9257.      - for SUBRs:
    9258. 

  9258.          stack = top-of-frame - (req + opt + length(keyword-list))
    9259. 

  9259.      - for compiled closures:
    9260. 

  9260.          stack = top-of-frame - (req + opt + (rest-flag ? 1 : 0) + length(keyword-list))
    9261. 

  9261.      - for interpreted closures:
    9262. 

  9262.          stack = top-of-frame
    9263. 

  9263.  */
    9264. 

  9264. #if STACKCHECKS || STACKCHECKC
    9265. 

  9265. #define with_saved_back_trace(fun,stack,num_arg,statement)              \
    9266. 

  9266.   do {                                                                  \
    9267. 

  9267.     p_backtrace_t bt_save = back_trace;                                 \
    9268. 

  9268.     struct backtrace_t bt_here;                                         \
    9269. 

  9269.     bt_here.bt_next = back_trace;                                       \
    9270. 

  9270.     bt_here.bt_function = (fun);                                        \
    9271. 

  9271.     bt_here.bt_stack = (stack);                                         \
    9272. 

  9272.     bt_here.bt_num_arg = (num_arg);                                     \
    9273. 

  9273.     BT_CHECK1("w/s/b/t: before");                                       \
    9274. 

  9274.     back_trace = &bt_here;                                              \
    9275. 

  9275.     statement;                                                          \
    9276. 

  9276.     if (back_trace != &bt_here) abort();                                \
    9277. 

  9277.     if (back_trace->bt_next != bt_save) abort();                        \
    9278. 

  9278.     BT_CHECK1("w/s/b/t: after");                                        \
    9279. 

  9279.     back_trace = back_trace->bt_next;                                   \
    9280. 

  9280.   } while(0)
    9281. 

  9281. #else
    9282. 

  9282. #define with_saved_back_trace(fun,stack,num_arg,statement)              \
    9283. 

  9283.   do {                                                                  \
    9284. 

  9284.     struct backtrace_t bt_here;                                         \
    9285. 

  9285.     bt_here.bt_next = back_trace;                                       \
    9286. 

  9286.     bt_here.bt_function = (fun);                                        \
    9287. 

  9287.     bt_here.bt_stack = (stack);                                         \
    9288. 

  9288.     bt_here.bt_num_arg = (num_arg);                                     \
    9289. 

  9289.     back_trace = &bt_here;                                              \
    9290. 

  9290.     statement;                                                          \
    9291. 

  9291.     back_trace = back_trace->bt_next;                                   \
    9292. 

  9292.   } while(0)
    9293. 

  9293. #endif
    9294. 

  9294. #define with_saved_back_trace_fsubr(fun,statement)  \
    9295. 

  9295.   with_saved_back_trace(fun,STACK,-1,statement)
    9296. 

  9296. #define with_saved_back_trace_subr(fun,stack,num_arg,statement)  \
    9297. 

  9297.   with_saved_back_trace(fun,stack,num_arg,statement)
    9298. 

  9298. #define with_saved_back_trace_cclosure(fun,statement)  \
    9299. 

  9299.   with_saved_back_trace(fun,STACK,-1,statement)
    9300. 

  9300. #define with_saved_back_trace_iclosure(fun,stack,num_arg,statement)  \
    9301. 

  9301.   with_saved_back_trace(fun,stack,num_arg,statement)
    9302. 

  9302. 

  9303. /* Every call of an external function (or a sequence of those) has to be framed
    9304. 

  9304.  with
    9305. 

  9305.    begin_call();
    9306. 

  9306.  and
    9307. 

  9307.    end_call();
    9308. 

  9308.  Purpose: The stack, if it resides in a register,
    9309. 

  9309.  should be brought to a halfway recent value
    9310. 

  9310.  in case of an interrupt during the corresponding timespan. */
    9311. 

  9311. #
    9312. 

  9312. /* If you want to access the STACK while an external function run,
    9313. 

  9313.  you have to frame the corresponding code with
    9314. 

  9314.    begin_callback();
    9315. 

  9315.  and
    9316. 

  9316.    end_callback(); */
    9317. 

  9317. #ifdef HAVE_SAVED_mv_count
    9318. 

  9318.   extern per_thread uintC saved_mv_count;
    9319. 

  9319.   #define SAVE_mv_count()     saved_mv_count = mv_count
    9320. 

  9320.   #define RESTORE_mv_count()  mv_count = saved_mv_count
    9321. 

  9321. #else
    9322. 

  9322.   #define SAVE_mv_count()
    9323. 

  9323.   #define RESTORE_mv_count()
    9324. 

  9324. #endif
    9325. 

  9325. #ifdef HAVE_SAVED_value1
    9326. 

  9326.   extern per_thread object saved_value1;
    9327. 

  9327.   #define SAVE_value1()     saved_value1 = value1
    9328. 

  9328.   #define RESTORE_value1()  value1 = saved_value1
    9329. 

  9329. #else
    9330. 

  9330.   #define SAVE_value1()
    9331. 

  9331.   #define RESTORE_value1()
    9332. 

  9332. #endif
    9333. 

  9333. #ifdef HAVE_SAVED_back_trace
    9334. 

  9334.   extern per_thread p_backtrace_t saved_back_trace;
    9335. 

  9335.   #define SAVE_back_trace()     saved_back_trace = back_trace
    9336. 

  9336.   #define RESTORE_back_trace()  back_trace = saved_back_trace
    9337. 

  9337. #else
    9338. 

  9338.   #define SAVE_back_trace()
    9339. 

  9339.   #define RESTORE_back_trace()
    9340. 

  9340. #endif
    9341. 

  9341. #define SAVE_GLOBALS()     SAVE_mv_count(); SAVE_value1(); SAVE_back_trace();
    9342. 

  9342. #define RESTORE_GLOBALS()  RESTORE_mv_count(); RESTORE_value1(); RESTORE_back_trace();
    9343. 

  9343. #if defined(HAVE_SAVED_STACK)
    9344. 

  9344.   extern per_thread gcv_object_t* saved_STACK;
    9345. 

  9345.   #define begin_call()  SAVE_GLOBALS(); saved_STACK = STACK
    9346. 

  9346.   #define end_call()  RESTORE_GLOBALS(); saved_STACK = (gcv_object_t*)NULL
    9347. 

  9347.   #define begin_callback()  SAVE_REGISTERS( STACK = saved_STACK; ); end_call()
    9348. 

  9348.   #define end_callback()  SAVE_GLOBALS(); RESTORE_REGISTERS( saved_STACK = STACK; )
    9349. 

  9349. #else
    9350. 

  9350.   #define begin_call()  SAVE_GLOBALS()
    9351. 

  9351.   #define end_call()  RESTORE_GLOBALS()
    9352. 

  9352.   #define begin_callback()  SAVE_REGISTERS(;); end_call()
    9353. 

  9353.   #define end_callback()  SAVE_GLOBALS(); RESTORE_REGISTERS(;)
    9354. 

  9354. #endif
    9355. 

  9355. %% #ifdef HAVE_SAVED_mv_count
    9356. 

  9356. %%   puts("extern uintC saved_mv_count;");
    9357. 

  9357. %% #endif
    9358. 

  9358. %% #ifdef HAVE_SAVED_value1
    9359. 

  9359. %%   puts("extern object saved_value1;");
    9360. 

  9360. %% #endif
    9361. 

  9361. %% #ifdef HAVE_SAVED_back_trace
    9362. 

  9362. %%   puts("extern p_backtrace_t saved_back_trace;");
    9363. 

  9363. %% #endif
    9364. 

  9364. %% #if defined(HAVE_SAVED_STACK)
    9365. 

  9365. %%   puts("extern gcv_object_t* saved_STACK;");
    9366. 

  9366. %% #endif
    9367. 

  9367. %% export_def(begin_call());
    9368. 

  9368. %% export_def(end_call());
    9369. 

  9369. %% export_def(begin_callback());
    9370. 

  9370. %% export_def(end_callback());
    9371. 

  9371. 

  9372. /* Every OS-call (or a sequence thereof) has to be framed with
    9373. 

  9373.    begin_system_call();
    9374. 

  9374.  and
    9375. 

  9375.    end_system_call();
    9376. 

  9376.  Purpose: The STACK - if it resides in a register -
    9377. 

  9377.  should be brought to a halfway recent value,
    9378. 

  9378.  if an interrupt happens during the corresponding timespan. */
    9379. 

  9379. #
    9380. 

  9380. /* While a break-semaphore has been set, you don't have to use the macros
    9381. 

  9381.  because of that. */
    9382. 

  9382. #ifdef NO_ASYNC_INTERRUPTS
    9383. 

  9383.   /* NO_ASYNC_INTERRUPTS: if we don't react to asynchronous Interrupts,
    9384. 

  9384.      the program can't be interruped.. */
    9385. 

  9385.   #define begin_system_call()
    9386. 

  9386.   #define end_system_call()
    9387. 

  9387. #else
    9388. 

  9388.   #define begin_system_call()  begin_call()
    9389. 

  9389.   #define end_system_call()  end_call()
    9390. 

  9390. #endif
    9391. 

  9391. /* The same holds for setjmp()/longjmp(). Here we avoid an unneeded overhead
    9392. 

  9392.  if at all possible.
    9393. 

  9393.  You don't have to use these macros when a break-semaphore has been
    9394. 

  9394.  set. */
    9395. 

  9395. #if 0
    9396. 

  9396.   /* Disassembly of setjmp() and longjmp() shows, that the STACK-register
    9397. 

  9397.    isn't used arbitrarily. */
    9398. 

  9398.   #define begin_setjmp_call()
    9399. 

  9399.   #define end_setjmp_call()
    9400. 

  9400.   #define begin_longjmp_call()
    9401. 

  9401.   #define end_longjmp_call()
    9402. 

  9402. #elif defined(I80386) && (defined(UNIX_LINUX) || defined(UNIX_GNU))
    9403. 

  9403.   /* Disassembly of setjmp() shows, that the STACK-register %ebx
    9404. 

  9404.    isn't used arbitrarily. */
    9405. 

  9405.   #define begin_setjmp_call()
    9406. 

  9406.   #define end_setjmp_call()
    9407. 

  9407.   #define begin_longjmp_call()  begin_system_call()
    9408. 

  9408.   #define end_longjmp_call()  end_system_call()
    9409. 

  9409. #else
    9410. 

  9410.   #define begin_setjmp_call()  begin_system_call()
    9411. 

  9411.   #define end_setjmp_call()  end_system_call()
    9412. 

  9412.   #define begin_longjmp_call()  begin_system_call()
    9413. 

  9413.   #define end_longjmp_call()  end_system_call()
    9414. 

  9414. #endif
    9415. 

  9415. /* The same holds for arithmetics-functions that use the STACK_registers.
    9416. 

  9416.  On I80386 (%ebx) these are SHIFT_LOOPS, MUL_LOOPS, DIV_LOOPS. */
    9417. 

  9417. #if defined(I80386) && !defined(NO_ARI_ASM) && defined(HAVE_SAVED_STACK)
    9418. 

  9418.   #define begin_arith_call()  begin_system_call()
    9419. 

  9419.   #define end_arith_call()  end_system_call()
    9420. 

  9420. #else
    9421. 

  9421.   #define begin_arith_call()
    9422. 

  9422.   #define end_arith_call()
    9423. 

  9423. #endif
    9424. 

  9424. %% export_def(begin_system_call());
    9425. 

  9425. %% export_def(end_system_call());
    9426. 

  9426. 

  9427. #if defined(HAVE_STACK_OVERFLOW_RECOVERY)
    9428. 

  9428.   /* Detection of SP-overflow through a Guard-Page or other mechanisms. */
    9429. 

  9429.   #define NOCOST_SP_CHECK
    9430. 

  9430. #else
    9431. 

  9431.   /* The OS is responsible for the SP.
    9432. 

  9432.    From where should we get a reasonable value for SP_bound? */
    9433. 

  9433.   #define NO_SP_CHECK
    9434. 

  9434. #endif
    9435. 

  9435. 

  9436. /* Tests for SP-overflow.
    9437. 

  9437.  check_SP();            tests for overflow
    9438. 

  9438.  check_SP_notUNIX();    dito, except when a temporary overflow doesn't matter */
    9439. 

  9439. #define check_SP()  if (SP_overflow()) SP_ueber()
    9440. 

  9440. #if !(defined(NO_SP_CHECK) || defined(NOCOST_SP_CHECK))
    9441. 

  9441.   #ifdef SP_DOWN
    9442. 

  9442.     #define SP_overflow()  ( (aint)SP() < (aint)SP_bound )
    9443. 

  9443.   #endif
    9444. 

  9444.   #ifdef SP_UP
    9445. 

  9445.     #define SP_overflow()  ( (aint)SP() > (aint)SP_bound )
    9446. 

  9446.   #endif
    9447. 

  9447. #else /* NO_SP_CHECK || NOCOST_SP_CHECK */
    9448. 

  9448.   #define SP_overflow()  false
    9449. 

  9449.   #ifdef NOCOST_SP_CHECK
    9450. 

  9450.     #ifdef WIN32_NATIVE
    9451. 

  9451.       #ifdef SP_DOWN
    9452. 

  9452.         #define near_SP_overflow()  ( (aint)SP() < (aint)SP_bound+0x1000 )
    9453. 

  9453.       #endif
    9454. 

  9454.       #ifdef SP_UP
    9455. 

  9455.         #define near_SP_overflow()  ( (aint)SP() > (aint)SP_bound-0x1000 )
    9456. 

  9456.       #endif
    9457. 

  9457.     #else
    9458. 

  9458.       extern bool near_SP_overflow (void);
    9459. 

  9459.     #endif
    9460. 

  9460.   #endif
    9461. 

  9461. #endif
    9462. 

  9462. extern per_thread void* SP_bound;
    9463. 

  9463. nonreturning_function(extern, SP_ueber, (void));
    9464. 

  9464. #ifdef UNIX
    9465. 

  9465.   #define check_SP_notUNIX()
    9466. 

  9466. #else
    9467. 

  9467.   #define check_SP_notUNIX()  check_SP()
    9468. 

  9468. #endif
    9469. 

  9469. 

  9470. /* Tests for STACK-overflow.
    9471. 

  9471.  check_STACK(); */
    9472. 

  9472. #define check_STACK()  if (STACK_overflow()) STACK_ueber()
    9473. 

  9473. #ifdef STACK_DOWN
    9474. 

  9474.   #define STACK_overflow()  ( (aint)STACK < (aint)STACK_bound )
    9475. 

  9475. #endif
    9476. 

  9476. #ifdef STACK_UP
    9477. 

  9477.   #define STACK_overflow()  ( (aint)STACK > (aint)STACK_bound )
    9478. 

  9478. #endif
    9479. 

  9479. extern per_thread void* STACK_bound;
    9480. 

  9480. extern per_thread void* STACK_start;
    9481. 

  9481. nonreturning_function(extern, STACK_ueber, (void));
    9482. 

  9482. %% #if notused
    9483. 

  9483. %% export_def(check_STACK());
    9484. 

  9484. %% export_def(STACK_overflow());
    9485. 

  9485. %% export_def(get_space_on_STACK(n));
    9486. 

  9486. %% puts("extern void* STACK_bound;");
    9487. 

  9487. %% puts("nonreturning_function(extern, STACK_ueber, (void));");
    9488. 

  9488. %% #endif
    9489. 

  9489. 

  9490. /* Tests, if there are still n Bytes free on the STACK.
    9491. 

  9491.  get_space_on_STACK(n); */
    9492. 

  9492. #ifdef STACK_DOWN
    9493. 

  9493.   #define get_space_on_STACK(n)  \
    9494. 

  9494.     if ( (aint)STACK < (aint)STACK_bound + (aint)(n) ) STACK_ueber()
    9495. 

  9495. #else
    9496. 

  9496.   #define get_space_on_STACK(n)  \
    9497. 

  9497.     if ( (aint)STACK + (aint)(n) > (aint)STACK_bound ) STACK_ueber()
    9498. 

  9498. #endif
    9499. 

  9499. 

  9500. /* Exit the LISP-Interpreter
    9501. 

  9501.  quit();
    9502. 

  9502.  > final_exitcode: 0 for a normal end, >0 for failure, -signum for a signal */
    9503. 

  9503. nonreturning_function(extern, quit, (void));
    9504. 

  9504. extern int final_exitcode;
    9505. 

  9505. /* is used by CONTROL */
    9506. 

  9506. 

  9507. /* Error message if an unreachable program part has been reached.
    9508. 

  9508.  Does not return.
    9509. 

  9509.  error_notreached(file,line);
    9510. 

  9510.  > file: Filename (with quotation marks) as constant ASCIZ-String
    9511. 

  9511.  > line: line number */
    9512. 

  9512. nonreturning_function(extern, error_notreached, (const char * file, uintL line));
    9513. 

  9513. /* used by all modules */
    9514. 

  9514. %% puts("nonreturning_function(extern, error_notreached, (const char * file, uintL line));");
    9515. 

  9515. 

  9516. /* Language that's used to communicate with the user: */
    9517. 

  9517. #ifdef LANGUAGE_STATIC
    9518. 

  9518.   #if ENGLISH
    9519. 

  9519.     #define GETTEXT(english)   english
    9520. 

  9520.     #define GETTEXTL(english)  english
    9521. 

  9521.   #endif
    9522. 

  9522. #else
    9523. 

  9523.   #define language_english   0
    9524. 

  9524.   #ifndef GNU_GETTEXT
    9525. 

  9525.     /* Language is determined at runtime by the variable language. */
    9526. 

  9526.     extern uintL language;
    9527. 

  9527.     #define ENGLISH  (language==language_english)
    9528. 

  9528.     #define GETTEXT(english)  english
    9529. 

  9529.     #define GETTEXTL(english)  english
    9530. 

  9530.   #else /* GNU_GETTEXT */
    9531. 

  9531.     #ifndef COMPILE_STANDALONE
    9532. 

  9532.       #include <libintl.h>
    9533. 

  9533.     #endif
    9534. 

  9534.     /* Fetch the message translations from a message catalog. */
    9535. 

  9535.     #ifndef gettext  /* Sometimes `gettext' is a macro... */
    9536. 

  9536.       extern char* gettext (const char * msgid);
    9537. 

  9537.     #endif
    9538. 

  9538.     extern const char * clgettext (const char * msgid);
    9539. 

  9539.     extern const char * clgettextl (const char * msgid);
    9540. 

  9540.     /* GETTEXT(english_message) fetches the translation of english_message
    9541. 

  9541.      and returns it in UTF-8 (if UNICODE is defined).
    9542. 

  9542.      GETTEXTL(english_message) fetches the translation of english_message
    9543. 

  9543.      and returns it in the locale encoding.
    9544. 

  9544.      GETTEXT and GETTEXTL are special tags recognized by clisp-xgettext. We
    9545. 

  9545.      choose English because it's the only language understood by all CLISP
    9546. 

  9546.      developers. */
    9547. 

  9547.     #define GETTEXT  clgettext
    9548. 

  9548.     #define GETTEXTL clgettextl
    9549. 

  9549.   #endif
    9550. 

  9550. 

  9551.   /* init the language and the locale */
    9552. 

  9552.   extern void init_language (const char*, const char*);
    9553. 

  9553. #endif
    9554. 

  9554. %% #if !defined(LANGUAGE_STATIC) && defined(GNU_GETTEXT)
    9555. 

  9555. %%   puts("#define GNU_GETTEXT");
    9556. 

  9556. %%   puts("#ifndef COMPILE_STANDALONE");
    9557. 

  9557. %%   puts("#include <libintl.h>");
    9558. 

  9558. %%   puts("#endif");
    9559. 

  9559. %%   puts("extern const char * clgettext (const char * msgid);");
    9560. 

  9560. %%   export_def(GETTEXT);
    9561. 

  9561. %% #else
    9562. 

  9562. %%   export_def(GETTEXT(english));
    9563. 

  9563. %% #endif
    9564. 

  9564. 

  9565. /* Fetch the message translations of a string: "CL String getTEXT"
    9566. 

  9566.  CLSTEXT(string)
    9567. 

  9567.  > obj: C string
    9568. 

  9568.  < result: String
    9569. 

  9569.  can trigger GC */
    9570. 

  9570. extern maygc object CLSTEXT (const char*);
    9571. 

  9571. %% #ifndef LANGUAGE_STATIC
    9572. 

  9572. %%   #ifndef GNU_GETTEXT
    9573. 

  9573. %%     emit_define("CLSTEXT","ascii_to_string");
    9574. 

  9574. %%   #else
    9575. 

  9575. %%     puts("extern object CLSTEXT (const char* asciz);");
    9576. 

  9576. %%   #endif
    9577. 

  9577. %% #endif
    9578. 

  9578. 

  9579. /* Fetch the "translation" of a Lisp object: "CL Object getTEXT"
    9580. 

  9580.  CLOTEXT(string)
    9581. 

  9581.  > obj: String
    9582. 

  9582.  can trigger GC */
    9583. 

  9583. extern maygc object CLOTEXT (const char*);
    9584. 

  9584. 

  9585. /* Print a Lisp object in Lisp notation relatively directly
    9586. 

  9586.  through the operating system:
    9587. 

  9587.  object_out(obj);
    9588. 

  9588.  can trigger GC */
    9589. 

  9589. extern maygc object object_out (object obj);
    9590. 

  9590. /* can trigger GC
    9591. 

  9591.  print the object with label, file name and line number
    9592. 

  9592.  this can trigger GC, but will save and restore OBJ */
    9593. 

  9593. #define OBJECT_OUT(obj,label)                                           \
    9594. 

  9594.   (printf("[%s:%d] %s: %s:\n",__FILE__,__LINE__,STRING(obj),label),     \
    9595. 

  9595.    obj=object_out(obj))
    9596. 

  9596. /* print the object to a C stream - not all objects can be handled yet!
    9597. 

  9597.  non-consing, STACK non-modifying */
    9598. 

  9598. extern maygc object nobject_out (FILE* out, object obj);
    9599. 

  9599. #define NOBJECT_OUT(obj,label)                                         \
    9600. 

  9600.   (printf("[%s:%d] %s: %s: ",__FILE__,__LINE__,STRING(obj),label),     \
    9601. 

  9601.    nobject_out(stdout,obj), printf("\n"))
    9602. 

  9602. /* used for debugging purposes */
    9603. 

  9603. %% puts("extern object object_out (object obj);");
    9604. 

  9604. %% puts("#define OBJECT_OUT(obj,label)  (printf(\"[%s:%d] %s: %s:\\n\",__FILE__,__LINE__,STRING(obj),label),obj=object_out(obj))");
    9605. 

  9605. 

  9606. /* After allocating memory for an object, add the type infos. */
    9607. 

  9607. #ifdef TYPECODES
    9608. 

  9608.   #define bias_type_pointer_object(bias,type,ptr) type_pointer_object(type,ptr)
    9609. 

  9609. #else
    9610. 

  9610.   #ifdef WIDE_AUXI
    9611. 

  9611.     #define bias_type_pointer_object(bias,type,ptr) as_object_with_auxi((aint)(ptr)+(bias))
    9612. 

  9612.   #else
    9613. 

  9613.     #define bias_type_pointer_object(bias,type,ptr) as_object((oint)(ptr)+(bias))
    9614. 

  9614.   #endif
    9615. 

  9615. #endif
    9616. 

  9616. /* used by SPVW, macros SP_allocate_bit_vector, SP_allocate_string */
    9617. 

  9617. 

  9618. /* UP: executes a Garbage Collection
    9619. 

  9619.  gar_col(level);
    9620. 

  9620.  > level: if 1, also drop all jitc code
    9621. 

  9621.  can trigger GC */
    9622. 

  9622. extern maygc void gar_col (int level);
    9623. 

  9623. /* is used by DEBUG */
    9624. 

  9624. 

  9625. /* GC-statistics */
    9626. 

  9626. extern uintL gc_count;
    9627. 

  9627. extern uintL2 gc_space;
    9628. 

  9628. extern internal_time_t gc_time;
    9629. 

  9629. /* is used by TIME */
    9630. 

  9630. 

  9631. /* UP:  allocates a Cons
    9632. 

  9632.  allocate_cons()
    9633. 

  9633.  < result: pointer to a new CONS, with CAR and CDR =NIL
    9634. 

  9634.  can trigger GC */
    9635. 

  9635. extern maygc object allocate_cons (void);
    9636. 

  9636. /* is used by LIST, SEQUENCE, PACKAGE, EVAL, CONTROL, RECORD,
    9637. 

  9637.             PREDTYPE, IO, STREAM, PATHNAME, SYMBOL, ARRAY, LISPARIT */
    9638. 

  9638. %% puts("extern object allocate_cons (void);");
    9639. 

  9639. 

  9640. /* UP: Returns a newly created uninterned symbol with a given Printname.
    9641. 

  9641.  make_symbol(string)
    9642. 

  9642.  > string: immutable Simple-String
    9643. 

  9643.  < result: new symbol with this name, with Home-Package=NIL.
    9644. 

  9644.  can trigger GC */
    9645. 

  9645. extern maygc object make_symbol (object string);
    9646. 

  9646. /* is used by PACKAGE, IO, SYMBOL */
    9647. 

  9647. %% #if notused
    9648. 

  9648. %% puts("extern object make_symbol (object string);");
    9649. 

  9649. %% #endif
    9650. 

  9650. 

  9651. /* UP: allocates a general vector
    9652. 

  9652.  allocate_vector(len)
    9653. 

  9653.  > len: length of the vector
    9654. 

  9654.  < result: fresh simple general vector (elements are initialized with NIL)
    9655. 

  9655.  can trigger GC */
    9656. 

  9656. extern maygc object allocate_vector (uintL len);
    9657. 

  9657. /* is used by ARRAY, IO, EVAL, PACKAGE, CONTROL, HASHTABL */
    9658. 

  9658. %% puts("extern object allocate_vector (uintL len);");
    9659. 

  9659. 

  9660. /* Function: Allocates a bit/byte vector.
    9661. 

  9661.  allocate_bit_vector(atype,len)
    9662. 

  9662.  > uintB atype: Atype_nBit
    9663. 

  9663.  > uintL len: length (number of n-bit blocks)
    9664. 

  9664.  < result: fresh simple bit/byte-vector of the given length
    9665. 

  9665.  can trigger GC */
    9666. 

  9666. extern maygc object allocate_bit_vector (uintB atype, uintL len);
    9667. 

  9667. /* is used by ARRAY, IO, RECORD, LISPARIT, STREAM, CLX */
    9668. 

  9668. %% puts("extern object allocate_bit_vector (uintB atype, uintL len);");
    9669. 

  9669. 

  9670. /* Macro: Allocates a 8bit-vector on the stack, with dynamic extent.
    9671. 

  9671.    { var DYNAMIC_8BIT_VECTOR(obj,len);
    9672. 

  9672.      ...
    9673. 

  9673.      FREE_DYNAMIC_8BIT_VECTOR(obj);
    9674. 

  9674.    }
    9675. 

  9675.  > uintL len: length (number of bytes)
    9676. 

  9676.  < object obj: simple-8bit-vector with dynamic extent
    9677. 

  9677.    (may or may not be heap-allocated, therefore not GC-invariant)
    9678. 

  9678.  can trigger GC */
    9679. 

  9679. #if defined(SPVW_PURE) || ((((STACK_ADDRESS_RANGE << addr_shift) >> garcol_bit_o) & 1) != 0)
    9680. 

  9680.   /* No way to allocate a Lisp object on the stack. */
    9681. 

  9681.   #define DYNAMIC_8BIT_VECTOR(objvar,len)  \
    9682. 

  9682.     var uintL objvar##_len = (len);               \
    9683. 

  9683.     var object objvar = O(dynamic_8bit_vector);   \
    9684. 

  9684.     O(dynamic_8bit_vector) = NIL;                 \
    9685. 

  9685.     if (!(simple_bit_vector_p(Atype_8Bit,objvar) && (Sbvector_length(objvar) >= objvar##_len))) \
    9686. 

  9686.       objvar = allocate_bit_vector(Atype_8Bit,objvar##_len); \
    9687. 

  9687.     GCTRIGGER1(objvar)
    9688. 

  9688.   #define FREE_DYNAMIC_8BIT_VECTOR(objvar)  \
    9689. 

  9689.     O(dynamic_8bit_vector) = objvar
    9690. 

  9690. #else
    9691. 

  9691.   /* Careful: Fill GCself with pointers to itself, so that GC will leave
    9692. 

  9692.    pointers to this object untouched. */
    9693. 

  9693.   #ifdef TYPECODES
    9694. 

  9694.     #define DYNAMIC_8BIT_VECTOR(objvar,len)  \
    9695. 

  9695.       DYNAMIC_ARRAY(objvar##_storage,object,ceiling((uintL)(len)+offsetofa(sbvector_,data),sizeof(gcv_object_t))); \
    9696. 

  9696.       var object objvar = ((Sbvector)objvar##_storage)->GCself = bias_type_pointer_object(varobject_bias,sb8vector_type,(Sbvector)objvar##_storage); \
    9697. 

  9697.       ((Sbvector)objvar##_storage)->length = (len); \
    9698. 

  9698.       GCTRIGGER1(objvar)
    9699. 

  9699.   #else
    9700. 

  9700.     #define DYNAMIC_8BIT_VECTOR(objvar,len)  \
    9701. 

  9701.       DYNAMIC_ARRAY(objvar##_storage,object,ceiling((uintL)(len)+offsetofa(sbvector_,data)+varobjects_misaligned,sizeof(gcv_object_t))); \
    9702. 

  9702.       var object* objvar##_address = (object*)((uintP)objvar##_storage | varobjects_misaligned); \
    9703. 

  9703.       var object objvar = ((Sbvector)objvar##_address)->GCself = bias_type_pointer_object(varobject_bias,sb8vector_type,(Sbvector)objvar##_address); \
    9704. 

  9704.       ((Sbvector)objvar##_address)->tfl = vrecord_tfl(Rectype_Sb8vector,len); \
    9705. 

  9705.       GCTRIGGER1(objvar)
    9706. 

  9706.   #endif
    9707. 

  9707.   #define FREE_DYNAMIC_8BIT_VECTOR(objvar)  \
    9708. 

  9708.     FREE_DYNAMIC_ARRAY(objvar##_storage)
    9709. 

  9709. #endif
    9710. 

  9710. /* used by STREAM, PATHNAME */
    9711. 

  9711. 

  9712. /* Macro: Wraps a GC-invariant uintB* pointer in a fake simple-8bit-vector.
    9713. 

  9713.  FAKE_8BIT_VECTOR(ptr)
    9714. 

  9714.  > uintB* ptr: pointer to GC-invariant data
    9715. 

  9715.  < gcv_object_t obj: a fake simple-8bit-vector,
    9716. 

  9716.                      with TheSbvector(obj)->data == ptr,
    9717. 

  9717.                      that must *not* be stored in GC-visible locations */
    9718. 

  9718. #ifdef TYPECODES
    9719. 

  9719.   #define FAKE_8BIT_VECTOR(ptr)  \
    9720. 

  9720.     type_pointer_object(0, (const char*)(ptr) - offsetofa(sbvector_,data))
    9721. 

  9721. #else
    9722. 

  9722.   #define FAKE_8BIT_VECTOR(ptr)  \
    9723. 

  9723.     fake_gcv_object((aint)((const char*)(ptr) - offsetofa(sbvector_,data)) + varobject_bias)
    9724. 

  9724. #endif
    9725. 

  9725. 

  9726. #if !defined(UNICODE) || defined(HAVE_SMALL_SSTRING)
    9727. 

  9727. /* UP, provides 8-bit character string
    9728. 

  9728.  allocate_s8string(len)
    9729. 

  9729.  > len: length of the string (in characters), must be <= stringsize_limit_1
    9730. 

  9730.  < result: new 8-bit character simple-string (LISP-object)
    9731. 

  9731.  can trigger GC */
    9732. 

  9732. extern maygc object allocate_s8string (uintL len);
    9733. 

  9733. /* used by */
    9734. 

  9734. #endif
    9735. 

  9735. #if defined(UNICODE) && !defined(HAVE_SMALL_SSTRING)
    9736. 

  9736. #define allocate_s8string(len)  allocate_s32string(len)
    9737. 

  9737. #endif
    9738. 

  9738. %% #if !defined(UNICODE)
    9739. 

  9739. %%   puts("extern object allocate_s8string (uintL len);");
    9740. 

  9740. %% #endif
    9741. 

  9741. 

  9742. #if !defined(UNICODE) || defined(HAVE_SMALL_SSTRING)
    9743. 

  9743. /* UP, provides immutable 8-bit character string
    9744. 

  9744.  allocate_imm_s8string(len)
    9745. 

  9745.  > len: length of the string (in characters), must be <= stringsize_limit_1
    9746. 

  9746.  < result: new immutable 8-bit character simple-string (LISP-object)
    9747. 

  9747.  can trigger GC */
    9748. 

  9748. extern maygc object allocate_imm_s8string (uintL len);
    9749. 

  9749. /* used by */
    9750. 

  9750. #endif
    9751. 

  9751. 

  9752. #ifdef HAVE_SMALL_SSTRING
    9753. 

  9753. /* UP, provides 16-bit character string
    9754. 

  9754.  allocate_s16string(len)
    9755. 

  9755.  > len: length of the string (in characters), must be <= stringsize_limit_1
    9756. 

  9756.  < result: new 16-bit character simple-string (LISP-object)
    9757. 

  9757.  can trigger GC */
    9758. 

  9758. extern maygc object allocate_s16string (uintL len);
    9759. 

  9759. /* used by */
    9760. 

  9760. #endif
    9761. 

  9761. #if defined(UNICODE) && !defined(HAVE_SMALL_SSTRING)
    9762. 

  9762. #define allocate_s16string(len)  allocate_s32string(len)
    9763. 

  9763. #endif
    9764. 

  9764. 

  9765. #ifdef HAVE_SMALL_SSTRING
    9766. 

  9766. /* UP, provides immutable 16-bit character string
    9767. 

  9767.  allocate_imm_s16string(len)
    9768. 

  9768.  > len: length of the string (in characters), must be <= stringsize_limit_1
    9769. 

  9769.  < result: new immutable 16-bit character simple-string (LISP-object)
    9770. 

  9770.  can trigger GC */
    9771. 

  9771. extern maygc object allocate_imm_s16string (uintL len);
    9772. 

  9772. /* used by */
    9773. 

  9773. #endif
    9774. 

  9774. 

  9775. #ifdef UNICODE
    9776. 

  9776. /* UP, provides 32-bit character string
    9777. 

  9777.  allocate_s32string(len)
    9778. 

  9778.  > len: length of the string (in characters), must be <= stringsize_limit_1
    9779. 

  9779.  < result: new 32-bit character simple-string (LISP-object)
    9780. 

  9780.  can trigger GC */
    9781. 

  9781. extern maygc object allocate_s32string (uintL len);
    9782. 

  9782. #endif
    9783. 

  9783. %% #ifdef UNICODE
    9784. 

  9784. %%   puts("extern object allocate_s32string (uintL len);");
    9785. 

  9785. %% #endif
    9786. 

  9786. 

  9787. #ifdef UNICODE
    9788. 

  9788. /* UP, provides immutable 32-bit character string
    9789. 

  9789.  allocate_imm_s32string(len)
    9790. 

  9790.  > len: length of the string (in characters), must be <= stringsize_limit_1
    9791. 

  9791.  < result: new immutable 32-bit character simple-string (LISP-object)
    9792. 

  9792.  can trigger GC */
    9793. 

  9793. extern maygc object allocate_imm_s32string (uintL len);
    9794. 

  9794. #endif
    9795. 

  9795. 

  9796. /* UP: allocates String
    9797. 

  9797.  allocate_string(len)
    9798. 

  9798.  > len: length of the Strings (in Characters), must be <= stringsize_limit_1
    9799. 

  9799.  < result: new Normal-Simple-String (LISP-object)
    9800. 

  9800.  can trigger GC */
    9801. 

  9801. #ifdef UNICODE
    9802. 

  9802.   #define allocate_string(len)  allocate_s32string(len)
    9803. 

  9803. #else
    9804. 

  9804.   #define allocate_string(len)  allocate_s8string(len)
    9805. 

  9805. #endif
    9806. 

  9806. /* is used by ARRAY, CHARSTRG, STREAM, PATHNAME */
    9807. 

  9807. %% export_def(allocate_string(len));
    9808. 

  9808. 

  9809. /* Macro: Allocates a normal string on the stack, with dynamic extent.
    9810. 

  9810.    { var DYNAMIC_STRING(obj,len);
    9811. 

  9811.      ...
    9812. 

  9812.      FREE_DYNAMIC_STRING(obj);
    9813. 

  9813.    }
    9814. 

  9814.  > uintL len: length (number of characters)
    9815. 

  9815.  < object obj: normal-simple-string with dynamic extent
    9816. 

  9816.    (may or may not be heap-allocated, therefore not GC-invariant)
    9817. 

  9817.  can trigger GC */
    9818. 

  9818. #if defined(SPVW_PURE) || ((((STACK_ADDRESS_RANGE << addr_shift) >> garcol_bit_o) & 1) != 0)
    9819. 

  9819.   /* No way to allocate a Lisp object on the stack. */
    9820. 

  9820.   #define DYNAMIC_STRING(objvar,len)  \
    9821. 

  9821.     var uintL objvar##_len = (len);           \
    9822. 

  9822.     var object objvar = O(dynamic_string);    \
    9823. 

  9823.     O(dynamic_string) = NIL;                  \
    9824. 

  9824.     if (!(simple_string_p(objvar) && (Sstring_length(objvar) >= objvar##_len))) { \
    9825. 

  9825.       if (objvar##_len > stringsize_limit_1)  \
    9826. 

  9826.         error_stringsize(objvar##_len);      \
    9827. 

  9827.       objvar = allocate_string(objvar##_len); \
    9828. 

  9828.     }                                         \
    9829. 

  9829.     GCTRIGGER1(objvar)
    9830. 

  9830.   #define FREE_DYNAMIC_STRING(objvar)  \
    9831. 

  9831.     O(dynamic_string) = objvar;
    9832. 

  9832. #else
    9833. 

  9833.   /* Careful: Fill GCself with pointers to itself, so that GC will leave
    9834. 

  9834.    pointers to this object untouched. */
    9835. 

  9835.   #ifdef UNICODE
    9836. 

  9836.     #define DYNAMIC_STRING(objvar,len)  \
    9837. 

  9837.       DYNAMIC_ARRAY(objvar##_storage,object,ceiling((uintL)(len)*sizeof(chart)+offsetofa(s32string_,data)+varobjects_misaligned,sizeof(gcv_object_t))); \
    9838. 

  9838.       var object* objvar##_address = (object*)((uintP)objvar##_storage | varobjects_misaligned); \
    9839. 

  9839.       var object objvar = ((Sstring)objvar##_address)->GCself = bias_type_pointer_object(varobject_bias,sstring_type,(Sstring)objvar##_address); \
    9840. 

  9840.       ((Sstring)objvar##_address)->tfl = sstring_tfl(Sstringtype_32Bit,0,0,len); \
    9841. 

  9841.       GCTRIGGER1(objvar)
    9842. 

  9842.   #else
    9843. 

  9843.     #define DYNAMIC_STRING(objvar,len)  \
    9844. 

  9844.       DYNAMIC_ARRAY(objvar##_storage,object,ceiling((uintL)(len)*sizeof(chart)+offsetofa(s8string_,data)+varobjects_misaligned,sizeof(gcv_object_t))); \
    9845. 

  9845.       var object* objvar##_address = (object*)((uintP)objvar##_storage | varobjects_misaligned); \
    9846. 

  9846.       var object objvar = ((Sstring)objvar##_address)->GCself = bias_type_pointer_object(varobject_bias,sstring_type,(Sstring)objvar##_address); \
    9847. 

  9847.       ((Sstring)objvar##_address)->tfl = sstring_tfl(Sstringtype_8Bit,0,0,len); \
    9848. 

  9848.       GCTRIGGER1(objvar)
    9849. 

  9849.   #endif
    9850. 

  9850.   #define FREE_DYNAMIC_STRING(objvar)  \
    9851. 

  9851.     FREE_DYNAMIC_ARRAY(objvar##_storage)
    9852. 

  9852. #endif
    9853. 

  9853. /* used by LISPARIT */
    9854. 

  9854. 

  9855. /* UP: allocates an immutable String
    9856. 

  9856.  allocate_imm_string(len)
    9857. 

  9857.  > len: length of the String (in Characters)
    9858. 

  9858.  < result: new immutable Normal-Simple-String (LISP-object)
    9859. 

  9859.  can trigger GC */
    9860. 

  9860. #ifdef UNICODE
    9861. 

  9861.   #define allocate_imm_string(len)  allocate_imm_s32string(len)
    9862. 

  9862. #else
    9863. 

  9863.   #define allocate_imm_string(len)  allocate_imm_s8string(len)
    9864. 

  9864. #endif
    9865. 

  9865. /* is used by CHARSTRG */
    9866. 

  9866. 

  9867. #ifdef HAVE_SMALL_SSTRING
    9868. 

  9868. /* UP: Changes the allocation of a Small-String to an Sistring, while
    9869. 

  9869.  copying the contents to a fresh normal string.
    9870. 

  9870.  reallocate_small_string(string)
    9871. 

  9871.  > string: a nonempty Small-String
    9872. 

  9872.  > newtype: new wider string type, Sstringtype_16Bit or Sstringtype_32Bit
    9873. 

  9873.  < result: an Sistring pointing to a wider String
    9874. 

  9874.  can trigger GC */
    9875. 

  9875.   extern maygc object reallocate_small_string (object string, uintB newtype);
    9876. 

  9876. /* is used by ARRAY */
    9877. 

  9877. #endif
    9878. 

  9878. 

  9879. /* Attempts to reallocate a simple-string, for debugging purposes.
    9880. 

  9880.  DBGREALLOC(string); */
    9881. 

  9881. #if defined(DEBUG_SMALL_SSTRING) && defined(HAVE_SMALL_SSTRING)
    9882. 

  9882.   #define DBGREALLOC(string)  \
    9883. 

  9883.     if (simple_string_p(string) && !sstring_reallocatedp(TheSstring(string)) \
    9884. 

  9884.         && !sstring_immutable(TheSstring(string))                            \
    9885. 

  9885.         && sstring_eltype(TheSstring(string)) != Sstringtype_32Bit           \
    9886. 

  9886.         && sstring_length(TheSstring(string)) > 0)                           \
    9887. 

  9887.       string = reallocate_small_string(string,sstring_eltype(TheSstring(string))+1)/*;*/
    9888. 

  9888. #else
    9889. 

  9889.   #define DBGREALLOC(string)  (void)0 /*nop*/
    9890. 

  9890. #endif
    9891. 

  9891. 

  9892. /* UP: allocates indirect array
    9893. 

  9893.  allocate_iarray(flags,rank,type)
    9894. 

  9894.  > uintB flags: Flags
    9895. 

  9895.  > uintC (actually uintWC) rank: rank
    9896. 

  9896.  > tint type: Typinfo
    9897. 

  9897.  < result: LISP-object Array
    9898. 

  9898.  can trigger GC */
    9899. 

  9899. extern maygc object allocate_iarray (uintB flags, uintC rank, tint type);
    9900. 

  9900. /* is used by ARRAY, IO */
    9901. 

  9901. 

  9902. /* UP: allocates Long-Record
    9903. 

  9903.  allocate_lrecord(rectype,reclen,type)
    9904. 

  9904.  > sintB rectype: further type-info
    9905. 

  9905.  > uintL reclen: length
    9906. 

  9906.  > tint type: type-info
    9907. 

  9907.  < result: LISP-object Record (elements are initialized with NIL)
    9908. 

  9908.  can trigger GC */
    9909. 

  9909. #ifdef TYPECODES
    9910. 

  9910.   extern maygc object allocate_lrecord (uintB rectype, uintL reclen, tint type);
    9911. 

  9911. #else
    9912. 

  9912.   #define allocate_lrecord(rectype,reclen,type)  /* ignore type */ \
    9913. 

  9913.     allocate_lrecord_(rectype,reclen)
    9914. 

  9914.   extern object allocate_lrecord_ (uintB rectype, uintL reclen);
    9915. 

  9915. #endif
    9916. 

  9916. /* is used by WEAK */
    9917. 

  9917. 

  9918. /* UP: allocates Simple-Record
    9919. 

  9919.  allocate_srecord(flags,rectype,reclen,type)
    9920. 

  9920.  > uintB flags: Flags
    9921. 

  9921.  > sintB rectype: further type-info
    9922. 

  9922.  > uintC (actually uintW) reclen: length
    9923. 

  9923.  > tint type: type-info
    9924. 

  9924.  < result: LISP-object Record (elements are initialized with NIL)
    9925. 

  9925.  can trigger GC */
    9926. 

  9926. #ifdef TYPECODES
    9927. 

  9927.   #define allocate_srecord(flags,rectype,reclen,type)  \
    9928. 

  9928.     allocate_srecord_(                                                     \
    9929. 

  9929.        (BIG_ENDIAN_P ? (uintW)(flags)+((uintW)(uintB)(rectype)<<intBsize)  \
    9930. 

  9930.                      : ((uintW)(flags)<<intBsize)+(uintW)(uintB)(rectype)),\
    9931. 

  9931.        reclen,                                                             \
    9932. 

  9932.        type)
    9933. 

  9933.   extern maygc object allocate_srecord_ (uintW flags_rectype, uintC reclen, tint type);
    9934. 

  9934. #else
    9935. 

  9935.   #define allocate_srecord(flags,rectype,reclen,type)  /* ignore type */ \
    9936. 

  9936.     allocate_srecord_(((uintW)(flags)<<8)+(uintW)(uintB)(rectype),reclen)
    9937. 

  9937.   extern maygc object allocate_srecord_ (uintW flags_rectype, uintC reclen);
    9938. 

  9938. #endif
    9939. 

  9939. /* is used by RECORD, EVAL */
    9940. 

  9940. 

  9941. /* UP: allocates Extended-Record
    9942. 

  9942.  allocate_xrecord(flags,rectype,reclen,recxlen,type)
    9943. 

  9943.  > uintB flags: Flags
    9944. 

  9944.  > sintB rectype: further type-info
    9945. 

  9945.  > uintC (actually uintB) reclen: length
    9946. 

  9946.  > uintC (actually uintB) recxlen: extra-length
    9947. 

  9947.  > tint type: Typinfo
    9948. 

  9948.  < result: LISP-object Record (elements are initialized with NIL resp. 0)
    9949. 

  9949.  can trigger GC */
    9950. 

  9950. #ifdef TYPECODES
    9951. 

  9951.   #define allocate_xrecord(flags,rectype,reclen,recxlen,type)  \
    9952. 

  9952.     allocate_xrecord_(                                                     \
    9953. 

  9953.        (BIG_ENDIAN_P ? (uintW)(flags)+((uintW)(uintB)(rectype)<<intBsize)  \
    9954. 

  9954.                      : ((uintW)(flags)<<intBsize)+(uintW)(uintB)(rectype)),\
    9955. 

  9955.        reclen,                                                             \
    9956. 

  9956.        recxlen,                                                            \
    9957. 

  9957.        type)
    9958. 

  9958.   extern maygc object allocate_xrecord_ (uintW flags_rectype, uintC reclen, uintC recxlen, tint type);
    9959. 

  9959. #else
    9960. 

  9960.   #define allocate_xrecord(flags,rectype,reclen,recxlen,type)  \
    9961. 

  9961.     allocate_xrecord_((((uintW)(flags)<<8)+(uintW)(uintB)(rectype)),reclen,recxlen)
    9962. 

  9962.   extern maygc object allocate_xrecord_ (uintW flags_rectype, uintC reclen, uintC recxlen);
    9963. 

  9963. #endif
    9964. 

  9964. /* is used by */
    9965. 

  9965. 

  9966. /* UP: allocates Closure
    9967. 

  9967.  allocate_closure(reclen)
    9968. 

  9968.  > uintC reclen: length
    9969. 

  9969.  < result: LISP-object Closure (elements are initialized with NIL) */
    9970. 

  9970. #define allocate_closure(reclen,flags)                               \
    9971. 

  9971.   allocate_srecord(flags,Rectype_Closure,reclen,closure_type)
    9972. 

  9972. /* is used by EVAL, RECORD */
    9973. 

  9973. 

  9974. /* copy a section of memory */
    9975. 

  9975. #define copy_mem_b(dest,orig,len) /* bytes */                   \
    9976. 

  9976.   do { var char* newptr = (char*)(dest);                        \
    9977. 

  9977.        var const char* oldptr = (const char*)(orig);            \
    9978. 

  9978.        var uintL count;                                         \
    9979. 

  9979.        var uintL leng = (len);                                  \
    9980. 

  9980.        dotimespL(count,leng,{ *newptr++ = *oldptr++; });        \
    9981. 

  9981.   } while(0)
    9982. 

  9982. #define copy_mem_o(dest,orig,len) /* objects */                  \
    9983. 

  9983.   do { var gcv_object_t* newptr = (dest);                \
    9984. 

  9984.        var const gcv_object_t* oldptr = (orig);          \
    9985. 

  9985.        var uintC count;                                  \
    9986. 

  9986.        var uintC leng = (len);                           \
    9987. 

  9987.        dotimespC(count,leng,{ *newptr++ = *oldptr++; }); \
    9988. 

  9988.   } while(0)
    9989. 

  9989. #if 0 /* the libc alternative turns out to be ~3-5% slower */
    9990. 

  9990. #define copy_mem_b(dest,orig,len)                       \
    9991. 

  9991.     do { begin_system_call(); memcpy(dest,orig,len);    \
    9992. 

  9992.          end_system_call(); } while(0)
    9993. 

  9993. #define copy_mem_o(dest,orig,len)                                           \
    9994. 

  9994.     do { begin_system_call(); memcpy(dest,orig,(len)*sizeof(gcv_object_t)); \
    9995. 

  9995.          end_system_call(); } while(0)
    9996. 

  9996. #endif
    9997. 

  9997. 

  9998. /* Copying a compiled closure:
    9999. 

  9999.  newclos = allocate_cclosure_copy(oldclos);
    10000. 

  10000.  can trigger GC */
    10001. 

  10001. #define allocate_cclosure_copy(oldclos)  \
    10002. 

  10002.   allocate_closure(Cclosure_length(oldclos),Closure_flags(oldclos))
    10003. 

  10003. /* do_cclosure_copy(newclos,oldclos); */
    10004. 

  10004. #define do_cclosure_copy(newclos,oldclos)               \
    10005. 

  10005.   copy_mem_o(((Srecord)TheCclosure(newclos))->recdata,  \
    10006. 

  10006.              ((Srecord)TheCclosure(oldclos))->recdata,  \
    10007. 

  10007.              Cclosure_length(oldclos))
    10008. 

  10008. /* is used by EVAL, IO, RECORD */
    10009. 

  10009. 

  10010. /* UP: allocates Structure
    10011. 

  10011.  allocate_structure(reclen)
    10012. 

  10012.  > uintC reclen: length
    10013. 

  10013.  < result: LISP-Object Structure (Elements are initialized with NIL)
    10014. 

  10014.  can trigger GC */
    10015. 

  10015. #ifdef case_structure
    10016. 

  10016.   #define allocate_structure(reclen)  \
    10017. 

  10017.     allocate_srecord(0,Rectype_Structure,reclen,structure_type)
    10018. 

  10018. #else
    10019. 

  10019.   #define allocate_structure(reclen)  \
    10020. 

  10020.     allocate_srecord(0,Rectype_Structure,reclen,orecord_type)
    10021. 

  10021. #endif
    10022. 

  10022. /* is used by RECORD */
    10023. 

  10023. 

  10024. /* UP: allocates Stream
    10025. 

  10025.  allocate_stream(strmflags,strmtype,reclen,recxlen)
    10026. 

  10026.  > uintB strmflags: Flags
    10027. 

  10027.  > uintB strmtype: further type-info
    10028. 

  10028.  > uintC reclen: length in objects
    10029. 

  10029.  > uintC recxlen: extra-length in bytes
    10030. 

  10030.  < result: LISP-object Stream (elements are initialized with NIL)
    10031. 

  10031.  can trigger GC */
    10032. 

  10032. #ifdef case_stream
    10033. 

  10033.   #define allocate_stream(strmflags,strmtype,reclen,recxlen)  \
    10034. 

  10034.     allocate_xrecord(strmflags | strmflags_open_B,strmtype,reclen,recxlen,stream_type)
    10035. 

  10035. #else
    10036. 

  10036.   extern maygc object allocate_stream (uintB strmflags, uintB strmtype, uintC reclen, uintC recxlen);
    10037. 

  10037. #endif
    10038. 

  10038. /* is used by STREAM */
    10039. 

  10039. 

  10040. /* UP: allocates Package
    10041. 

  10041.  allocate_package()
    10042. 

  10042.  < result: LISP-object Package
    10043. 

  10043.  can trigger GC */
    10044. 

  10044. #define allocate_package()  \
    10045. 

  10045.   allocate_xrecord(0,Rectype_Package,package_length,0,orecord_type)
    10046. 

  10046. /* is used by PACKAGE */
    10047. 

  10047. 

  10048. /* UP: allocates Hash-Table
    10049. 

  10049.  allocate_hash_table()
    10050. 

  10050.  < result: LISP-object Hash-Table
    10051. 

  10051.  can trigger GC */
    10052. 

  10052. #define allocate_hash_table()  \
    10053. 

  10053.   allocate_xrecord(0,Rectype_Hashtable,hashtable_length,hashtable_xlength, \
    10054. 

  10054.                    orecord_type)
    10055. 

  10055. /* is used by */
    10056. 

  10056. 

  10057. /* UP: allocates  Readtable
    10058. 

  10058.  allocate_readtable()
    10059. 

  10059.  < result: LISP-object Readtable
    10060. 

  10060.  can trigger GC */
    10061. 

  10061. #define allocate_readtable()  \
    10062. 

  10062.   allocate_xrecord(0,Rectype_Readtable,readtable_length,0,orecord_type)
    10063. 

  10063. /* is used by IO */
    10064. 

  10064. 

  10065. /* UP: allocates Pathname
    10066. 

  10066.  allocate_pathname()
    10067. 

  10067.  < result: LISP-object Pathname
    10068. 

  10068.  can trigger GC */
    10069. 

  10069. #define allocate_pathname()  \
    10070. 

  10070.   allocate_xrecord(0,Rectype_Pathname,pathname_length,0,orecord_type)
    10071. 

  10071. /* is used by PATHNAME */
    10072. 

  10072. 

  10073. #ifdef LOGICAL_PATHNAMES
    10074. 

  10074. /* UP: allocates Logical Pathname
    10075. 

  10075.  allocate_logpathname()
    10076. 

  10076.  < result: LISP-object Logical Pathname
    10077. 

  10077.  can trigger GC */
    10078. 

  10078. #define allocate_logpathname()  \
    10079. 

  10079.   allocate_xrecord(0,Rectype_Logpathname,logpathname_length,0,orecord_type)
    10080. 

  10080. /* is used by PATHNAME */
    10081. 

  10081. #endif
    10082. 

  10082. 

  10083. /* UP: allocates Random-State
    10084. 

  10084.  allocate_random_state()
    10085. 

  10085.  < result: LISP-object Random-State
    10086. 

  10086.  can trigger GC */
    10087. 

  10087. #define allocate_random_state()  \
    10088. 

  10088.   allocate_xrecord(0,Rectype_Random_State,random_state_length,0,orecord_type)
    10089. 

  10089. /* is used by IO, LISPARIT */
    10090. 

  10090. 

  10091. /* UP: allocates Byte
    10092. 

  10092.  allocate_byte()
    10093. 

  10093.  < result: LISP-object Byte
    10094. 

  10094.  can trigger GC */
    10095. 

  10095. #define allocate_byte()  \
    10096. 

  10096.   allocate_xrecord(0,Rectype_Byte,byte_length,0,orecord_type)
    10097. 

  10097. /* is used by LISPARIT */
    10098. 

  10098. 

  10099. /* UP: allocates Fsubr
    10100. 

  10100.  allocate_fsubr()
    10101. 

  10101.  < result: LISP-object Fsubr
    10102. 

  10102.  can trigger GC */
    10103. 

  10103. #define allocate_fsubr()  \
    10104. 

  10104.   allocate_xrecord(0,Rectype_Fsubr,fsubr_length,fsubr_xlength,orecord_type)
    10105. 

  10105. /* is used by SPVW */
    10106. 

  10106. 

  10107. /* UP: allocates Load-time-Eval
    10108. 

  10108.  allocate_loadtimeeval()
    10109. 

  10109.  < result: LISP-object Load-time-Eval
    10110. 

  10110.  can trigger GC */
    10111. 

  10111. #define allocate_loadtimeeval()  \
    10112. 

  10112.   allocate_xrecord(0,Rectype_Loadtimeeval,loadtimeeval_length,0,orecord_type)
    10113. 

  10113. /* is used by IO, RECORD */
    10114. 

  10114. 

  10115. /* UP: allocates Symbol-Macro
    10116. 

  10116.  allocate_symbolmacro()
    10117. 

  10117.  < result: LISP-object Symbol-Macro
    10118. 

  10118.  can trigger GC */
    10119. 

  10119. #define allocate_symbolmacro()  \
    10120. 

  10120.   allocate_xrecord(0,Rectype_Symbolmacro,symbolmacro_length,0,orecord_type)
    10121. 

  10121. /* is used by CONTROL, RECORD */
    10122. 

  10122. 

  10123. /* UP: allocates Global-Symbol-Macro
    10124. 

  10124.  allocate_globalsymbolmacro()
    10125. 

  10125.  < result: LISP-object Global-Symbol-Macro
    10126. 

  10126.  can trigger GC */
    10127. 

  10127. #define allocate_globalsymbolmacro()  \
    10128. 

  10128.   allocate_xrecord(0,Rectype_GlobalSymbolmacro,globalsymbolmacro_length,0,orecord_type)
    10129. 

  10129. /* is used by RECORD */
    10130. 

  10130. 

  10131. /* UP: allocates a Macro
    10132. 

  10132.  allocate_macro()
    10133. 

  10133.  < result: a fresh Macro
    10134. 

  10134.  can trigger GC */
    10135. 

  10135. #define allocate_macro()  \
    10136. 

  10136.   allocate_xrecord(0,Rectype_Macro,macro_length,0,orecord_type)
    10137. 

  10137. /* is used by RECORD */
    10138. 

  10138. 

  10139. /* UP: allocates a FunctionMacro
    10140. 

  10140.  allocate_functionmacro()
    10141. 

  10141.  < result: a fresh FunctionMacro
    10142. 

  10142.  can trigger GC */
    10143. 

  10143. #define allocate_functionmacro()  \
    10144. 

  10144.   allocate_xrecord(0,Rectype_FunctionMacro,functionmacro_length,0,orecord_type)
    10145. 

  10145. /* is used by RECORD */
    10146. 

  10146. 

  10147. /* UP: allocates a BigReadLabel
    10148. 

  10148.  allocate_big_read_label()
    10149. 

  10149.  < result: a fresh BigReadLabel
    10150. 

  10150.  can trigger GC */
    10151. 

  10151. #define allocate_big_read_label()  \
    10152. 

  10152.   allocate_xrecord(0,Rectype_BigReadLabel,bigreadlabel_length,0,orecord_type)
    10153. 

  10153. /* is used by IO */
    10154. 

  10154. 

  10155. /* UP: allocates an Encoding
    10156. 

  10156.  allocate_encoding()
    10157. 

  10157.  < result: a fresh Encoding
    10158. 

  10158.  can trigger GC */
    10159. 

  10159. #define allocate_encoding()  \
    10160. 

  10160.   allocate_xrecord(0,Rectype_Encoding,encoding_length,encoding_xlength,orecord_type)
    10161. 

  10161. /* is used by ENCODING */
    10162. 

  10162. 

  10163. #ifdef FOREIGN
    10164. 

  10164. /* UP: allocates a foreign-pointer packing
    10165. 

  10165.  allocate_fpointer(foreign)
    10166. 

  10166.  > foreign: of Type FOREIGN
    10167. 

  10167.  < result: LISP-object, contains the foreign pointer
    10168. 

  10168.  can trigger GC */
    10169. 

  10169.   extern maygc object allocate_fpointer (FOREIGN foreign);
    10170. 

  10170. /* used by FFI & modules */
    10171. 

  10171. #endif
    10172. 

  10172. %% #ifdef FOREIGN
    10173. 

  10173. %%   puts("extern object allocate_fpointer (FOREIGN foreign);");
    10174. 

  10174. %% #endif
    10175. 

  10175. 

  10176. /* UP: allocates foreign address
    10177. 

  10177.  allocate_faddress()
    10178. 

  10178.  < result: LISP-object foreign address
    10179. 

  10179.  can trigger GC */
    10180. 

  10180. #define allocate_faddress()  \
    10181. 

  10181.   allocate_xrecord(0,Rectype_Faddress,faddress_length,faddress_xlength,orecord_type)
    10182. 

  10182. /* is used by FOREIGN */
    10183. 

  10183. 

  10184. /* UP: allocates foreign variable
    10185. 

  10185.  allocate_fvariable()
    10186. 

  10186.  < result: LISP-object foreign variable
    10187. 

  10187.  can trigger GC */
    10188. 

  10188. #define allocate_fvariable()  \
    10189. 

  10189.   allocate_xrecord(0,Rectype_Fvariable,fvariable_length,0,orecord_type)
    10190. 

  10190. /* is used by FOREIGN */
    10191. 

  10191. 

  10192. /* UP: allocates foreign function
    10193. 

  10193.  allocate_ffunction()
    10194. 

  10194.  < result: LISP-object foreign function
    10195. 

  10195.  can trigger GC */
    10196. 

  10196. #define allocate_ffunction()  \
    10197. 

  10197.   allocate_xrecord(0,Rectype_Ffunction,ffunction_length,0,orecord_type)
    10198. 

  10198. /* is used by FOREIGN */
    10199. 

  10199. 

  10200. /* UP: allocates finalizer
    10201. 

  10201.  allocate_finalizer()
    10202. 

  10202.  < result: LISP-object finalizer
    10203. 

  10203.  can trigger GC */
    10204. 

  10204. #define allocate_finalizer()  \
    10205. 

  10205.   allocate_xrecord(0,Rectype_Finalizer,finalizer_length,0,orecord_type)
    10206. 

  10206. /* is used by RECORD */
    10207. 

  10207. 

  10208. /* UP: allocates Socket-Server
    10209. 

  10209.  allocate_socket_server()
    10210. 

  10210.  < result: LISP-object Socket-Server */
    10211. 

  10211. #ifdef SOCKET_STREAMS
    10212. 

  10212.   #define allocate_socket_server() \
    10213. 

  10213.     allocate_xrecord(0,Rectype_Socket_Server,socket_server_length,0,orecord_type)
    10214. 

  10214. #endif
    10215. 

  10215. 

  10216. #ifdef YET_ANOTHER_RECORD
    10217. 

  10217. /* UP: allocates Yetanother
    10218. 

  10218.  allocate_yetanother()
    10219. 

  10219.  < result: LISP-object Yetanother
    10220. 

  10220.  can trigger GC */
    10221. 

  10221.   #define allocate_yetanother()  \
    10222. 

  10222.     allocate_xrecord(0,Rectype_Yetanother,yetanother_length,0,orecord_type)
    10223. 

  10223. /* is used by */
    10224. 

  10224. #endif
    10225. 

  10225. 

  10226. /* UP: allocates handle
    10227. 

  10227.  allocate_handle(handle)
    10228. 

  10228.  < result: LISP-object, that contains handle
    10229. 

  10229.  can trigger GC */
    10230. 

  10230. #ifdef FOREIGN_HANDLE
    10231. 

  10231.   /* can trigger GC */
    10232. 

  10232.   extern maygc object allocate_handle (Handle handle);
    10233. 

  10233. #else
    10234. 

  10234.   #define allocate_handle(handle)  fixnum((uintL)(handle))
    10235. 

  10235. #endif
    10236. 

  10236. %% #if defined(FOREIGN_HANDLE)
    10237. 

  10237. %%   puts("extern object allocate_handle (Handle handle);");
    10238. 

  10238. %% #else
    10239. 

  10239. %%   export_def(allocate_handle(handle));
    10240. 

  10240. %% #endif
    10241. 

  10241. 

  10242. /* UP: allocates Bignum
    10243. 

  10243.  allocate_bignum(len,sign)
    10244. 

  10244.  > uintC (actually uintWC) len: length of the number (in Digits)
    10245. 

  10245.  > sintB sign: flag for sign (0 = +, -1 = -)
    10246. 

  10246.  < result: new Bignum (LISP-object)
    10247. 

  10247.  can trigger GC */
    10248. 

  10248. extern maygc object allocate_bignum (uintC len, sintB sign);
    10249. 

  10249. /* is used by LISPARIT, STREAM */
    10250. 

  10250. 

  10251. /* UP: allocates Single-Float
    10252. 

  10252.  allocate_ffloat(value)
    10253. 

  10253.  > ffloat value: value (Bit 31 = sign)
    10254. 

  10254.  < result: new Single-Float (LISP-object)
    10255. 

  10255.  can trigger GC */
    10256. 

  10256. extern maygc object allocate_ffloat (ffloat value);
    10257. 

  10257. /* is used by LISPARIT */
    10258. 

  10258. 

  10259. /* UP: allocates Double-Float */
    10260. 

  10260. #ifdef intQsize
    10261. 

  10261. /* allocate_dfloat(value)
    10262. 

  10262.  > dfloat value: value (Bit 63 = sign)
    10263. 

  10263.  < result: new Double-Float (LISP-object)
    10264. 

  10264.  can trigger GC */
    10265. 

  10265.   extern maygc object allocate_dfloat (dfloat value);
    10266. 

  10266. #else
    10267. 

  10267. /* allocate_dfloat(semhi,mlo)
    10268. 

  10268.  > semhi,mlo: value (Bit 31 of semhi = sign )
    10269. 

  10269.  < result: new Double-Float (LISP-object)
    10270. 

  10270.  can trigger GC */
    10271. 

  10271.   extern maygc object allocate_dfloat (uint32 semhi, uint32 mlo);
    10272. 

  10272. #endif
    10273. 

  10273. /* is used by LISPARIT */
    10274. 

  10274. 

  10275. /* UP: allocates Long-Float
    10276. 

  10276.  allocate_lfloat(len,expo,sign)
    10277. 

  10277.  > uintC (actually uintWC) len: length of the mantissa (in Digits)
    10278. 

  10278.  > uintL expo: exponent
    10279. 

  10279.  > signean sign: sign (0 = +, -1 = -)
    10280. 

  10280.  < result: new Long-Float, without mantissa
    10281. 

  10281.  It will only be a LISP-object when the mantissa has been entered!
    10282. 

  10282.  can trigger GC */
    10283. 

  10283. extern maygc object allocate_lfloat (uintC len, uintL expo, signean sign);
    10284. 

  10284. /* is used by LISPARIT */
    10285. 

  10285. 

  10286. /* UP: makes a rational number
    10287. 

  10287.  make_ratio(num,den)
    10288. 

  10288.  > object num: numerator (has to be an integer /= 0, relatively prime to den)
    10289. 

  10289.  > object den: denominator (has to be an Integer > 1)
    10290. 

  10290.  < result: rational number
    10291. 

  10291.  can trigger GC */
    10292. 

  10292. extern maygc object make_ratio (object num, object den);
    10293. 

  10293. /* is used by LISPARIT */
    10294. 

  10294. 

  10295. /* UP: makes a complex number
    10296. 

  10296.  make_complex(real,imag)
    10297. 

  10297.  > real: real part (has to be a real number)
    10298. 

  10298.  > imag: imaginary part (has to be a real number /= Fixnum 0)
    10299. 

  10299.  < result: complex number
    10300. 

  10300.  can trigger GC */
    10301. 

  10301. extern maygc object make_complex (object real, object imag);
    10302. 

  10302. /* is used by LISPARIT */
    10303. 

  10303. 

  10304. #ifdef MULTITHREAD
    10305. 

  10305. /* allocate a thread object
    10306. 

  10306.  allocate_thread()
    10307. 

  10307.  > *name_ : thread name (usually a symbol)
    10308. 

  10308.  < result : new thread object (not started)
    10309. 

  10309.  can trigger GC */
    10310. 

  10310. global maygc object allocate_thread (gcv_object_t *name_);
    10311. 

  10311. /* used by ZTHREAD */
    10312. 

  10312. 

  10313. /* allocate a mutex object
    10314. 

  10314.  allocate_mutex()
    10315. 

  10315.  > *name_ : mutex name (usually a symbol)
    10316. 

  10316.  < result : new mutex object (initialized)
    10317. 

  10317.  can trigger GC */
    10318. 

  10318. global maygc object allocate_mutex (gcv_object_t *name_);
    10319. 

  10319. /* used by ZTHREAD */
    10320. 

  10320. 

  10321. /* allocate an exemption object
    10322. 

  10322.  allocate_exemption()
    10323. 

  10323.  > *name_ : exemption name (usually a symbol)
    10324. 

  10324.  < result : new exemption object (initialized)
    10325. 

  10325.  can trigger GC */
    10326. 

  10326. global maygc object allocate_exemption (gcv_object_t *name_);
    10327. 

  10327. /* used by ZTHREAD */
    10328. 

  10328. #endif
    10329. 

  10329. 

  10330. /* Adds a freshly allocated object to the list of weak pointers.
    10331. 

  10331.  activate_weak(obj);
    10332. 

  10332.  > obj: A fresh but filled object of type Rectype_Weak* */
    10333. 

  10333. extern void activate_weak (object obj);
    10334. 

  10334. /* is used by WEAK */
    10335. 

  10335. 

  10336. /* UP: return the length of the ASCIZ-String
    10337. 

  10337.  asciz_length(asciz)
    10338. 

  10338.  > char* asciz: ASCIZ-String
    10339. 

  10339.        (added with a NULL byte determines the end of string)
    10340. 

  10340.  < result: Length of the character sequence (without the NULL byte) */
    10341. 

  10341. extern uintL asciz_length (const char * asciz);
    10342. 

  10342. #if defined(GNU) && (SAFETY < 2)
    10343. 

  10343.   #ifdef HAVE_BUILTIN_STRLEN
    10344. 

  10344.     #define asciz_length(a)  ((uintL)__builtin_strlen(a))
    10345. 

  10345.   #endif
    10346. 

  10346. #endif
    10347. 

  10347. #ifndef asciz_length
    10348. 

  10348.   #ifdef HAVE_SAVED_STACK
    10349. 

  10349.     /* can not use strlen() instead of asciz_length() , because this would
    10350. 

  10350.      require a begin_system_call()/end_system_call() . */
    10351. 

  10351.   #else
    10352. 

  10352.     /* let us presume, that strlen() is implemented efficiently. */
    10353. 

  10353.     #ifdef STDC_HEADERS
    10354. 

  10354.       #include <string.h> /* declares strlen() */
    10355. 

  10355.     #endif
    10356. 

  10356.     #define asciz_length(a)  ((uintL)strlen(a))
    10357. 

  10357.   #endif
    10358. 

  10358. #endif
    10359. 

  10359. /* is used by SPVW */
    10360. 

  10360. %% #ifdef asciz_length
    10361. 

  10361. %%   export_def(asciz_length(a));
    10362. 

  10362. %% #else
    10363. 

  10363. %%   puts("extern uintL asciz_length (const char * asciz);");
    10364. 

  10364. %% #endif
    10365. 

  10365. 

  10366. /* UP: Compares two ASCIZ-Strings.
    10367. 

  10367.  asciz_equal(asciz1,asciz2)
    10368. 

  10368.  > char* asciz1: first ASCIZ-String
    10369. 

  10369.  > char* asciz2: second ASCIZ-String
    10370. 

  10370.  < result: true if the number-sequences are equal */
    10371. 

  10371. extern bool asciz_equal (const char * asciz1, const char * asciz2);
    10372. 

  10372. /* is used by STREAM */
    10373. 

  10373. %% #if notused
    10374. 

  10374. %% #ifdef asciz_length
    10375. 

  10375. %%   export_def(asciz_equal(a1,a2));
    10376. 

  10376. %% #else
    10377. 

  10377. %%   puts("extern bool asciz_equal (const char * asciz1, const char * asciz2);");
    10378. 

  10378. %% #endif
    10379. 

  10379. %% #endif
    10380. 

  10380. 

  10381. /* allocate memory and check for success */
    10382. 

  10382. extern void* my_malloc (size_t size);
    10383. 

  10383. /* used by FOREIGN and modules */
    10384. 

  10384. %% puts("extern void* my_malloc (size_t size);");
    10385. 

  10385. 

  10386. /* reallocate memory and check for success */
    10387. 

  10387. extern void* my_realloc (void* ptr, size_t size);
    10388. 

  10388. /* used by modules */
    10389. 

  10389. %% puts("extern void* my_realloc (void *ptr, size_t size);");
    10390. 

  10390. 

  10391. /* UP: Returns a Table of all circularities within an Object.
    10392. 

  10392.  (A circularity is a Sub-Object contained within this Object,
    10393. 

  10393.  which has more than one access-path to it.)
    10394. 

  10394.  get_circularities(obj,pr_array,pr_closure)
    10395. 

  10395.  > object obj: Object
    10396. 

  10396.  > bool pr_array: Flag, if Array-Elements recursively count as Sub-Objects
    10397. 

  10397.  > bool pr_closure: Flag, if Closure-Components recursively count as Sub-Objects
    10398. 

  10398.  < result: T if Stack-Overflow occurred,
    10399. 

  10399.              NIL if no circularities available,
    10400. 

  10400.              #(0 ...) an (n+1)-element Vector, that contains the number 0 and the n
    10401. 

  10401.                       circularities as Elements, n>0.
    10402. 

  10402.  can trigger GC */
    10403. 

  10403. extern maygc object get_circularities (object obj, bool pr_array, bool pr_closure);
    10404. 

  10404. /* is used by IO */
    10405. 

  10405. 

  10406. /* UP: unentangles #n# - References in Object *ptr with help from Aliste alist.
    10407. 

  10407.  > *ptr : Object
    10408. 

  10408.  > alist : Alist (Read-Label --> Object, to be substituted)
    10409. 

  10409.  < *ptr : Object with unentangled References
    10410. 

  10410.  < result : erroneous Reference or nullobj if everything is OK */
    10411. 

  10411. extern object subst_circ (gcv_object_t* ptr, object alist);
    10412. 

  10412. /* is used by IO */
    10413. 

  10413. 

  10414. /* UP: Runs through the whole memory, and calls for each
    10415. 

  10415.  Object obj: fun(arg,obj,bytelen) .
    10416. 

  10416.  map_heap_objects(fun,arg);
    10417. 

  10417.  > fun: C-Function
    10418. 

  10418.  > arg: arbitrary given Argument */
    10419. 

  10419. typedef void map_heap_function_t (void* arg, object obj, uintM bytelen);
    10420. 

  10420. extern void map_heap_objects (map_heap_function_t* fun, void* arg);
    10421. 

  10421. /* is used by PREDTYPE */
    10422. 

  10422. 

  10423. /* UP: returns the size (in Bytes) of an object.
    10424. 

  10424.  varobject_bytelength(obj)
    10425. 

  10425.  > obj: Heap-object with variable length
    10426. 

  10426.  < result; the number of bytes occupied by it (header included) */
    10427. 

  10427. extern uintM varobject_bytelength (object obj);
    10428. 

  10428. /* is used by PREDTYPE */
    10429. 

  10429. 

  10430. /* Break-Semaphores
    10431. 

  10431.  As long as a Break-Semaphore is set, the Lisp-Program can not
    10432. 

  10432.  be interrupted. Purpose:
    10433. 

  10433.  - backup of Consistencies,
    10434. 

  10434.  - Non-reentrant Data-Structures (like e.g. DTA_buffer) can not
    10435. 

  10435.    be used recursively. */
    10436. 

  10436. typedef union {uintB einzeln[8]; uintL gesamt[2]; } break_sems_;
    10437. 

  10437. extern break_sems_ break_sems;
    10438. 

  10438. #define break_sem_0  break_sems.einzeln[0]
    10439. 

  10439. #define break_sem_1  break_sems.einzeln[1]
    10440. 

  10440. #define break_sem_2  break_sems.einzeln[2]
    10441. 

  10441. #define break_sem_3  break_sems.einzeln[3]
    10442. 

  10442. #define break_sem_4  break_sems.einzeln[4]
    10443. 

  10443. #define break_sem_5  break_sems.einzeln[5]
    10444. 

  10444. #define break_sem_6  break_sems.einzeln[6]
    10445. 

  10445. #define break_sem_7  break_sems.einzeln[7]
    10446. 

  10446. /* is used by SPVW, Macros set/clr_break_sem_0/1/2/3/4/5/6/7 */
    10447. 

  10447. 

  10448. /* Tests whether all break-semaphores have been cleared. */
    10449. 

  10449. #define break_sems_cleared()  \
    10450. 

  10450.   (break_sems.gesamt[0] == 0 && break_sems.gesamt[1] == 0)
    10451. 

  10451. /* is used by SPVW, WIN32AUX */
    10452. 

  10452. 

  10453. /* clears all break-semaphores. Very dangerous! */
    10454. 

  10454. #define clear_break_sems()  \
    10455. 

  10455.   (break_sems.gesamt[0] = 0, break_sems.gesamt[1] = 0)
    10456. 

  10456. /* is used by SPVW */
    10457. 

  10457. 

  10458. /* sets break-semaphore 0 and thus protects against interrupts
    10459. 

  10459.  set_break_sem_0(); */
    10460. 

  10460. #define set_break_sem_0()  (break_sem_0 = 1)
    10461. 

  10461. /* is used by SPVW */
    10462. 

  10462. 

  10463. /* clears the break-semaphore 0 and thus releases the interrupts
    10464. 

  10464.  clr_break_sem_0(); */
    10465. 

  10465. #define clr_break_sem_0()  (break_sem_0 = 0)
    10466. 

  10466. /* is used by SPVW */
    10467. 

  10467. 

  10468. /* sets break-semaphore 1 and thus protects against interrupts
    10469. 

  10469.  set_break_sem_1(); */
    10470. 

  10470. #define set_break_sem_1()  (break_sem_1 = 1)
    10471. 

  10471. /* is used by SPVW, ARRAY */
    10472. 

  10472. 

  10473. /* clears the break-semaphore 1 and thus releases the interrupts
    10474. 

  10474.  clr_break_sem_1(); */
    10475. 

  10475. #define clr_break_sem_1()  (break_sem_1 = 0)
    10476. 

  10476. /* is used by SPVW, ARRAY */
    10477. 

  10477. 

  10478. /* sets break-semaphore 2 and thus protects against interrupts
    10479. 

  10479.  set_break_sem_2(); */
    10480. 

  10480. #define set_break_sem_2()  (break_sem_2 = 1)
    10481. 

  10481. /* is used by PACKAGE, HASHTABL */
    10482. 

  10482. 

  10483. /* clears the break-semaphore 2 and thus releases the interrupts
    10484. 

  10484.  clr_break_sem_2(); */
    10485. 

  10485. #define clr_break_sem_2()  (break_sem_2 = 0)
    10486. 

  10486. /* is used by PACKAGE, HASHTABL */
    10487. 

  10487. 

  10488. /* sets break-semaphore 3 and thus protects against interrupts
    10489. 

  10489.  set_break_sem_3(); */
    10490. 

  10490. #define set_break_sem_3()  (break_sem_3 = 1)
    10491. 

  10491. /* is used by PACKAGE */
    10492. 

  10492. 

  10493. /* clears the break-semaphore 3 and thus releases the interrupts
    10494. 

  10494.  clr_break_sem_3(); */
    10495. 

  10495. #define clr_break_sem_3()  (break_sem_3 = 0)
    10496. 

  10496. /* is used by PACKAGE */
    10497. 

  10497. 

  10498. /* sets break-semaphore 4 and thus protects against interrupts
    10499. 

  10499.  set_break_sem_4(); */
    10500. 

  10500. #define set_break_sem_4()  (break_sem_4 = 1)
    10501. 

  10501. /* is used by STREAM, PATHNAME */
    10502. 

  10502. 

  10503. /* clears the break-semaphore 4 and thus releases the interrupts
    10504. 

  10504.  clr_break_sem_4(); */
    10505. 

  10505. #define clr_break_sem_4()  (break_sem_4 = 0)
    10506. 

  10506. /* is used by STREAM, PATHNAME */
    10507. 

  10507. 

  10508. /* increments break-semaphore 5 and thus protects against interrupts
    10509. 

  10509.  inc_break_sem_5(); */
    10510. 

  10510. #define inc_break_sem_5()  (break_sem_5++)
    10511. 

  10511. /* is used by SPVW */
    10512. 

  10512. 

  10513. /* decrements break-semaphore 5 and thus releases interrupts
    10514. 

  10514.  dec_break_sem_5(); */
    10515. 

  10515. #define dec_break_sem_5()  (break_sem_5--)
    10516. 

  10516. /* is used by SPVW */
    10517. 

  10517. 

  10518. /* clears the break-semaphore 5 and thus releases the interrupts
    10519. 

  10519.  clr_break_sem_5(); */
    10520. 

  10520. #define clr_break_sem_5()  (break_sem_5 = 0)
    10521. 

  10521. /* is used by SPVW */
    10522. 

  10522. 

  10523. /* Flag, whether SYS::READ-FORM should behave compatible to ILISP */
    10524. 

  10524. extern bool ilisp_mode;
    10525. 

  10525. 

  10526. /* returns the amount of space occupied by static LISP-objects */
    10527. 

  10527. extern uintM static_space (void);
    10528. 

  10528. /* is used by DEBUG */
    10529. 

  10529. 

  10530. /* returns the amount of space occupied by LISP-objects */
    10531. 

  10531. extern uintM used_space (void);
    10532. 

  10532. /* is used by TIME, DEBUG */
    10533. 

  10533. 

  10534. /* returns the amount of space still available for LISP-objects */
    10535. 

  10535. extern uintM free_space (void);
    10536. 

  10536. /* is used by DEBUG */
    10537. 

  10537. 

  10538. /* UP: saves memory image to disc
    10539. 

  10539.  savemem(stream);
    10540. 

  10540.  > object stream: open File-Output-Stream, will be closed
    10541. 

  10541.  > bool exec_p: should the result include runtime?
    10542. 

  10542.  < file length
    10543. 

  10543.  can trigger GC */
    10544. 

  10544. extern maygc off_t savemem (object stream, bool exec_p);
    10545. 

  10545. /* used by PATHNAME */
    10546. 

  10546. 

  10547. #ifdef HAVE_SIGNALS
    10548. 

  10548. /* Temporarily do not ignore the status of subprocesses. */
    10549. 

  10549.   extern void begin_want_sigcld (void);
    10550. 

  10550.   extern void end_want_sigcld (void);
    10551. 

  10551. /* is used by PATHNAME */
    10552. 

  10552. #endif
    10553. 

  10553. 

  10554. #if defined(HAVE_SIGNALS) && defined(SIGPIPE)
    10555. 

  10555.   /* Set ONLY during write() calls to pipes directed to subprocesses. */
    10556. 

  10556. extern bool writing_to_subprocess;
    10557. 

  10557. #endif
    10558. 

  10558. 

  10559. 

  10560. /* Declaration of the FSUBRs.
    10561. 

  10561.  As C-functions: C_name, of the type fsubr_function_t (no arguments, no value) */
    10562. 

  10562. 

  10563. /* make C-functions visible: */
    10564. 

  10564. #define LISPSPECFORM  LISPSPECFORM_A
    10565. 

  10565. #include "fsubr.c"
    10566. 

  10566. #undef LISPSPECFORM
    10567. 

  10567. /* is used by */
    10568. 

  10568. 

  10569. /* make Fsubr-table visible: */
    10570. 

  10570. #define LISPSPECFORM  LISPSPECFORM_C
    10571. 

  10571. struct fsubr_tab_ {
    10572. 

  10572.   #include "fsubr.c"
    10573. 

  10573. };
    10574. 

  10574. #undef LISPSPECFORM
    10575. 

  10575. extern const struct fsubr_tab_ fsubr_tab;
    10576. 

  10576. /* is used by CONTROL, SPVW */
    10577. 

  10577. 

  10578. 

  10579. /* Declaration of the SUBR-table:
    10580. 

  10580.  As C-functions: C_name
    10581. 

  10581.  of the type subr_norest_function_t (no arguments, no value)
    10582. 

  10582.  resp. subr_rest_function_t (two arguments, no value): */
    10583. 

  10583. typedef Values subr_norest_function_t (void);
    10584. 

  10584. typedef Values subr_rest_function_t (uintC argcount, gcv_object_t* rest_args_pointer);
    10585. 

  10585. %% #if notused
    10586. 

  10586. %% emit_typedef_f("Values %s(void)","subr_norest_function_t");
    10587. 

  10587. %% emit_typedef_f("Values %s(uintC argcount, object* rest_args_pointer)","subr_rest_function_t");
    10588. 

  10588. %% #endif
    10589. 

  10589. 

  10590. /* As LISP-Subr:    L(name) */
    10591. 

  10591. 

  10592. /* Make C-functions visible: */
    10593. 

  10593. #define LISPFUN  LISPFUN_A
    10594. 

  10594. #include "subr.c"
    10595. 

  10595. #undef LISPFUN
    10596. 

  10596. /* is used by */
    10597. 

  10597. 

  10598. /* Make Subr-tables visible: */
    10599. 

  10599. #define LISPFUN  LISPFUN_C
    10600. 

  10600. extern struct subr_tab_ {
    10601. 

  10601.   VAROBJECTS_ALIGNMENT_DUMMY_DECL
    10602. 

  10602.   #include "subr.c"
    10603. 

  10603. } subr_tab_data;
    10604. 

  10604. #undef LISPFUN
    10605. 

  10605. /* is used by Macro L */
    10606. 

  10606. %% puts("extern struct subr_tab_ {");
    10607. 

  10607. %% puts("  VAROBJECTS_ALIGNMENT_DUMMY_DECL");
    10608. 

  10608. %% #undef LISPFUN
    10609. 

  10609. %% #define LISPFUN(name,sec,req_count,opt_count,rest_flag,key_flag,key_count,keywords) \
    10610. 

  10610. %%   printf("  subr_t %s;\n",STRING(D_##name));
    10611. 

  10611. %% #include "subr.c"
    10612. 

  10612. %% #undef LISPFUN
    10613. 

  10613. %% puts("} subr_tab_data;");
    10614. 

  10614. 

  10615. /* Abbreviation for LISP-Subr with a given name: L(name) */
    10616. 

  10616. #if !defined(MAP_MEMORY_TABLES)
    10617. 

  10617.   #define subr_tab  subr_tab_data
    10618. 

  10618.   #ifdef TYPECODES
    10619. 

  10619.     #define subr_tab_ptr_as_object(subr_addr)  (type_constpointer_object(subr_type,subr_addr))
    10620. 

  10620.   #else
    10621. 

  10621.     #if defined(WIDE_AUXI)
    10622. 

  10622.       #define subr_tab_ptr_as_object(subr_addr)  as_object_with_auxi((aint)(subr_addr)+subr_bias)
    10623. 

  10623.     #elif defined(OBJECT_STRUCT)
    10624. 

  10624.       #define subr_tab_ptr_as_object(subr_addr)  as_object((oint)(subr_addr)+subr_bias)
    10625. 

  10625.     #else
    10626. 

  10626.       #define subr_tab_ptr_as_object(subr_addr)  objectplus(subr_addr,subr_bias)
    10627. 

  10627.     #endif
    10628. 

  10628.   #endif
    10629. 

  10629.   #define L_help_(name)  subr_tab_ptr_as_object(&subr_tab.name)
    10630. 

  10630. #else
    10631. 

  10631.   /* define subr_tab_addr  ((struct subr_tab_ *)type_constpointer_object(subr_type,0)) */
    10632. 

  10632.   #define subr_tab_addr  ((struct subr_tab_ *)type_zero_oint(subr_type))
    10633. 

  10633.   #define subr_tab  (*subr_tab_addr)
    10634. 

  10634.   #define subr_tab_ptr_as_object(subr_addr)  (as_object((oint)(subr_addr)))
    10635. 

  10635.   #define L_help_(name)  subr_tab_ptr_as_object(&subr_tab_addr->name)
    10636. 

  10636. #endif
    10637. 

  10637. #define L(name)  L_help_(D_##name)
    10638. 

  10638. /* is used by all modules */
    10639. 

  10639. %% #if defined(MAP_MEMORY_TABLES)
    10640. 

  10640. %%   export_def(subr_tab_addr);
    10641. 

  10641. %% #endif
    10642. 

  10642. %% export_def(subr_tab);
    10643. 

  10643. %% export_def(subr_tab_ptr_as_object(subr_addr));
    10644. 

  10644. %% export_def(L_help_(name));
    10645. 

  10645. %% emit_define("L(name)","L_help_(D_##name)");
    10646. 

  10646. 

  10647. 

  10648. /* Pseudofunctions are addresses of C functions (to be called directly, not via
    10649. 

  10649.  FUNCALL) or constant C data.
    10650. 

  10650.  For SAVEMEM/LOADMEM we have a table of all such pseudofunctions. */
    10651. 

  10651. typedef const void *  Pseudofun; /* assume function pointers fit in a void* */
    10652. 

  10652. %% puts("typedef const void *  Pseudofun;");
    10653. 

  10653. 

  10654. /* Declaration of the tables of relocatable pointers: */
    10655. 

  10655. #define PSEUDO  PSEUDO_A
    10656. 

  10656. extern struct pseudocode_tab_ {
    10657. 

  10657.   #include "pseudofun.c"
    10658. 

  10658. } pseudocode_tab;
    10659. 

  10659. #undef PSEUDO
    10660. 

  10660. #define PSEUDO  PSEUDO_B
    10661. 

  10661. extern struct pseudodata_tab_ {
    10662. 

  10662.   #include "pseudofun.c"
    10663. 

  10663.   #if defined(MICROSOFT) && !defined(UNICODE)
    10664. 

  10664.   Pseudofun dummy_pseudofun;
    10665. 

  10665.   #endif
    10666. 

  10666. } pseudodata_tab;
    10667. 

  10667. #undef PSEUDO
    10668. 

  10668. /* is used by STREAM, SPVW */
    10669. 

  10669. 

  10670. /* Declaration of the functions that can be stored in Lisp objects. */
    10671. 

  10671. #define PSEUDO  PSEUDO_C
    10672. 

  10672. #include "pseudofun.c"
    10673. 

  10673. #undef PSEUDO
    10674. 

  10674. /* is used by STREAM, and to avoid gcc -Wmissing-declarations warnings */
    10675. 

  10675. 

  10676. /* Return an ADDRESS object encapsulating a pseudofunction. */
    10677. 

  10677. #ifdef TYPECODES
    10678. 

  10678.   #define P(fun)  type_constpointer_object(machine_type,(Pseudofun)&(fun))
    10679. 

  10679. #else
    10680. 

  10680.   #define P(fun)  make_machine_code((Pseudofun)&(fun))
    10681. 

  10681. #endif
    10682. 

  10682. /* is used by STREAM, ENCODING */
    10683. 

  10683. 

  10684. 

  10685. /* Declaration if the Symbol-table: */
    10686. 

  10686. #define LISPSYM  LISPSYM_A
    10687. 

  10687. extern struct symbol_tab_ {
    10688. 

  10688.   VAROBJECTS_ALIGNMENT_DUMMY_DECL
    10689. 

  10689.   #include "constsym.c"
    10690. 

  10690. } symbol_tab_data;
    10691. 

  10691. #undef LISPSYM
    10692. 

  10692. /* is used by Macro S, gcinvariant_symbol_p */
    10693. 

  10693. %% puts("extern struct symbol_tab_ {");
    10694. 

  10694. %% puts("  VAROBJECTS_ALIGNMENT_DUMMY_DECL");
    10695. 

  10695. %% #define LISPSYM(name,printname,package)  \
    10696. 

  10696. %%   printf("  symbol_ %s;\n",STRING(S_##name));
    10697. 

  10697. %% #include "constsym.c"
    10698. 

  10698. %% #undef LISPSYM
    10699. 

  10699. %% puts("} symbol_tab_data;");
    10700. 

  10700. 

  10701. /* Abbreviation for LISP-Symbol with a given name: S(name) */
    10702. 

  10702. #define S(name)  S_help_(S_##name)
    10703. 

  10703. #if !defined(MAP_MEMORY_TABLES)
    10704. 

  10704.   #define symbol_tab  symbol_tab_data
    10705. 

  10705.   #ifdef TYPECODES
    10706. 

  10706.     #define S_help_(name)  (type_constpointer_object(symbol_type,&symbol_tab.name))
    10707. 

  10707.   #else
    10708. 

  10708.     #if defined(WIDE_AUXI)
    10709. 

  10709.       #define S_help_(name)  as_object_with_auxi((aint)&symbol_tab.name+varobject_bias)
    10710. 

  10710.     #elif defined(OBJECT_STRUCT)
    10711. 

  10711.       #define S_help_(name)  as_object((oint)&symbol_tab.name+varobject_bias)
    10712. 

  10712.     #else
    10713. 

  10713.       #define S_help_(name)  objectplus(&symbol_tab.name,varobject_bias)
    10714. 

  10714.     #endif
    10715. 

  10715.   #endif
    10716. 

  10716. #else
    10717. 

  10717.   /* define symbol_tab_addr ((struct symbol_tab_ *)type_constpointer_object(symbol_type,0)) */
    10718. 

  10718.   #define symbol_tab_addr ((struct symbol_tab_ *)type_zero_oint(symbol_type))
    10719. 

  10719.   #define symbol_tab  (*symbol_tab_addr)
    10720. 

  10720.   #define S_help_(name)  (as_object((oint)(&symbol_tab_addr->name)))
    10721. 

  10721.   #if 0 /* Some compilers do not allow the above expression */
    10722. 

  10722.         /* - even though it's a 'constant expression' -
    10723. 

  10723.          as initializer of static variables.
    10724. 

  10724.          We have to assist: */
    10725. 

  10725.     #undef S_help_
    10726. 

  10726.     #define S_help_(name)  (as_object( (char*)(&((struct symbol_tab_ *)0)->name) + (uintP)symbol_tab_addr ))
    10727. 

  10727.   #endif
    10728. 

  10728. #endif
    10729. 

  10729. /* is used by all modules */
    10730. 

  10730. %% emit_define("S(name)","S_help_(S_##name)");
    10731. 

  10731. %% #if defined(MAP_MEMORY_TABLES)
    10732. 

  10732. %%   export_def(symbol_tab_addr);
    10733. 

  10733. %% #endif
    10734. 

  10734. %% export_def(symbol_tab);
    10735. 

  10735. %% export_def(S_help_(name));
    10736. 

  10736. 

  10737. #define NIL  S(nil)
    10738. 

  10738. #define T    S(t)
    10739. 

  10739. %% export_def(NIL);
    10740. 

  10740. %% export_def(T);
    10741. 

  10741. 

  10742. #if defined(DEBUG_GCSAFETY)
    10743. 

  10743. /* gcinvariant_symbol_p(obj)
    10744. 

  10744.  > obj: an object
    10745. 

  10745.  < result: true if obj is a symbol in symbol_tab */
    10746. 

  10746. static inline bool gcinvariant_symbol_p (object obj) {
    10747. 

  10747.   if (
    10748. 

  10748.       #ifdef TYPECODES
    10749. 

  10749.         symbolp(obj)
    10750. 

  10750.       #else
    10751. 

  10751.         varobjectp(obj)
    10752. 

  10752.       #endif
    10753. 

  10753.       &&
    10754. 

  10754.       (
    10755. 

  10755.        #if !defined(MAP_MEMORY_TABLES)
    10756. 

  10756.          #ifdef TYPECODES
    10757. 

  10757.            (as_oint(obj) >> (oint_addr_shift-addr_shift)) - ((aint)(tint)symbol_type<<oint_type_shift)
    10758. 

  10758.          #else
    10759. 

  10759.            as_oint(obj) - varobject_bias
    10760. 

  10760.          #endif
    10761. 

  10761.        #else
    10762. 

  10762.          /* FIXME: MAP_MEMORY_TABLES possibly uses MULTIMAP_MEMORY_SYMBOL_TAB. */
    10763. 

  10763.          as_oint(obj)
    10764. 

  10764.        #endif
    10765. 

  10765.        - (aint)&symbol_tab < sizeof(symbol_tab))
    10766. 

  10766.      )
    10767. 

  10767.     return true;
    10768. 

  10768.   else
    10769. 

  10769.     return false;
    10770. 

  10770. }
    10771. 

  10771. #endif
    10772. 

  10772. %% #if defined(DEBUG_GCSAFETY)
    10773. 

  10773. %%   printf("static inline bool gcinvariant_symbol_p (object obj) { if (");
    10774. 

  10774. %%   #ifdef TYPECODES
    10775. 

  10775. %%     printf("symbolp(obj)");
    10776. 

  10776. %%   #else
    10777. 

  10777. %%     printf("varobjectp(obj)");
    10778. 

  10778. %%   #endif
    10779. 

  10779. %%   printf(" && (");
    10780. 

  10780. %%   #if !defined(MAP_MEMORY_TABLES)
    10781. 

  10781. %%     #ifdef TYPECODES
    10782. 

  10782. %%       printf2("(as_oint(obj) >> %d) - %d", oint_addr_shift-addr_shift, (aint)(tint)symbol_type<<oint_type_shift);
    10783. 

  10783. %%     #else
    10784. 

  10784. %%       printf1("as_oint(obj) - %d", varobject_bias);
    10785. 

  10785. %%     #endif
    10786. 

  10786. %%   #else
    10787. 

  10787. %%     printf("as_oint(obj)");
    10788. 

  10788. %%   #endif
    10789. 

  10789. %%   puts(" - (aint)&symbol_tab < sizeof(symbol_tab))) return true; else return false; }");
    10790. 

  10790. %% #endif
    10791. 

  10791. 

  10792. /* The macro NIL_IS_CONSTANT tells , whether NIL is recognized
    10793. 

  10793.  as 'constant expression' by the C-Compiler. If so, tables can
    10794. 

  10794.  already be initialized largely by the C-Compiler. */
    10795. 

  10795. #if (oint_addr_shift==0)
    10796. 

  10796.   #define NIL_IS_CONSTANT  true
    10797. 

  10797. #else
    10798. 

  10798.   #define NIL_IS_CONSTANT  false
    10799. 

  10799. #endif
    10800. 

  10800. 

  10801. /* Declaration of the table with the remaining constant objects: */
    10802. 

  10802. #define LISPOBJ  LISPOBJ_A
    10803. 

  10803. extern struct object_tab_ {
    10804. 

  10804.   #include "constobj.c"
    10805. 

  10805. } object_tab;
    10806. 

  10806. #undef LISPOBJ
    10807. 

  10807. /* is used by Macro O */
    10808. 

  10808. %% puts("extern struct object_tab_ {");
    10809. 

  10809. %% #define LISPOBJ(name,init)  printf("  gcv_object_t %s;\n",STRING(name));
    10810. 

  10810. %% #include "constobj.c"
    10811. 

  10811. %% #undef LISPOBJ
    10812. 

  10812. %% puts("} object_tab;");
    10813. 

  10813. 

  10814. /* Abbreviation for other LISP-object with a given Name: */
    10815. 

  10815. #define O(name)  (object_tab.name)
    10816. 

  10816. %% /* FIXME: Difference between lispbibl.d and clisp.h */
    10817. 

  10817. %% puts("#define GLO(name)  (object_tab.name)");
    10818. 

  10818. 

  10819. #if defined(GENERATIONAL_GC) && defined(SPVW_MIXED)
    10820. 

  10820. /* handle_fault_range(PROT_READ,start,end) makes an address range readable.
    10821. 

  10821.  handle_fault_range(PROT_READ_WRITE,start,end) makes an address range writable. */
    10822. 

  10822.   extern bool handle_fault_range (int prot, aint start_address, aint end_address);
    10823. 

  10823. #endif
    10824. 

  10824. %% export_def(PROT_READ);
    10825. 

  10825. %% export_def(PROT_READ_WRITE);
    10826. 

  10826. %% #if defined(GENERATIONAL_GC) && defined(SPVW_MIXED)
    10827. 

  10827. %% puts("extern bool handle_fault_range (int prot, aint start_address, aint end_address);");
    10828. 

  10828. %% #else
    10829. 

  10829. %% puts("#define handle_fault_range(p,s,e)");
    10830. 

  10830. %% #endif
    10831. 

  10831. 

  10832. 

  10833. /* ###################### MODBIBL for MODULES.D ########################### */
    10834. 

  10834. 

  10835. #if defined(DYNAMIC_MODULES) && !defined(HAVE_DYNLOAD) && !defined(WIN32_NATIVE)
    10836. 

  10836.   /* if you want DYNAMIC_MODULES to work on a non-WIN32_NATIVE platform
    10837. 

  10837.      which does not HAVE_DYNLOAD (e.g., via ltdl), you will need to
    10838. 

  10838.      implement libopen() and find_name() in spvw.d for your platform */
    10839. 

  10839.   #error "Dynamic modules require dynamic loading!"
    10840. 

  10840. #endif
    10841. 

  10841. 

  10842. /* Number of external modules: */
    10843. 

  10843. extern uintC module_count;
    10844. 

  10844. %% puts("extern uintC module_count;");
    10845. 

  10845. 

  10846. /* Data for initialization of a module's subr_tab: */
    10847. 

  10847. typedef struct {
    10848. 

  10848.   const char* packname; /* Name of the Home-Package of the Symbol or NULL */
    10849. 

  10849.   const char* symname; /* Name of the Symbol */
    10850. 

  10850. } subr_initdata_t;
    10851. 

  10851. %% emit_typedef("struct { const char* packname; const char* symname; }","subr_initdata_t");
    10852. 

  10852. 

  10853. /* Data for initialization of a module's object_tab: */
    10854. 

  10854. typedef struct {
    10855. 

  10855.   const char* initstring; /* Initialization-String */
    10856. 

  10856. } object_initdata_t;
    10857. 

  10857. %% emit_typedef("struct { const char* initstring; }","object_initdata_t");
    10858. 

  10858. 

  10859. /* Table resp. List of Modules: */
    10860. 

  10860. typedef struct module_t {
    10861. 

  10861.   const char* name; /* Name */
    10862. 

  10862.   subr_t* stab; const uintC* stab_size; /* a separate subr_tab */
    10863. 

  10863.   gcv_object_t* otab; const uintC* otab_size; /* a separate object_tab */
    10864. 

  10864.   bool initialized;
    10865. 

  10865.   /* Data for Initialization: */
    10866. 

  10866.   const subr_initdata_t* stab_initdata;
    10867. 

  10867.   const object_initdata_t* otab_initdata;
    10868. 

  10868.   /* Functions for Initialization */
    10869. 

  10869.   void (*initfunction1) (struct module_t *); /* only once */
    10870. 

  10870.   void (*initfunction2) (struct module_t *); /* always at start up */
    10871. 

  10871.   void (*finifunction) (struct module_t *);  /* before termination */
    10872. 

  10872.   #ifdef DYNAMIC_MODULES
    10873. 

  10873.     struct module_t * next; /* linked List */
    10874. 

  10874.   #endif
    10875. 

  10875. } module_t;
    10876. 

  10876. #ifdef DYNAMIC_MODULES
    10877. 

  10877.   extern module_t modules[]; /* List-Start */
    10878. 

  10878.   BEGIN_DECLS
    10879. 

  10879.   extern void add_module (module_t * new_module);
    10880. 

  10880.   END_DECLS
    10881. 

  10881. #else
    10882. 

  10882.   extern module_t modules[]; /* 1+module_count entries, then an empty entry */
    10883. 

  10883. #endif
    10884. 

  10884. %% 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 *);");
    10885. 

  10885. %% #ifdef DYNAMIC_MODULES
    10886. 

  10886. %%   strcat(buf," struct module_t * next;");
    10887. 

  10887. %% #endif
    10888. 

  10888. %% strcat(buf," }"); emit_typedef(buf,"module_t");
    10889. 

  10889. %% #ifdef DYNAMIC_MODULES
    10890. 

  10890. %%   puts("BEGIN_DECLS");
    10891. 

  10891. %%   puts("extern void add_module (module_t * new_module);");
    10892. 

  10892. %%   puts("END_DECLS");
    10893. 

  10893. %% #else
    10894. 

  10894. %%   puts("extern module_t modules[];");
    10895. 

  10895. %% #endif
    10896. 

  10896. 

  10897. #if defined(HAVE_DYNLOAD) || defined(WIN32_NATIVE)
    10898. 

  10898. /* open the dynamic library
    10899. 

  10899.  libname is the name of the library
    10900. 

  10900.  returns a handle suitable for find_name()
    10901. 

  10901.  calls dlopen() or LoadLibrary() */
    10902. 

  10902. extern void * libopen (const char* libname);
    10903. 

  10903. /* used by FOREIGN and spvw.d:dynload_modules() */
    10904. 

  10904. 

  10905. /* find the name in the dynamic library handle
    10906. 

  10906.  calls dlsym() or GetProcAddress()
    10907. 

  10907.  handle is an object returned by libopen()
    10908. 

  10908.         or NULL, which means emulate RTLD_DEFAULT on UNIX_FREEBSD
    10909. 

  10909.         and WIN32_NATIVE by searching through all libraries
    10910. 

  10910.  name is the name of the function (or variable) in the library */
    10911. 

  10911. extern void* find_name (void *handle, const char *name);
    10912. 

  10912. /* used by FOREIGN and spvw.d:dynload_modules() */
    10913. 

  10913. #endif
    10914. 

  10914. 

  10915. #if defined(DYNAMIC_MODULES)
    10916. 

  10916. /* Attaches a shared library to this process' memory, and attempts to load
    10917. 

  10917.    a number of clisp modules from it. */
    10918. 

  10918. extern void dynload_modules (const char * library, uintC modcount,
    10919. 

  10919.                              const char * const * modnames);
    10920. 

  10920. #endif
    10921. 

  10921. 

  10922. /* find the module with the given name */
    10923. 

  10923. extern module_t* find_module (const char *name);
    10924. 

  10924. /* push all module names to STACK and return the number of modules pushed
    10925. 

  10925.  can trigger GC */
    10926. 

  10926. extern maygc uintC modules_names_to_stack (void);
    10927. 

  10927. 

  10928. /* ####################### EVALBIBL for EVAL.D ############################# */
    10929. 

  10929. 

  10930. /*
    10931. 

    10932. 

  10932. Specifications for the Evaluator
    10933. 

  10933. ################################
    10934. 

    10935. 

  10935. SUBRs and FSUBRs
    10936. 

  10936. ================
    10937. 

    10938. 

  10938. They're constructed through
    10939. 

  10939.   LISPFUN             for general LISP-functions,
    10940. 

  10940.   LISPFUNN            for normal  LISP-functions (only required parameters),
    10941. 

  10941.   LISPSPECFORM        for special forms (FSUBRs).
    10942. 

  10942. Note that SUBRs with KEY_COUNT=0 will be seen as SUBRs without keyword-
    10943. 

  10943. parameters by the evaluator (which in consequence means that in this case the
    10944. 

  10944. ALLOW_FLAG is meaningless and no keyword, not even :ALLOW-OTHER-KEYS,
    10945. 

  10945. will be accepted)!
    10946. 

    10947. 

  10947. Values
    10948. 

  10948. ======
    10949. 

    10950. 

  10950. The following format is used for the passing of multiple values:
    10951. 

  10951. value1 contains the first value (NIL if there aren't values).
    10952. 

  10952. mv_count contains the number of values..
    10953. 

  10953. If there is at least one value       : value1 = first value.
    10954. 

  10954. If there are at least two values     : value2 = second value.
    10955. 

  10955. If there are at least three values   : value3 = third value .
    10956. 

  10956. All values are in mv_space .
    10957. 

  10957. Recommended commands for returning of values to the caller:
    10958. 

  10958.   0 values:   VALUES0;
    10959. 

  10959.   1 value :     VALUES1(...);
    10960. 

  10960.   2 values:   value1=...; value2=...; mv_count=2;
    10961. 

  10961.   3 values:   value1=...; value2=...; value3=...; mv_count=3;
    10962. 

  10962.   more than 3 values:
    10963. 

  10963.               if (number of values >= mv_limit) goto error_too_many_values;
    10964. 

  10964.               Put the values one after another onto the STACK
    10965. 

  10965.               STACK_to_mv(number of values);
    10966. 

    10967. 

  10967. Passing of parameters to SUBRs
    10968. 

  10968. ==============================
    10969. 

    10970. 

  10970. The arguments are passed on the LISP-stack, with the first one being on the
    10971. 

  10971. top. The required arguments come first, then the optional ones
    10972. 

  10972. (each #UNBOUND, if not specified), then come the
    10973. 

  10973. keyword-arguments (again, each #UNBOUND, if not specified).
    10974. 

  10974. The SUBR-object can be found in back_trace.
    10975. 

  10975. This is all if no &REST-argument is planned. But if a &REST-argument
    10976. 

  10976. is planned, all further arguments follow (the optional ones) on the stack
    10977. 

  10977. one by one, and this will be passed: the number of these arguments and a pointer
    10978. 

  10978. above the first of these arguments. (This means that the number of LISP-objects on
    10979. 

  10979. the stack is not always the same!)
    10980. 

  10980. All arguments have to be removed from the LISP-stack at the return jump.
    10981. 

  10981. (for example. for SUBRs with &REST: the stackpointer STACK has to have the value
    10982. 

  10982. args_pointer = rest_args_pointer STACKop (fixed number of arguments)
    10983. 

  10983. = pointer above the very first argument), and mv_count/mv_space
    10984. 

  10984. has to hold the values.
    10985. 

    10986. 

  10986. Passing of parameters to FSUBRs
    10987. 

  10987. ===============================
    10988. 

    10989. 

  10989. The parameters are passed on the LISP-stack with the first one being on top.
    10990. 

  10990. At first there are the required parametes, followed by the optional ones
    10991. 

  10991. (#UNBOUND, if not specifired), then - if body-flag true -
    10992. 

  10992. the whole rest of the body (most of the time a list).
    10993. 

  10993. So the number of objects on the LISP-stack is always the same, namely
    10994. 

  10994. numReqParameter + numOptParameter + (0 or 1 if body-flag).
    10995. 

  10995. At the call, back_trace holds the FSUBR-object, and the whole form is
    10996. 

  10996. in the EVAL-frame, directly above the parameters.
    10997. 

  10997. All parameters have to be removed from the LISP-stack at the return jump
    10998. 

  10998. (ie. the stackpointer STACK has to be incemented by the number of objects),
    10999. 

  10999. and mv_count/mv_space has to hold the values.
    11000. 

    11001. 

  11001. Environments
    11002. 

  11002. ============
    11003. 

    11004. 

  11004. General
    11005. 

  11005. -------
    11006. 

  11006. The lexical environment is separated into 5 components:
    11007. 

  11007.   - the variables-environment (VAR_ENV),
    11008. 

  11008.   - the functions- and macro-environment (FUN_ENV),
    11009. 

  11009.   - the block-environment (BLOCK_ENV),
    11010. 

  11010.   - the tagbody-environment (GO_ENV),
    11011. 

  11011.   - the declarations-environment (DECL_ENV).
    11012. 

  11012. The environment is kept in 5 "global variables". They are dynamically bound
    11013. 

  11013. with special frames on change.
    11014. 

  11014. A single functions- and macro environment is passed to SYM_FUNCTION,
    11015. 

  11015. MACROEXP, MACROEXP0, PARSE_DD.
    11016. 

  11016. GET_CLOSURE expects a pointer to all environments en bloc: A3 with
    11017. 

  11017. VAR_(A3)=VAR_ENV, FUN_(A3)=FUN_ENV, BLOCK_(A3)=BLOCK_ENV, GO_(A3)=GO_ENV,
    11018. 

  11018. DECL_(A3)=DECL_ENV.
    11019. 

    11020. 

  11020. The variables-environment
    11021. 

  11021. -------------------------
    11022. 

  11022. It contains the local variable-bindings.
    11023. 

  11023. A variables-enviroment is given through a pointer to a
    11024. 

  11024. variable-binding frame, or NIL  (which means an empty lexical
    11025. 

  11025. environment) or a vector that is built as follows:
    11026. 

  11026. The vector contains n bindings and has the length 2n+1. The elements are
    11027. 

  11027. n-times each variable (a symbol) and  the value that belongs to it ("value" can
    11028. 

  11028. be #<SPECDECL> as well, and then the variable has to be referenced dynamically)
    11029. 

  11029. and as last element the predecessor environment.
    11030. 

    11031. 

  11031. The functions- and macro-environment
    11032. 

  11032. ------------------------------------
    11033. 

  11033. It contains the local function- and macro-definitions.
    11034. 

  11034. A functions- and macro-environment is given through a pointer to
    11035. 

  11035. a functions- or macrobindings-frame or NIL (which means an empty
    11036. 

  11036. lexical environment) or through a vector that is built as follows:
    11037. 

  11037. The vector contains n bindings and has length 2n+1. The elements are
    11038. 

  11038. n-time each function-name (a symbol) and the definiton that belongs to it (a
    11039. 

  11039. closure or NIL or a SYS::MACRO object) and as last element
    11040. 

  11040. the predecessor environment.
    11041. 

    11042. 

  11042. The block-environment
    11043. 

  11043. ---------------------
    11044. 

  11044. It contains the lexically visible block-exitpoints.
    11045. 

  11045. A block-environment is given through a pointer to a block-frame
    11046. 

  11046. or through an association-list, whose elements each have the block-name (a symbol)
    11047. 

  11047. as CAR and as CDR either the pointer to the appropriate
    11048. 

  11048. frame or #DISABLED, if the block has already been left.
    11049. 

    11050. 

  11050. The tagbody-environment
    11051. 

  11051. -----------------------
    11052. 

  11052. It contains the lexically visible Go-labels of the tagbodies.
    11053. 

  11053. A tagbody-environment is given through a pointer to a
    11054. 

  11054. tagbody-frame or an associations-list, whose elements have a vector (with the
    11055. 

  11055. Go-tags as elements) as CAR and as CDR either the pointer to the
    11056. 

  11056. related frame or #DISABLED, if the tagbody has already
    11057. 

  11057. been left.
    11058. 

    11059. 

  11059. The declarations-environment
    11060. 

  11060. ----------------------------
    11061. 

  11061. It contains the lexically visible declarations.
    11062. 

  11062. A declarations-environment is given through a list of declaration-
    11063. 

  11063. specifiers, whose CAR is each either OPTIMIZE or DECLARATION or
    11064. 

  11064. a user-specified declaration-type.
    11065. 

    11066. 

  11066. Passing of environtments to LISP-functions
    11067. 

  11067. ------------------------------------------
    11068. 

  11068. There are two data structures for this:
    11069. 

  11069. When it is passed as second argument to macro-expander-functions (CLTL p.
    11070. 

  11070. 145-146) and when it is receipted by MACROEXPAND and MACROEXPAND-1 (CLTL p. 151)
    11071. 

  11071. it is simply a Simple-Vector with 2 elements, consisting of a nested
    11072. 

  11072. variable-environment and a nested functions- and macro-environment.
    11073. 

  11073. The same for passing to  SYSTEM::%EXPAND-LAMBDABODY-MAIN and the like.
    11074. 

  11074. If it is passed as second argument to the value of *EVALHOOK* or as third one
    11075. 

  11075. to the value of *APPLYHOOK* (CLTL p. 322) and on reception by
    11076. 

  11076. EVALHOOK and APPLYHOOK (CLTL p. 323) it is a Simple-Vector with
    11077. 

  11077. five elements with all five components nested.
    11078. 

    11079. 

  11079. Frames
    11080. 

  11080. ======
    11081. 

  11081. Frames are not used to call SUBRs, FSUBRs and compiled closures.
    11082. 

    11083. 

  11083. There are the following 14 kinds of frames:
    11084. 

  11084.   - Environmentbinding-Frame (ENV_FRAME),
    11085. 

  11085.   - APPLY-frame (APPLY_FRAME),
    11086. 

  11086.   - EVAL-frame (EVAL_FRAME),
    11087. 

  11087.   - dynamic variable-bindings-frame (DYNBIND_FRAME),
    11088. 

  11088.   - Variable-bindings-frame (VAR_FRAME),
    11089. 

  11089.   - Function- or Macrobindings-Frame (FUN_FRAME),
    11090. 

  11090.   - interpreted block-frame (IBLOCK_FRAME),
    11091. 

  11091.   - compiled block-frame (CBLOCK_FRAME),
    11092. 

  11092.   - interpreted tagbody-frame (ITAGBODY_FRAME),
    11093. 

  11093.   - compiled tagbody-frame (CTAGBODY_FRAME),
    11094. 

  11094.   - Catch-Frame (CATCH_FRAME),
    11095. 

  11095.   - Unwind-Protect-frame (UNWIND_PROTECT_FRAME),
    11096. 

  11096.   - Handler-frame (HANDLER_FRAME),
    11097. 

  11097.   - Driver-frame (DRIVER_FRAME).
    11098. 

  11098. Right at the bottom of a frame there is a long-word, that contains the
    11099. 

  11099. frame-type information and a pointer above the frame (= the value of the
    11100. 

  11100. STACK before and after the frame has been built).
    11101. 

  11101. In the frame-info there are the bits
    11102. 

  11102.   SKIP2_BIT      deleted, if another long-word comes above it,
    11103. 

  11103.                    that is not a LISP-object and thus has to be skipped
    11104. 

  11104.                    by the GC,
    11105. 

  11105.   EXITPOINT_BIT  set for all but VAR and FUN,
    11106. 

  11106.   NESTED_BIT     set for IBLOCK and ITAGBODY, if the exitpoint or
    11107. 

  11107.                    the Go-label has already been put into an Alist.
    11108. 

  11108. The default-values for  the frame-type info-bytes are ENVxx_FRAME_INFO,
    11109. 

  11109. APPLY_FRAME_INFO, EVAL_FRAME_INFO, VAR_FRAME_INFO, FUN_FRAME_INFO,
    11110. 

  11110. IBLOCK_FRAME_INFO, CBLOCK_FRAME_INFO, ITAGBODY_FRAME_INFO, CTAGBODY_FRAME_INFO,
    11111. 

  11111. CATCH_FRAME_INFO, UNWIND_PROTECT_FRAME_INFO, DRIVER_FRAME_INFO.
    11112. 

  11112. The routine that is in (SP).L with SP=SP_(STACK) (for IBLOCK-, CBLOCK-,
    11113. 

  11113. ITAGBODY-, CTAGBODY-, CATCH-, UNWIND-PROTECT-frames), is being
    11114. 

  11114. jumped to by MOVE.L SP_(STACK),SP ! RTS  .
    11115. 

  11115. For DRIVER-frames by MOVE.L SP_(STACK),SP ! MOVE.L (SP),-(SP) ! RTS  .
    11116. 

  11116. In the portable C-version in SP_(STACK) there is a pointer to a
    11117. 

  11117. setjmp/longjmp-buffer.
    11118. 

    11119. 

  11119. Environmentbindings-frames
    11120. 

  11120. --------------------------
    11121. 

  11121. They contain dynamic bindings of a maximum of 5 environments.
    11122. 

  11122. ENVxx_FRAME_INFO  is frame-info (xx depending on the environment that is
    11123. 

  11123. bound here). Structure:
    11124. 

  11124.     Offset        Stack-Contents
    11125. 

  11125.   20/16/12/8/4  [old value ofDECL_ENV]
    11126. 

  11126.   16/12/8/4     [old value ofGO_ENV]
    11127. 

  11127.   12/8/4        [old value ofBLOCK_ENV]
    11128. 

  11128.   8/4           [old value ofFUN_ENV]
    11129. 

  11129.   4             [old value ofVAR_ENV]
    11130. 

  11130.   0             Frame-Info; pointer above frame
    11131. 

    11132. 

  11132. ENV1V_frame    for 1 VAR_ENV
    11133. 

  11133. ENV1F_frame    for 1 FUN_ENV
    11134. 

  11134. ENV1B_frame    for 1 BLOCK_ENV
    11135. 

  11135. ENV1G_frame    for 1 GO_ENV
    11136. 

  11136. ENV1D_frame    for 1 DECL_ENV
    11137. 

  11137. ENV2VD_frame   for 1 VAR_ENV and 1 DECL_ENV
    11138. 

  11138. ENV5_frame     for all 5 environments
    11139. 

    11140. 

  11140. APPLY-frames
    11141. 

  11141. ------------
    11142. 

  11142. They are created at every call (APPLY or FUNCALL) of an interpreted
    11143. 

  11143. closure.
    11144. 

  11144. Structure:
    11145. 

  11145.   Offset     Stack-contents
    11146. 

  11146.   4n+12
    11147. 

  11147.   4n+8      Argument 1
    11148. 

  11148.   ...
    11149. 

  11149.   12        Argument n
    11150. 

  11150.   8         Function that is being called
    11151. 

  11151.   4         SP
    11152. 

  11152.   0         Frame-info; pointer above frame
    11153. 

  11153. SP is a pointer into the program-stack. Jumping back to (SP).L after dissolving
    11154. 

  11154. the APPLY-fame returns the contents of A0/... as values of the form.
    11155. 

  11155. The frame-info has the value APPLY_FRAME_INFO or TRAPPED_APPLY_FRAME_INFO.
    11156. 

    11157. 

  11157. EVAL-frames
    11158. 

  11158. -----------
    11159. 

  11159. They are created for every call of the EVAL-procedure.
    11160. 

  11160. Layout:
    11161. 

  11161.   Offset     Stack-content
    11162. 

  11162.   8         Form that is being evaluated
    11163. 

  11163.   4         SP
    11164. 

  11164.   0         Frame-info; pointer above frame
    11165. 

  11165. SP is a pointer into the program stack. Jumping back to (SP).L after dissolving
    11166. 

  11166. the EVAL-frame returns the contents of A0/... as values of the form.
    11167. 

  11167. The frame-info has the value EVAL_FRAME_INFO or TRAPPED_EVAL_FRAME_INFO.
    11168. 

    11169. 

  11169. Dynamic variable-bindings frames
    11170. 

  11170. -----------------------------------
    11171. 

  11171. They bind symbols to values dynamically.
    11172. 

  11172. The structure of such a frame with n bindings is as follows::
    11173. 

  11173.   Offset  stack contents
    11174. 

  11174.   8n+4
    11175. 

  11175.   8n      value 1
    11176. 

  11176.   8n-4    symbol 1
    11177. 

  11177.   ...     ...
    11178. 

  11178.   8       value n
    11179. 

  11179.   4       symbol n
    11180. 

  11180.   0       frame-info; pointer above frame
    11181. 

  11181. The content of the frameinfo-byte is DYNBIND_FRAME_INFO.
    11182. 

    11183. 

  11183. Variable-bindings-frames
    11184. 

  11184. ------------------------
    11185. 

  11185. They are created when interpreted closures are being used (for the variable
    11186. 

  11186. bindings specified in the Lambda-list and in the dynamic references that might
    11187. 

  11187. be specified in the declarations) and by LET and LET*, as well as by all
    11188. 

  11188. constructs, that use LET or LET* implicitly (such as DO, DO*, PROG, PROG*,
    11189. 

  11189. DOLIST, DOTIMES, ...).
    11190. 

  11190. The structure of a variable-bindings-frame with n bindings is as follows:
    11191. 

  11191. #ifndef NO_symbolflags
    11192. 

  11192.   Offset  stack contents
    11193. 

  11193.   12+8n
    11194. 

  11194.   8+8n    value 1
    11195. 

  11195.   4+8n    symbol 1
    11196. 

  11196.   ...     ...
    11197. 

  11197.   16      value n
    11198. 

  11198.   12      symbol n
    11199. 

  11199.   8       NEXT_ENV
    11200. 

  11200.   4       m
    11201. 

  11201.   0       frame-info; pointer above frame
    11202. 

  11202. #else
    11203. 

  11203.   Offset  stack contents
    11204. 

  11204.   12+12n
    11205. 

  11205.   8+12n   value 1
    11206. 

  11206.   4+12n   symbol 1
    11207. 

  11207.   12n     marker bits 1
    11208. 

  11208.   ...     ...
    11209. 

  11209.   20      value n
    11210. 

  11210.   16      symbol n
    11211. 

  11211.   12      marker bits n
    11212. 

  11212.   8       NEXT_ENV
    11213. 

  11213.   4       m
    11214. 

  11214.   0       frame-info; pointer above frame
    11215. 

  11215. #endif
    11216. 

  11216. The symbol/value-pairs are numbered and stored in the order in which the
    11217. 

  11217. bindings become active (i.e. for interpreted closures: at first the dynamic
    11218. 

  11218. references (SPECIAL-declarations), then the required-parameters, then the
    11219. 

  11219. optional parameters, then the remaining parameters, then the keyword
    11220. 

  11220. parameters, then the AUX-variables).
    11221. 

  11221. The symbols contain the following marker bits on the stack: ACTIVE_BIT, is
    11222. 

  11222. set, if the binding is active, DYNAM_BIT is set, if the binding is
    11223. 

  11223. dynamic. (Dynamic references are marked as lexical with
    11224. 

  11224. the special value #SPECDECL!).
    11225. 

  11225. NEXT_ENV is next upper variables-environment.
    11226. 

  11226. m is a long-word, 0 <= m <= n, and stands for the number of bindings that
    11227. 

  11227. have not yet been put into a vector by NEST-operations. Thus
    11228. 

  11228. the symbol/value-pairs 1,...,n-m have been active but been nested meanwhile
    11229. 

  11229. and thus inactive again on the stack (if the bindings were static).
    11230. 

  11230. Only some of the pairs n-m+1,...,n can be static and active.
    11231. 

  11231. The frameinfo-byte contains VAR_FRAME_INFO.
    11232. 

    11233. 

  11233. Function- and Macrobindings-Frames
    11234. 

  11234. -----------------------------------
    11235. 

  11235. They are created by FLET and MACROLET.
    11236. 

  11236. The structure of a variable-bindings-frame with n bindings is as follows:
    11237. 

  11237.   Offset  stack contents
    11238. 

  11238.   12+8n
    11239. 

  11239.   8+8n    value 1
    11240. 

  11240.   4+8n    symbol 1
    11241. 

  11241.   ...     ...
    11242. 

  11242.   16      value n
    11243. 

  11243.   12      symbol n
    11244. 

  11244.   8       NEXT_ENV
    11245. 

  11245.   4       m
    11246. 

  11246.   0       Frame-Info; pointer above frame
    11247. 

  11247. NEXT_ENV is the next higher function-environment.
    11248. 

  11248. m is a long word, 0 <= m <= n, and stands for the number of bindings, that
    11249. 

  11249. have not yet been put into a vector by NEST-operations. So the
    11250. 

  11250. symbol/value pais 1,...,n-m have been active, but nested meanwhile and thus
    11251. 

  11251. inactive on the stack again. Only the pairs n-m+1,...,n are active.
    11252. 

  11252. Marker bits are not needed here, as opposed to the variable-bindings frames
    11253. 

    11254. 

  11254. All values are closures or SYS::MACRO objects.
    11255. 

  11255. The content of the Frameinfo-bytes is FUN_FRAME_INFO.
    11256. 

    11257. 

  11257. Interpreted Block-Frames
    11258. 

  11258. ------------------------
    11259. 

  11259. They are created by BLOCK and all constructs that contain an implicit
    11260. 

  11260. BLOCK (e.g. DO, DO*, LOOP, PROG, PROG*, ...). The structure is as follows:
    11261. 

  11261.   Offset  stack contents
    11262. 

  11262.   16
    11263. 

  11263.   12       NAME
    11264. 

  11264.   8        NEXT_ENV
    11265. 

  11265.   4        SP
    11266. 

  11266.   0        Frame-Info; pointer above frame
    11267. 

  11267. NAME is the name of the block. NEXT_ENV is the next higher Block-Environment.
    11268. 

  11268. SP is a pointer into the program stack, (SP).L is a routine, that unwinds the
    11269. 

  11269. Block-Frame and leaves the block with the values A0-A2/...
    11270. 

  11270. Frame-Info is IBLOCK_FRAME_INFO, possibly with set NESTED_BIT (then NEXT_ENV
    11271. 

  11271. points to an Alist, whose first element is the pair (NAME . <Framepointer>),
    11272. 

  11272. because the block is not DISABLED yet).
    11273. 

    11274. 

  11274. Compiled Block-Frames
    11275. 

  11275. ---------------------
    11276. 

  11276. Structure:
    11277. 

  11277.   Offset  stack contents
    11278. 

  11278.    12
    11279. 

  11279.    8        Cons (NAME . <Framepointer>)
    11280. 

  11280.    4        SP
    11281. 

  11281.    0        Frame-Info; pointer above frame
    11282. 

  11282. NAME is the name of the block.
    11283. 

  11283. SP is a pointer into the program stack, (SP).L is a routine, that
    11284. 

  11284. unwinds the Block-Frame and leaves the block with the values A0-A2/...
    11285. 

  11285. Frame-Info is CBLOCK_FRAME_INFO.
    11286. 

    11287. 

  11287. Interpreted Tagbody-Frames
    11288. 

  11288. --------------------------
    11289. 

  11289. They are created by TAGBODY and all constructs that contain an implicit
    11290. 

  11290. TAGBODY (e.g. DO, DO*, PROG, PROG*, ...).
    11291. 

  11291. The structure of a Tagbody-Frames with n tags is as follows:
    11292. 

  11292.   Offset  stack contents
    11293. 

  11293.   12+8n
    11294. 

  11294.   8+8n     BODY 1
    11295. 

  11295.   4+8n     TAG 1
    11296. 

  11296.   ...      ...
    11297. 

  11297.   16       BODY n
    11298. 

  11298.   12       TAG n
    11299. 

  11299.   8        NEXT_ENV
    11300. 

  11300.   4        SP
    11301. 

  11301.   0        Frame-Info; pointer above frame
    11302. 

  11302. The tags are the jump destinations ; they are symbols and Integers, that are in
    11303. 

  11303. the Body. The corresponding "value" BODY i contains the part of the body
    11304. 

  11304. that follows TAG i. NEXT_ENV is the next higher Tagbody-Environment.
    11305. 

  11305. SP is a pointer into the program stack, (SP).L is a routine, that executes
    11306. 

  11306. the action (GO TAGi), if it is jumped to with BODYi in A0.
    11307. 

  11307. Frame-Info is ITAGBODY_FRAME_INFO, poss. with set NESTED_BIT (then
    11308. 

  11308. NEXT_ENV points to an Alist, whose first element has the form
    11309. 

  11309. (#(TAG1 ... TAGn) . <Framepointer>), because the Tagbody is not
    11310. 

  11310. DISABLED yet).
    11311. 

    11312. 

  11312. Compiled Tagbody-Frames
    11313. 

  11313. -----------------------
    11314. 

  11314. Structure:
    11315. 

  11315.   Offset  stack contents
    11316. 

  11316.    12
    11317. 

  11317.    8        Cons (#(TAG1 ... TAGn) . <Framepointer>)
    11318. 

  11318.    4        SP
    11319. 

  11319.    0        Frame-Info; above frame
    11320. 

  11320. TAG1, ..., TAGn are the names of the tags (actually only contained in
    11321. 

  11321. the compiled code to create error messages).
    11322. 

  11322. SP is a pointer into the program stack, (SP).L is a routine, that executes
    11323. 

  11323. the action (GO TAGi), if it has been jumped at with value1 = i (1 <= i <= n)
    11324. 

    11325. 

  11325. Frame-Info is CTAGBODY_FRAME_INFO.
    11326. 

    11327. 

  11327. Catch-Frames
    11328. 

  11328. ------------
    11329. 

  11329. They are created by the  Special-Form CATCH. Its structure is as follows:
    11330. 

  11330.   Offset  stack contents
    11331. 

  11331.    12
    11332. 

  11332.    8        TAG
    11333. 

  11333.    4        SP
    11334. 

  11334.    0        Frame-Info; pointer above frame
    11335. 

  11335. TAG is the tag of the catcher.
    11336. 

  11336. SP is a pointer into the program stack, (SP).L is a routine, that unwinds
    11337. 

  11337. the Frame and returns the values A0-A2/...
    11338. 

  11338. Frame-Info is CATCH_FRAME_INFO.
    11339. 

    11340. 

  11340. Unwind-Protect-Frames
    11341. 

  11341. ---------------------
    11342. 

  11342. They are created by the Special-Form UNWIND-PROTECT and all constructs
    11343. 

  11343. that contain an implicit UNWIND-PROTECT (like WITH-OPEN-STREAM or
    11344. 

  11344. WITH-OPEN-FILE). Their structure is as follows:
    11345. 

  11345.   Offset  Stack-contents
    11346. 

  11346.    8
    11347. 

  11347.    4        SP
    11348. 

  11348.    0        Frame-Info; pointer above frame
    11349. 

  11349. SP is a pointer into the program stack. (SP).L a routine, that unwinds the
    11350. 

  11350. Frame,saves the current values A0-A2/...  executes the cleanup,
    11351. 

  11351. writes the saved values back and finally jumps to the address
    11352. 

  11352. (with RTS), that has been entered into the program stack in place of their own
    11353. 

  11353. and leaves D6 unchanged.
    11354. 

    11355. 

  11355. Handler-Frames
    11356. 

  11356. --------------
    11357. 

  11357. They are created by the macro HANDLER-BIND. Their structure is as follows:
    11358. 

  11358.   Offset  Stack-contens
    11359. 

  11359.    16
    11360. 

  11360.    12       Cons (#(type1 label1 ... typem labelm) . SPdepth)
    11361. 

  11361.    8        Closure
    11362. 

  11362.    4        SP
    11363. 

  11363.    0        Frame-Info; pointer above frame
    11364. 

  11364. SP is a pointer into the program stack.
    11365. 

  11365. If there is a condition of the type typei
    11366. 

  11366. the closure starting at Bte labeli is interpreted as Handler, where at first
    11367. 

  11367. a piece of the program stack with the length SPdepth  is duplicated.
    11368. 

  11368. One variant of Handler-Frames calls a C-Handler:
    11369. 

  11369.   Offset  Stack-contents
    11370. 

  11370.    16
    11371. 

  11371.    12       Cons (#(type1 label1 ... typem labelm))
    11372. 

  11372.    8        Handler-function
    11373. 

  11373.    4        SP
    11374. 

  11374.    0        Frame-Info; pointer above frame
    11375. 

  11375. SP is a pointer into the program stack.
    11376. 

  11376. If there is a condition of the type typei
    11377. 

  11377. the handler-function is called with the arguments SP
    11378. 

  11378. (arbitrary pointer into the C-Stack), frame (pointer above the frame),
    11379. 

  11379. labeli (arbitrary Lisp-object), condition.
    11380. 

  11380. If the Handler wants to yield control via unwind_upto(FRAME) by itself,
    11381. 

  11381. the Frame has to be created with finish_entry_frame.
    11382. 

    11383. 

  11383. Driver-Frames
    11384. 

  11384. -------------
    11385. 

  11385. They are created upon entry into a top-level loop (most of the time
    11386. 

  11386. a READ-EVAL-PRINT-loop) and are used to continue the previous top-level
    11387. 

  11387. loop after an error message. The structure is simple
    11388. 

  11388.   Offset  Stack-contens
    11389. 

  11389.    8
    11390. 

  11390.    4        SP
    11391. 

  11391.    0        Frame-Info; pointer above Frame
    11392. 

  11392. SP is a pointer into the program stack. (SP).L is a routine, that
    11393. 

  11393. re-enters the corresponding top-level loop.
    11394. 

    11395. 

  11395.  STACK:
    11396. 

  11396.  ------
    11397. 

  11397.  STACK is the LISP-Stack.
    11398. 

  11398.  STACK_0 is the first object on the STACK.
    11399. 

  11399.  STACK_1 is the second object on the STACK.
    11400. 

  11400.  etc., generally STACK_(n) = (n+1)th object on the STACK.
    11401. 

  11401.  pushSTACK(object)  puts an object onto the Stack. Synonym: -(STACK).
    11402. 

  11402.  popSTACK()  returns STACK_0 and removes it from the stack.
    11403. 

  11403.  skipSTACK(n);  removes n objects from the STACK.
    11404. 

  11404.  If you want to save the value of the stack, you do this:
    11405. 

  11405.    var gcv_object_t* temp = STACK; ... (no access through temp !) ... setSTACK(STACK = temp);
    11406. 

  11406.    but: access through STACKpointable(temp)  is possible.
    11407. 

  11407.  If you want a pointer that can traverse through the Stack, you do this:
    11408. 

  11408.    var gcv_object_t* ptr = &STACK_0;  or = STACKpointable(STACK);
    11409. 

  11409.    assert( *(ptr STACKop 0) == STACK_0 );
    11410. 

  11410.    assert( *(ptr STACKop 1) == STACK_1 );
    11411. 

  11411.    ...
    11412. 

  11412.    ptr skipSTACKop n;
    11413. 

  11413.    assert( *(ptr STACKop 0) == STACK_(n) );
    11414. 

  11414.    ...
    11415. 

  11415.    This pointer must not be assigned to the STACK again!
    11416. 

  11416.  If you store blocks of objects on the STACK and want to get the (n+1)-th block,
    11417. 

  11417.    you do this:  STACKblock_(type,n). type should be a
    11418. 

  11418.    struct-type with sizeof(type) a multiple of sizeof(gcv_object_t). */
    11419. 

  11419. 

  11420. #ifdef STACK_DOWN
    11421. 

  11421.   #define STACK_(n)  (STACK[(sintP)(n)])
    11422. 

  11422.   #define STACKpointable(STACKvar)  ((gcv_object_t*)(STACKvar))
    11423. 

  11423.   #define skipSTACKop  +=
    11424. 

  11424.   #define STACKop      +
    11425. 

  11425.   #define cmpSTACKop   <
    11426. 

  11426.   #define STACKblock_(type,n)  (((type*)STACK)[(sintP)(n)])
    11427. 

  11427. #endif
    11428. 

  11428. #ifdef STACK_UP
    11429. 

  11429.   #define STACK_(n)  (STACK[-1-(sintP)(n)])
    11430. 

  11430.   #define STACKpointable(STACKvar)  ((gcv_object_t*)(STACKvar)-1)
    11431. 

  11431.   #define skipSTACKop  -=
    11432. 

  11432.   #define STACKop      -
    11433. 

  11433.   #define cmpSTACKop   >
    11434. 

  11434.   #define STACKblock_(type,n)  (((type*)STACK)[-1-(sintP)(n)])
    11435. 

  11435. #endif
    11436. 

  11436. #define pushSTACK(obj)  (STACK_(-1) = (obj), STACK skipSTACKop -1)
    11437. 

  11437.   /* Almost equivalent with *--STACK = obj  resp.  *STACK++ = obj  , but
    11438. 

  11438.    Careful: first enter the object into STACK_(-1), THEN modify the STACK! */
    11439. 

  11439. #define popSTACK()  (STACK skipSTACKop 1, STACK_(-1))
    11440. 

  11440. #define skipSTACK(n)  (STACK skipSTACKop (sintP)(n))
    11441. 

  11441. 

  11442. #if defined(GNU) && defined(MC680X0) && !defined(NO_ASM) && !defined(WIDE) && defined(STACK_register)
    11443. 

  11443.   /* With GNU and a 680X0 STACK is in a register. Access and
    11444. 

  11444.    modification of the STACK are an atomic unit that cannot be interrupted. */
    11445. 

  11445.   #undef pushSTACK
    11446. 

  11446.   #undef popSTACK
    11447. 

  11447.   #ifdef STACK_DOWN
    11448. 

  11448.     /* define pushSTACK(obj)  (*--STACK = (obj)) */
    11449. 

  11449.     #define pushSTACK(obj)  \
    11450. 

  11450.       ({ __asm__ __volatile__ ("movel %0,"REGISTER_PREFIX""STACK_register"@-" : : "g" ((object)(obj)) : STACK_register ); })
    11451. 

  11451.     /* define popSTACK()  (*STACK++) */
    11452. 

  11452.     #define popSTACK()  \
    11453. 

  11453.       ({var object __result;                                                                                         \
    11454. 

  11454.         __asm__ __volatile__ ("movel "REGISTER_PREFIX""STACK_register"@+,%0" : "=g" (__result) : : STACK_register ); \
    11455. 

  11455.         __result;                                                                                                    \
    11456. 

  11456.        })
    11457. 

  11457.   #endif
    11458. 

  11458.   #ifdef STACK_UP
    11459. 

  11459.     /* define pushSTACK(obj)  (*STACK++ = (obj)) */
    11460. 

  11460.     #define pushSTACK(obj)  \
    11461. 

  11461.       ({ __asm__ __volatile__ ("movel %0,"REGISTER_PREFIX""STACK_register"@+" : : "g" ((object)(obj)) : STACK_register ); })
    11462. 

  11462.     /* define popSTACK()  (*--STACK) */
    11463. 

  11463.     #define popSTACK()  \
    11464. 

  11464.       ({var object __result;                                                                                         \
    11465. 

  11465.         __asm__ __volatile__ ("movel "REGISTER_PREFIX""STACK_register"@-,%0" : "=g" (__result) : : STACK_register ); \
    11466. 

  11466.         __result;                                                                                                    \
    11467. 

  11467.        })
    11468. 

  11468.   #endif
    11469. 

  11469. #endif
    11470. 

  11470. #if defined(SPARC) && !defined(GNU) && !defined(__SUNPRO_C) && !defined(MULTITHREAD) && (SAFETY < 2)
    11471. 

  11471.   #undef pushSTACK
    11472. 

  11472.   #undef popSTACK
    11473. 

  11473.   #undef skipSTACK
    11474. 

  11474.   #define pushSTACK(obj)  (STACK_(-1) = (obj), _setSTACK(STACK STACKop -1))
    11475. 

  11475.   #define popSTACK()  (_setSTACK(STACK STACKop 1), STACK_(-1))
    11476. 

  11476.   #define skipSTACK(n)  (_setSTACK(STACK STACKop (sintP)(n)))
    11477. 

  11477. #endif
    11478. 

  11478. %% export_def(STACK_(n));
    11479. 

  11479. %% export_def(skipSTACKop);
    11480. 

  11480. %% export_def(STACKop);
    11481. 

  11481. %% export_def(pushSTACK(obj));
    11482. 

  11482. %% export_def(popSTACK());
    11483. 

  11483. %% export_def(skipSTACK(n));
    11484. 

  11484. 

  11485. #define STACK_0  (STACK_(0))
    11486. 

  11486. #define STACK_1  (STACK_(1))
    11487. 

  11487. #define STACK_2  (STACK_(2))
    11488. 

  11488. #define STACK_3  (STACK_(3))
    11489. 

  11489. #define STACK_4  (STACK_(4))
    11490. 

  11490. #define STACK_5  (STACK_(5))
    11491. 

  11491. #define STACK_6  (STACK_(6))
    11492. 

  11492. #define STACK_7  (STACK_(7))
    11493. 

  11493. #define STACK_8  (STACK_(8))
    11494. 

  11494. #define STACK_9  (STACK_(9))
    11495. 

  11495. #define STACK_10  (STACK_(10))
    11496. 

  11496. /* etc. */
    11497. 

  11497. %% { int i;
    11498. 

  11498. %%   for (i=0; i<=10; i++)
    11499. 

  11499. %%     printf("#define STACK_%d  (STACK_(%d))\n",i,i);
    11500. 

  11500. %% }
    11501. 

  11501. 

  11502. /* Values:
    11503. 

    11504. 

  11504.  Highest number of multiple values + 1 */
    11505. 

  11505. #define mv_limit  128
    11506. 

  11506. /* Values are always passed in the MULTIPLE_VALUE_SPACE mv_space:
    11507. 

  11507.  uintC mv_count : number of values, >=0, <mv_limit
    11508. 

  11508.  object mv_space [mv_limit-1] : the values.
    11509. 

  11509.    For mv_count>0 the first mv_count elements are occupied.
    11510. 

  11510.    For mv_count=0 the first value = NIL.
    11511. 

  11511.    The values in mv_space are not subject to the Garbage Collection! */
    11512. 

  11512. #if !defined(mv_count_register)
    11513. 

  11513.   /* a global Variable */
    11514. 

  11514.   extern per_thread uintC mv_count;
    11515. 

  11515. #else
    11516. 

  11516.   /* a global register */
    11517. 

  11517.   register uintC mv_count __asm__(mv_count_register);
    11518. 

  11518. #endif
    11519. 

  11519. extern per_thread object mv_space [mv_limit-1];
    11520. 

  11520. /* Synonyms: */
    11521. 

  11521. #if !defined(value1_register)
    11522. 

  11522.     #define value1  mv_space[0]
    11523. 

  11523.   #define VALUE1_EXTRA /* and thus has to be treated extra every time... */
    11524. 

  11524. #else
    11525. 

  11525.   /* The first value mv_space[0] is stored permanently in a register: */
    11526. 

  11526.   register object value1 __asm__(value1_register);
    11527. 

  11527.   #define VALUE1_EXTRA /* and thus has to be treated extra every time... */
    11528. 

  11528. #endif
    11529. 

  11529. #define value2  mv_space[1]
    11530. 

  11530. #define value3  mv_space[2]
    11531. 

  11531. #define value4  mv_space[3]
    11532. 

  11532. #define value5  mv_space[4]
    11533. 

  11533. #define value6  mv_space[5]
    11534. 

  11534. #define value7  mv_space[6]
    11535. 

  11535. #define value8  mv_space[7]
    11536. 

  11536. #define value9  mv_space[8]
    11537. 

  11537. /* You might need global variables to pass with setjmp/longjmp: */
    11538. 

  11538. #ifdef NEED_temp_mv_count
    11539. 

  11539.   extern per_thread uintC temp_mv_count;
    11540. 

  11540.   #define LONGJMP_SAVE_mv_count()  temp_mv_count = mv_count
    11541. 

  11541.   #define LONGJMP_RESTORE_mv_count()  mv_count = temp_mv_count
    11542. 

  11542. #else
    11543. 

  11543.   #define LONGJMP_SAVE_mv_count()
    11544. 

  11544.   #define LONGJMP_RESTORE_mv_count()
    11545. 

  11545. #endif
    11546. 

  11546. #ifdef NEED_temp_value1
    11547. 

  11547.   extern per_thread object temp_value1;
    11548. 

  11548.   #define LONGJMP_SAVE_value1()  temp_value1 = value1
    11549. 

  11549.   #define LONGJMP_RESTORE_value1()  value1 = temp_value1
    11550. 

  11550. #else
    11551. 

  11551.   #define LONGJMP_SAVE_value1()
    11552. 

  11552.   #define LONGJMP_RESTORE_value1()
    11553. 

  11553. #endif
    11554. 

  11554. /* is used by EVAL, CONTROL,
    11555. 

  11555.                     Macros LIST_TO_MV, MV_TO_LIST, STACK_TO_MV, MV_TO_STACK */
    11556. 

  11556. %% #if notused
    11557. 

  11557. %% export_def(mv_limit);
    11558. 

  11558. %% #endif
    11559. 

  11559. %% #if !defined(mv_count_register)
    11560. 

  11560. %%   puts("extern uintC mv_count;");
    11561. 

  11561. %% #else
    11562. 

  11562. %%   puts("#ifndef IN_MODULE_CC");
    11563. 

  11563. %%   printf("register uintC mv_count __asm__(\"%s\");\n",mv_count_register);
    11564. 

  11564. %%   puts("#endif");
    11565. 

  11565. %% #endif
    11566. 

  11566. %% printf("extern object mv_space [%d];\n",mv_limit-1);
    11567. 

  11567. %% #if !defined(value1_register)
    11568. 

  11568. %%   emit_define("value1","mv_space[0]");
    11569. 

  11569. %% #else
    11570. 

  11570. %%   puts("#ifndef IN_MODULE_CC");
    11571. 

  11571. %%   printf("register object value1 __asm__(\"%s\");\n",value1_register);
    11572. 

  11572. %%   puts("#endif");
    11573. 

  11573. %% #endif
    11574. 

  11574. %% { int i = 2;
    11575. 

  11575. %%   for (; i <=9 ; i++)
    11576. 

  11576. %%     printf("#define value%d  mv_space[%d]\n",i,i-1);
    11577. 

  11577. %% }
    11578. 

  11578. 

  11579. #ifdef DEBUG_GCSAFETY
    11580. 

  11580.   /* Add support for the 'mv_space' expression to the GCTRIGGER1/2/... macros. */
    11581. 

  11581.   inline void inc_allocstamp (object (&mvsp)[mv_limit-1]) {
    11582. 

  11582.     inc_allocstamp(value1);
    11583. 

  11583.     var uintC count = mv_count;
    11584. 

  11584.     if (count > 1) {
    11585. 

  11585.       var object* mvp = &mv_space[1];
    11586. 

  11586.       dotimespC(count,count-1, { inc_allocstamp(*mvp++); });
    11587. 

  11587.     }
    11588. 

  11588.   }
    11589. 

  11589. #endif
    11590. 

  11590. 

  11591. /* Returns the bottom objects from the STACK as multiple values.
    11592. 

  11592.  STACK_to_mv(count)
    11593. 

  11593.  count: number of objects, < mv_limit. */
    11594. 

  11594. #if !defined(VALUE1_EXTRA)
    11595. 

  11595.   #define STACK_to_mv(countx)                                   \
    11596. 

  11596.     do { var uintC count = (countx);                            \
    11597. 

  11597.       mv_count = count;                                         \
    11598. 

  11598.       if (count == 0) value1 = NIL;                             \
    11599. 

  11599.       else { /* pointer behind space for last value               */\
    11600. 

  11600.        object* mvp = &mv_space[count];                          \
    11601. 

  11601.        dotimespC(count,count, { *--mvp = popSTACK(); } );       \
    11602. 

  11602.     }  } while(0)
    11603. 

  11603. #else
    11604. 

  11604.   #define STACK_to_mv(countx)                                   \
    11605. 

  11605.     do { var uintC count = (countx);                            \
    11606. 

  11606.       mv_count = count;                                         \
    11607. 

  11607.       if (count == 0) value1 = NIL;                             \
    11608. 

  11608.       else {                                                    \
    11609. 

  11609.         count--;                                                \
    11610. 

  11610.         if (count > 0) { /* pointer behind space for last value   */\
    11611. 

  11611.           object* mvp = &mv_space[1+count];                     \
    11612. 

  11612.           dotimespC(count,count, { *--mvp = popSTACK(); } );    \
    11613. 

  11613.         }                                                       \
    11614. 

  11614.         value1 = popSTACK();                                    \
    11615. 

  11615.     }  } while(0)
    11616. 

  11616. #endif
    11617. 

  11617. /* is used by EVAL, CONTROL */
    11618. 

  11618. %% export_def(STACK_to_mv(countx));
    11619. 

  11619. 

  11620. /* Puts all values onto the STACK.
    11621. 

  11621.  mv_to_STACK()
    11622. 

  11622.  > mv_count/mv_space : values
    11623. 

  11623.  < values on the Stack (first value on top)
    11624. 

  11624.  STACK-Overflow is checked.
    11625. 

  11625.  modifies STACK */
    11626. 

  11626. #if !defined(VALUE1_EXTRA)
    11627. 

  11627.   #define mv_to_STACK()                                         \
    11628. 

  11628.     do { var uintC count = mv_count;                            \
    11629. 

  11629.          if (count!=0) { /* no values-> nothing onto the STACK    */\
    11630. 

  11630.            var object* mvp = &mv_space[0];                      \
    11631. 

  11631.            get_space_on_STACK(count);                           \
    11632. 

  11632.            dotimespC(count,count, { pushSTACK(*mvp++); } );     \
    11633. 

  11633.     }  } while(0)
    11634. 

  11634. #else
    11635. 

  11635.   #define mv_to_STACK()                                         \
    11636. 

  11636.     do { var uintC count = mv_count;                            \
    11637. 

  11637.          if (count!=0) { /* no values -> nothing onto the STACK   */\
    11638. 

  11638.            get_space_on_STACK(count);                           \
    11639. 

  11639.            pushSTACK(value1);                                   \
    11640. 

  11640.            count--;                                             \
    11641. 

  11641.            if (count > 0) {                                     \
    11642. 

  11642.              var object* mvp = &mv_space[1];                    \
    11643. 

  11643.              dotimespC(count,count, { pushSTACK(*mvp++); } );   \
    11644. 

  11644.            }                                                    \
    11645. 

  11645.     }  } while(0)
    11646. 

  11646. #endif
    11647. 

  11647. /* is used by EVAL, CONTROL */
    11648. 

  11648. 

  11649. /* Returns the elements of a list as multiple values.
    11650. 

  11650.  list_to_mv(list,error_statement)
    11651. 

  11651.  error_statement: if there's an error (too many values). */
    11652. 

  11652. #define NEXT_MV  *mvp++ = Car(l); l = Cdr(l); count++
    11653. 

  11653. #if !defined(VALUE1_EXTRA)
    11654. 

  11654.   #define list_to_mv(lst,error_statement)                               \
    11655. 

  11655.     do { var object l = (lst);                                          \
    11656. 

  11656.      var uintC count = 0;                                               \
    11657. 

  11657.      if (atomp(l)) value1 = NIL;                                        \
    11658. 

  11658.      else {                                                             \
    11659. 

  11659.        var object* mvp = &mv_space[0];                                  \
    11660. 

  11660.        NEXT_MV; if (atomp(l)) goto mv_done;                             \
    11661. 

  11661.        NEXT_MV; if (atomp(l)) goto mv_done;                             \
    11662. 

  11662.        NEXT_MV; if (atomp(l)) goto mv_done;                             \
    11663. 

  11663.        do { if (count==mv_limit-1) { error_statement; } NEXT_MV;        \
    11664. 

  11664.        } while (consp(l));                                              \
    11665. 

  11665.      }                                                                  \
    11666. 

  11666.      mv_done:                                                           \
    11667. 

  11667.      if (!nullp(l)) error_proper_list_dotted(S(values_list),l);         \
    11668. 

  11668.      mv_count = count;                                                  \
    11669. 

  11669.     } while(0)
    11670. 

  11670. #else
    11671. 

  11671.   #define list_to_mv(lst,error_statement)                               \
    11672. 

  11672.     do { var object l = (lst);                                          \
    11673. 

  11673.      var uintC count = 0;                                               \
    11674. 

  11674.      if (atomp(l)) value1 = NIL;                                        \
    11675. 

  11675.      else {                                                             \
    11676. 

  11676.        value1 = Car(l); l = Cdr(l); count++; if (atomp(l)) goto mv_done; \
    11677. 

  11677.        {var object* mvp = &mv_space[1];                                 \
    11678. 

  11678.         NEXT_MV; if (atomp(l)) goto mv_done;                            \
    11679. 

  11679.         NEXT_MV; if (atomp(l)) goto mv_done;                            \
    11680. 

  11680.         do { if (count==mv_limit-1) { error_statement; } NEXT_MV;       \
    11681. 

  11681.         } while (consp(l));                                             \
    11682. 

  11682.      }}                                                                 \
    11683. 

  11683.      mv_done:                                                           \
    11684. 

  11684.      if (!nullp(l)) error_proper_list_dotted(S(values_list),l);         \
    11685. 

  11685.      mv_count = count;                                                  \
    11686. 

  11686.     } while(0)
    11687. 

  11687. #endif
    11688. 

  11688. /* is used by EVAL, CONTROL */
    11689. 

  11689. 

  11690. /* Gives the list of the multiple values on -(STACK).
    11691. 

  11691.  mv_to_list()
    11692. 

  11692.  can trigger GC */
    11693. 

  11693. #define mv_to_list()                                                  \
    11694. 

  11694.   do {                                                                \
    11695. 

  11695.     mv_to_STACK(); /* at first all values onto the stack                */\
    11696. 

  11696.     GCTRIGGER();                                                      \
    11697. 

  11697.     pushSTACK(NIL); /* head of the list                                 */\
    11698. 

  11698.     { var uintC count;                                                \
    11699. 

  11699.       dotimesC(count,mv_count, { /* until all values have been used:    */\
    11700. 

  11700.         var object l = allocate_cons(); /* new cell                     */\
    11701. 

  11701.         Cdr(l) = popSTACK(); /* list so far                             */\
    11702. 

  11702.         Car(l) = STACK_0; /* next value                                 */\
    11703. 

  11703.         STACK_0 = l; /* save new cons                                   */\
    11704. 

  11704.       });                                                             \
    11705. 

  11705.   } } while(0)
    11706. 

  11706. /* is used by EVAL, CONTROL, DEBUG */
    11707. 

  11707. 

  11708. /* Error message if there are too many values
    11709. 

  11709.  error_mv_toomany(caller);
    11710. 

  11710.  > caller: caller, a Symbol */
    11711. 

  11711. nonreturning_function(extern, error_mv_toomany, (object caller));
    11712. 

  11712. /* is used by EVAL, CONTROL, LISPARIT */
    11713. 

  11713. %% #if notused
    11714. 

  11714. %% puts("nonreturning_function(extern, error_mv_toomany, (object caller));");
    11715. 

  11715. %% #endif
    11716. 

  11716. 

  11717. #if !defined(back_trace_register)
    11718. 

  11718.   extern per_thread p_backtrace_t back_trace;
    11719. 

  11719. #else
    11720. 

  11720.   register p_backtrace_t back_trace __asm__(back_trace_register);
    11721. 

  11721. #endif
    11722. 

  11722. #define subr_self  back_trace->bt_function
    11723. 

  11723. %% #if !defined(back_trace_register)
    11724. 

  11724. %%   puts("extern p_backtrace_t back_trace;");
    11725. 

  11725. %% #else
    11726. 

  11726. %%   puts("#ifndef IN_MODULE_CC");
    11727. 

  11727. %%   printf("register p_backtrace_t back_trace __asm__(\"%s\");\n",back_trace_register);
    11728. 

  11728. %%   puts("#endif");
    11729. 

  11729. %% #endif
    11730. 

  11730. %% export_def(subr_self);
    11731. 

  11731. 

  11732. /* Within the body of a SUBR: Access to the arguments.
    11733. 

  11733.  A SUBR with a fixed number of arguments can access them through the STACK:
    11734. 

  11734.    STACK_0 = last argument, STACK_1 = second to last argument etc.
    11735. 

  11735.    Clean STACK: with skipSTACK(number of arguments) .
    11736. 

  11736.  A SUBR with arbitrarily many arguments (&REST-Parameter) gets passed:
    11737. 

  11737.      uintC argcount                    the number of the remaining arguments
    11738. 

  11738.      gcv_object_t* rest_args_pointer   Pointer above the remaining arguments
    11739. 

  11739.    Additionally:
    11740. 

  11740.      gcv_object_t* args_end_pointer    Pointer below all arguments, depends on the STACK
    11741. 

  11741.    Additionally possible:
    11742. 

  11742.      gcv_object_t* args_pointer = rest_args_pointer STACKop (fixed number of arguments);
    11743. 

  11743.                                        Pointer above the first argument
    11744. 

  11744.    Typical Loop-Processing:
    11745. 

  11745.      from the front:
    11746. 

  11746.        while (argcount != 0) {
    11747. 

  11747.          var object arg = NEXT(rest_args_pointer); ...; argcount--;
    11748. 

  11748.        }
    11749. 

  11749.        while (rest_args_pointer != args_end_pointer) {
    11750. 

  11750.          var object arg = NEXT(rest_args_pointer); ...;
    11751. 

  11751.        }
    11752. 

  11752.      from the back:
    11753. 

  11753.        while (argcount != 0) {
    11754. 

  11754.          var object arg = BEFORE(args_end_pointer); ...; argcount--;
    11755. 

  11755.        }
    11756. 

  11756.        while (rest_args_pointer != args_end_pointer) {
    11757. 

  11757.          var object arg = BEFORE(args_end_pointer); ...;
    11758. 

  11758.        }
    11759. 

  11759.    The macros NEXT and BEFORE modify their arguments!
    11760. 

  11760.    Clean STACK: with set_args_end_pointer(args_pointer)
    11761. 

  11761.      or skipSTACK((fixed number of arguments) + (uintL) (number of remainung arguments)) . */
    11762. 

  11762. #define args_end_pointer  STACK
    11763. 

  11763. #define set_args_end_pointer(new_args_end_pointer)  \
    11764. 

  11764.   setSTACK(STACK = (new_args_end_pointer))
    11765. 

  11765. #ifdef STACK_DOWN
    11766. 

  11766.   #define NEXT(argpointer)  (*(--(argpointer)))
    11767. 

  11767.   #define BEFORE(argpointer)  (*((argpointer)++))
    11768. 

  11768. #endif
    11769. 

  11769. #ifdef STACK_UP
    11770. 

  11770.   #define NEXT(argpointer)  (*((argpointer)++))
    11771. 

  11771.   #define BEFORE(argpointer)  (*(--(argpointer)))
    11772. 

  11772. #endif
    11773. 

  11773. /* Next(pointer) yields the same value as NEXT(pointer),
    11774. 

  11774.  but without changing the value of pointer.
    11775. 

  11775.  Before(pointer) yields the same value as BEFORE(pointer),
    11776. 

  11776.  but without changing the value of pointer. */
    11777. 

  11777. #define Next(pointer)  (*(STACKpointable(pointer) STACKop -1))
    11778. 

  11778. #define Before(pointer)  (*(STACKpointable(pointer) STACKop 0))
    11779. 

  11779. %% emit_define("args_end_pointer","STACK");
    11780. 

  11780. %% #if notused
    11781. 

  11781. %% emit_define("set_args_end_pointer(new_args_end_pointer)","STACK = (new_args_end_pointer)");
    11782. 

  11782. %% export_def(NEXT(argpointer));
    11783. 

  11783. %% export_def(BEFORE(argpointer));
    11784. 

  11784. %% emit_define("Next(pointer)","(*(STACKpointable(pointer) STACKop -1))");
    11785. 

  11785. %% emit_define("Before(pointer)","(*(STACKpointable(pointer) STACKop 0))");
    11786. 

  11786. %% #endif
    11787. 

  11787. 

  11788. /* Environments: */
    11789. 

  11789. 

  11790. typedef struct {
    11791. 

  11791.   object var_env;   /* Variable-Bindings-Environment */
    11792. 

  11792.   object fun_env;   /* Function-Bindings-Environment */
    11793. 

  11793.   object block_env; /* Block-Environment */
    11794. 

  11794.   object go_env;    /* Tagbody/Go-Environment */
    11795. 

  11795.   object decl_env;  /* Declarations-Environment */
    11796. 

  11796. } environment_t;
    11797. 

  11797. typedef struct {
    11798. 

  11798.   gcv_object_t var_env;   /* Variable-Bindings-Environment */
    11799. 

  11799.   gcv_object_t fun_env;   /* Function-Bindings-Environment */
    11800. 

  11800.   gcv_object_t block_env; /* Block-Environment */
    11801. 

  11801.   gcv_object_t go_env;    /* Tagbody/Go-Environment */
    11802. 

  11802.   gcv_object_t decl_env;  /* Declarations-Environment */
    11803. 

  11803. } gcv_environment_t;
    11804. 

  11804. 

  11805. /* The current Environment: */
    11806. 

  11806. extern per_thread gcv_environment_t aktenv;
    11807. 

  11807. 

  11808. /* Macro: Puts five single Environments on the STACK
    11809. 

  11809.  and makes a single Environment out of them.
    11810. 

  11810.  make_STACK_env(venv,fenv,benv,genv,denv, env5 = );
    11811. 

  11811.  > object venv,fenv,benv,genv,denv: 5 single Environments
    11812. 

  11812.  < gcv_environment_t* env5: pointer to the Environment on the Stack */
    11813. 

  11813. #ifdef STACK_UP
    11814. 

  11814.   #define make_STACK_env(venv,fenv,benv,genv,denv,env5_assignment)      \
    11815. 

  11815.     do { pushSTACK(venv); pushSTACK(fenv); pushSTACK(benv);             \
    11816. 

  11816.          pushSTACK(genv); pushSTACK(denv);                              \
    11817. 

  11817.          env5_assignment &STACKblock_(gcv_environment_t,0); } while(0)
    11818. 

  11818. #endif
    11819. 

  11819. #ifdef STACK_DOWN
    11820. 

  11820.   #define make_STACK_env(venv,fenv,benv,genv,denv,env5_assignment)      \
    11821. 

  11821.     do { pushSTACK(denv); pushSTACK(genv); pushSTACK(benv);             \
    11822. 

  11822.          pushSTACK(fenv); pushSTACK(venv);                              \
    11823. 

  11823.          env5_assignment &STACKblock_(gcv_environment_t,0); } while(0)
    11824. 

  11824. #endif
    11825. 

  11825. 

  11826. /* Frameinfobits in Frames:
    11827. 

  11827.  in the Frame-Info-Byte (tint): */
    11828. 

  11828. #if (oint_type_len>=7) && 0 /* provisionally?? */
    11829. 

  11829.   /* Bit numbers in the Frame-Info-Byte:
    11830. 

  11830.    occupy Bits 6..0 (resp. Bits 7,5..0 if garcol_bit_t=7). */
    11831. 

  11831.   #ifdef TYPECODES
    11832. 

  11832.     #define FB7  garcol_bit_t
    11833. 

  11833.     #define FB6  (garcol_bit_t>TB5 ? TB5 : TB6)
    11834. 

  11834.     #define FB5  (garcol_bit_t>TB4 ? TB4 : TB5)
    11835. 

  11835.     #define FB4  (garcol_bit_t>TB3 ? TB3 : TB4)
    11836. 

  11836.     #define FB3  (garcol_bit_t>TB2 ? TB2 : TB3)
    11837. 

  11837.     #define FB2  (garcol_bit_t>TB1 ? TB1 : TB2)
    11838. 

  11838.     #define FB1  (garcol_bit_t>TB0 ? TB0 : TB1)
    11839. 

  11839.   #else
    11840. 

  11840.     #define FB7  garcol_bit_o
    11841. 

  11841.     #define FB6  30
    11842. 

  11842.     #define FB5  29
    11843. 

  11843.     #define FB4  28
    11844. 

  11844.     #define FB3  27
    11845. 

  11845.     #define FB2  26
    11846. 

  11846.     #define FB1  25
    11847. 

  11847.   #endif
    11848. 

  11848.   /* depending on it: */
    11849. 

  11849.   #define frame_bit_t    FB7  /* garcol_bit as FRAME-identifier */
    11850. 

  11850.   #define skip2_bit_t    FB6  /* unset if GC has to skip two longwords */
    11851. 

  11851.   #define unwind_bit_t   FB5  /* set if there's something to do while */
    11852. 

  11852.                               /* unwinding the frame */
    11853. 

  11853.   /* skip2-Bit=1 ==> unwind-Bit=1.
    11854. 

  11854.    for further Information within the Frames with skip2-Bit=1: */
    11855. 

  11855.   #define envbind_bit_t  FB4  /* Bit set for ENV-Frames. */
    11856. 

  11856.                               /* Bit is unset for DYNBIND-Frames. */
    11857. 

  11857.   /* for further identification of the ENV-Frames: */
    11858. 

  11858.   #define envbind_case_mask_t  (bit(FB3)|bit(FB2)|bit(FB1))
    11859. 

  11859.   /* for further discrimination within the Frames with skip2-Bit=0: */
    11860. 

  11860.   #define entrypoint_bit_t  FB4  /* Bit is set, if FRAME contains */
    11861. 

  11861.   /* a non-local entrypoint, with Offset SP_, SP is on the STACK.
    11862. 

  11862.    Bit is unset for VAR/FUN-Frame and CALLBACK-Frame.
    11863. 

  11863.    for further discrimination in BLOCK/TAGBODY/APPLY/EVAL/CATCH/UNWIND_PROTECT/HANDLER/DRIVER: */
    11864. 

  11864.   #define blockgo_bit_t    FB3  /* Bit set for BLOCK- and TAGBODY-FRAME */
    11865. 

  11865.   /* for further discrimination in BLOCK/TAGBODY: */
    11866. 

  11866.   #define cframe_bit_t     FB1  /* set for compiled BLOCK/TAGBODY-Frames, */
    11867. 

  11867.                                 /* unset for interpreted BLOCK/TAGBODY-Frames */
    11868. 

  11868.   #define nested_bit_t unwind_bit_t /* set for IBLOCK and ITAGBODY, */
    11869. 

  11869.                                     /* if Exitpoint resp. Tags were nested */
    11870. 

  11870.   /* for further discrimination in APPLY/EVAL/CATCH/UNWIND_PROTECT/HANDLER/DRIVER: */
    11871. 

  11871.   #define dynjump_bit_t  FB2    /* unset for APPLY and EVAL, set */
    11872. 

  11872.                                 /* for CATCH/UNWIND_PROTECT/DRIVER-Frames */
    11873. 

  11873.   #define trapped_bit_t unwind_bit_t /* set for APPLY and EVAL, if */
    11874. 

  11874.                                 /* interrupted while unwinding the Frame */
    11875. 

  11875.   /* unwind-Bit set for UNWIND_PROTECT/DRIVER/TRAPPED_APPLY/TRAPPED_EVAL,
    11876. 

  11876.    else unset. */
    11877. 

  11877.   #define eval_bit_t     FB1    /* set for EVAL-Frames, */
    11878. 

  11878.                                 /* unset for APPLY-Frames */
    11879. 

  11879.   #define driver_bit_t   FB1    /* set for DRIVER-Frames, */
    11880. 

  11880.                                 /* unset for UNWIND_PROTECT-Frames */
    11881. 

  11881.   #define handler_bit_t  FB1    /* set for HANDLER-Frames, */
    11882. 

  11882.                                 /* unset for CATCH-Frames */
    11883. 

  11883.   /* for further discrimination in VAR/FUN/CALLBACK: */
    11884. 

  11884.   #define callback_bit_t   FB3  /* Bit is unset for CALLBACK-Frames. */
    11885. 

  11885.                                 /* Bit is set for VAR/FUN-Frames. */
    11886. 

  11886.   /* for further discrimination in VAR/FUN: */
    11887. 

  11887.   #define fun_bit_t      FB2    /* set for FUN-Frame, unset for VAR-Frame */
    11888. 

  11888.   /* on objects on the STACK (oint): */
    11889. 

  11889.   #define      frame_bit_o      (frame_bit_t+oint_type_shift)
    11890. 

  11890.   #define      skip2_bit_o      (skip2_bit_t+oint_type_shift)
    11891. 

  11891.   #define     unwind_bit_o     (unwind_bit_t+oint_type_shift)
    11892. 

  11892.   #define    envbind_bit_o    (envbind_bit_t+oint_type_shift)
    11893. 

  11893.   #define   callback_bit_o   (callback_bit_t+oint_type_shift)
    11894. 

  11894.   #define entrypoint_bit_o (entrypoint_bit_t+oint_type_shift)
    11895. 

  11895.   #define    blockgo_bit_o    (blockgo_bit_t+oint_type_shift)
    11896. 

  11896.   #define     cframe_bit_o     (cframe_bit_t+oint_type_shift)
    11897. 

  11897.   #define     nested_bit_o     (nested_bit_t+oint_type_shift)
    11898. 

  11898.   #define    dynjump_bit_o    (dynjump_bit_t+oint_type_shift)
    11899. 

  11899.   #define    trapped_bit_o    (trapped_bit_t+oint_type_shift)
    11900. 

  11900.   #define       eval_bit_o       (eval_bit_t+oint_type_shift)
    11901. 

  11901.   #define     driver_bit_o     (driver_bit_t+oint_type_shift)
    11902. 

  11902.   #define    handler_bit_o    (handler_bit_t+oint_type_shift)
    11903. 

  11903.   #define        fun_bit_o        (fun_bit_t+oint_type_shift)
    11904. 

  11904.   /* single Frame-Info-Bytes: */
    11905. 

  11905.   #define DYNBIND_frame_info          /* %1110... */ (bit(FB7)|bit(FB6)|bit(FB5))
    11906. 

  11906.   #define ENV1V_frame_info            /* %1111000 */ (bit(FB7)|bit(FB6)|bit(FB5)|bit(FB4))
    11907. 

  11907.   #define ENV1F_frame_info            /* %1111001 */ (bit(FB7)|bit(FB6)|bit(FB5)|bit(FB4)|bit(FB1))
    11908. 

  11908.   #define ENV1B_frame_info            /* %1111010 */ (bit(FB7)|bit(FB6)|bit(FB5)|bit(FB4)|bit(FB2))
    11909. 

  11909.   #define ENV1G_frame_info            /* %1111011 */ (bit(FB7)|bit(FB6)|bit(FB5)|bit(FB4)|bit(FB2)|bit(FB1))
    11910. 

  11910.   #define ENV1D_frame_info            /* %1111100 */ (bit(FB7)|bit(FB6)|bit(FB5)|bit(FB4)|bit(FB3))
    11911. 

  11911.   #define ENV2VD_frame_info           /* %1111101 */ (bit(FB7)|bit(FB6)|bit(FB5)|bit(FB4)|bit(FB3)|bit(FB1))
    11912. 

  11912.   #define ENV5_frame_info             /* %1111110 */ (bit(FB7)|bit(FB6)|bit(FB5)|bit(FB4)|bit(FB3)|bit(FB2))
    11913. 

  11913.   #ifdef HAVE_SAVED_REGISTERS
    11914. 

  11914.     #define CALLBACK_frame_info         /* %10100.. */ (bit(FB7)|bit(FB5))
    11915. 

  11915.   #endif
    11916. 

  11916.   #define VAR_frame_info              /* %101010. */ (bit(FB7)|bit(FB5)|bit(FB3))
    11917. 

  11917.   #define FUN_frame_info              /* %101011. */ (bit(FB7)|bit(FB5)|bit(FB3)|bit(FB2))
    11918. 

  11918.   #define IBLOCK_frame_info           /* %1001100 */ (bit(FB7)|bit(FB4)|bit(FB3))
    11919. 

  11919.   #define NESTED_IBLOCK_frame_info    /* %1011100 */ (bit(FB7)|bit(FB5)|bit(FB4)|bit(FB3))
    11920. 

  11920.   #define ITAGBODY_frame_info         /* %1001110 */ (bit(FB7)|bit(FB4)|bit(FB3)|bit(FB2))
    11921. 

  11921.   #define NESTED_ITAGBODY_frame_info  /* %1011110 */ (bit(FB7)|bit(FB5)|bit(FB4)|bit(FB3)|bit(FB2))
    11922. 

  11922.   #define CBLOCK_CTAGBODY_frame_info  /* %1011101 */ (bit(FB7)|bit(FB5)|bit(FB4)|bit(FB3)|bit(FB1))
    11923. 

  11923.   #define APPLY_frame_info            /* %1001000 */ (bit(FB7)|bit(FB4))
    11924. 

  11924.   #define TRAPPED_APPLY_frame_info    /* %1011000 */ (bit(FB7)|bit(FB5)|bit(FB4))
    11925. 

  11925.   #define EVAL_frame_info             /* %1001001 */ (bit(FB7)|bit(FB4)|bit(FB1))
    11926. 

  11926.   #define TRAPPED_EVAL_frame_info     /* %1011001 */ (bit(FB7)|bit(FB5)|bit(FB4)|bit(FB1))
    11927. 

  11927.   #define CATCH_frame_info            /* %1001010 */ (bit(FB7)|bit(FB4)|bit(FB2))
    11928. 

  11928.   #define HANDLER_frame_info          /* %1001011 */ (bit(FB7)|bit(FB4)|bit(FB2)|bit(FB1))
    11929. 

  11929.   #define UNWIND_PROTECT_frame_info   /* %1011010 */ (bit(FB7)|bit(FB5)|bit(FB4)|bit(FB2))
    11930. 

  11930.   #define DRIVER_frame_info           /* %1011011 */ (bit(FB7)|bit(FB5)|bit(FB4)|bit(FB2)|bit(FB1))
    11931. 

  11931. #endif
    11932. 

  11932. #if (oint_type_len==6) || 1 /* provisionally?? */
    11933. 

  11933.   /* bit numbers in Frame-Info-Byte:
    11934. 

  11934.    occupy Bits 5..0 (resp. Bits 7,4..0 if garcol_bit_t=7). */
    11935. 

  11935.   #ifdef TYPECODES
    11936. 

  11936.     #define FB6  garcol_bit_t
    11937. 

  11937.     #define FB5  (garcol_bit_t>TB4 ? TB4 : TB5)
    11938. 

  11938.     #define FB4  (garcol_bit_t>TB3 ? TB3 : TB4)
    11939. 

  11939.     #define FB3  (garcol_bit_t>TB2 ? TB2 : TB3)
    11940. 

  11940.     #define FB2  (garcol_bit_t>TB1 ? TB1 : TB2)
    11941. 

  11941.     #define FB1  (garcol_bit_t>TB0 ? TB0 : TB1)
    11942. 

  11942.   #else /* HEAPCODES */
    11943. 

  11943.     #define FB6  garcol_bit_o
    11944. 

  11944.     #ifdef STANDARD_HEAPCODES
    11945. 

  11945.       #define FB5  (garcol_bit_o-1)
    11946. 

  11946.       #define FB4  (garcol_bit_o-2)
    11947. 

  11947.       #define FB3  (garcol_bit_o-3)
    11948. 

  11948.       #define FB2  (garcol_bit_o-4)
    11949. 

  11949.       #define FB1  (garcol_bit_o-5)
    11950. 

  11950.     #endif
    11951. 

  11951.     #ifdef LINUX_NOEXEC_HEAPCODES
    11952. 

  11952.       #define FB5  5
    11953. 

  11953.       #define FB4  4
    11954. 

  11954.       #define FB3  3
    11955. 

  11955.       #define FB2  2
    11956. 

  11956.       #define FB1  1
    11957. 

  11957.     #endif
    11958. 

  11958.   #endif
    11959. 

  11959.   /* depending on it: */
    11960. 

  11960.   #define frame_bit_t    FB6  /* garcol_bit as FRAME-indicator */
    11961. 

  11961.   #define skip2_bit_t    FB5  /* unset if the GC has to skip two long words */
    11962. 

  11962.   /* define unwind_limit_t  ...  # above:
    11963. 

  11963.    if there's something to be done while to unwind a Frame
    11964. 

  11964.    skip2-Bit=1 ==> >= unwind-limit.
    11965. 

  11965.    for further information within the Frames with skip2-Bit=1: */
    11966. 

  11966.   #define envbind_bit_t  FB4  /* Bit is set for ENV-Frames. */
    11967. 

  11967.                               /* Bit unset for DYNBIND-Frames. */
    11968. 

  11968.   /* for further identification within the ENV-Frames: */
    11969. 

  11969.   #define envbind_case_mask_t  (bit(FB3)|bit(FB2)|bit(FB1))
    11970. 

  11970.   /* for further discrimination with the Frames with skip2-Bit=0:
    11971. 

  11971.    define entrypoint_limit_t  ...  # below:
    11972. 

  11972.    if FRAME contains a non-local entry point
    11973. 

  11973.    with Offset SP_ SP is on the STACK.
    11974. 

  11974.    above: for VAR/FUN-Frame and CALLBACK-Frame.
    11975. 

  11975.    for further discrimination in BLOCK/TAGBODY/APPLY/EVAL/CATCH/UNWIND_PROTECT/HANDLER/DRIVER: */
    11976. 

  11976.   #define blockgo_bit_t    FB3  /* Bit set for BLOCK- and TAGBODY-FRAME */
    11977. 

  11977.   /* for further discrimination in BLOCK/TAGBODY: */
    11978. 

  11978.   #define cframe_bit_t   FB4  /* set for compiled, unset for */
    11979. 

  11979.                               /* interpreted BLOCK/TAGBODY-Frames */
    11980. 

  11980.   #define nested_bit_t   FB2  /* set for IBLOCK and ITAGBODY, */
    11981. 

  11981.                               /* if exit point or Tags have been nested */
    11982. 

  11982.   /* for further discrimination in APPLY/EVAL/CATCH/UNWIND_PROTECT/HANDLER/DRIVER: */
    11983. 

  11983.   #define dynjump_bit_t  FB2  /* unset for APPLY and EVAL, set */
    11984. 

  11984.                               /* for CATCH/UNWIND_PROTECT/HANDLER/DRIVER-Frames */
    11985. 

  11985.   #define trapped_bit_t  FB4  /* set for APPLY and EVAL, if interruped while */
    11986. 

  11986.                               /* unwinding the Frames */
    11987. 

  11987.   /* >= unwind_limit_t for UNWIND_PROTECT/DRIVER/TRAPPED_APPLY/TRAPPED_EVAL,
    11988. 

  11988.    < unwind_limit_t else. */
    11989. 

  11989.   #define eval_bit_t     FB1  /* set for EVAL-Frames, */
    11990. 

  11990.                               /* unset for APPLY-Frames */
    11991. 

  11991.   #define driver_bit_t   FB1  /* set for DRIVER-Frames, */
    11992. 

  11992.                               /* unset for UNWIND_PROTECT-Frames */
    11993. 

  11993.   #define handler_bit_t  FB1  /* set for HANDLER-Frames, */
    11994. 

  11994.                               /* unset for CATCH-Frames */
    11995. 

  11995.   /* for further discrimination in VAR/FUN/CALLBACK: */
    11996. 

  11996.   #define callback_bit_t   FB2  /* Bit is unset for CALLBACK-Frames. */
    11997. 

  11997.                                 /* Bit is set for VAR/FUN-Frames. */
    11998. 

  11998.   /* for further discrimination in VAR/FUN: */
    11999. 

  11999.   #define fun_bit_t      FB1  /* set for FUN-Frame, unset for VAR-Frame */
    12000. 

  12000.   /* in Objects on the STACK (oint): */
    12001. 

  12001.   #define    frame_bit_o    (frame_bit_t+oint_type_shift)
    12002. 

  12002.   #define    skip2_bit_o    (skip2_bit_t+oint_type_shift)
    12003. 

  12003.   #define  envbind_bit_o  (envbind_bit_t+oint_type_shift)
    12004. 

  12004.   #define callback_bit_o (callback_bit_t+oint_type_shift)
    12005. 

  12005.   #define  blockgo_bit_o  (blockgo_bit_t+oint_type_shift)
    12006. 

  12006.   #define   cframe_bit_o   (cframe_bit_t+oint_type_shift)
    12007. 

  12007.   #define   nested_bit_o   (nested_bit_t+oint_type_shift)
    12008. 

  12008.   #define  dynjump_bit_o  (dynjump_bit_t+oint_type_shift)
    12009. 

  12009.   #define  trapped_bit_o  (trapped_bit_t+oint_type_shift)
    12010. 

  12010.   #define     eval_bit_o     (eval_bit_t+oint_type_shift)
    12011. 

  12011.   #define   driver_bit_o   (driver_bit_t+oint_type_shift)
    12012. 

  12012.   #define  handler_bit_o  (handler_bit_t+oint_type_shift)
    12013. 

  12013.   #define      fun_bit_o      (fun_bit_t+oint_type_shift)
    12014. 

  12014.   /* single Frame-Info-Bytes: */
    12015. 

  12015.   #define APPLY_frame_info            /* %100000 */ (bit(FB6))
    12016. 

  12016.   #define EVAL_frame_info             /* %100001 */ (bit(FB6)|bit(FB1))
    12017. 

  12017.   #define CATCH_frame_info            /* %100010 */ (bit(FB6)|bit(FB2))
    12018. 

  12018.   #define HANDLER_frame_info          /* %100011 */ (bit(FB6)|bit(FB2)|bit(FB1))
    12019. 

  12019.   #define IBLOCK_frame_info           /* %100100 */ (bit(FB6)|bit(FB3))
    12020. 

  12020.   #define ITAGBODY_frame_info         /* %100101 */ (bit(FB6)|bit(FB3)|bit(FB1))
    12021. 

  12021.   #define unwind_limit_t                            (bit(FB6)|bit(FB3)|bit(FB2))
    12022. 

  12022.   #define NESTED_IBLOCK_frame_info    /* %100110 */ (bit(FB6)|bit(FB3)|bit(FB2))
    12023. 

  12023.   #define NESTED_ITAGBODY_frame_info  /* %100111 */ (bit(FB6)|bit(FB3)|bit(FB2)|bit(FB1))
    12024. 

  12024.   #define TRAPPED_APPLY_frame_info    /* %101000 */ (bit(FB6)|bit(FB4))
    12025. 

  12025.   #define TRAPPED_EVAL_frame_info     
    12026.