home *** CD-ROM | disk | FTP | other *** search
/ Amiga ISO Collection / AmigaUtilCD2.iso / Programming / Misc / CLISP-1.LHA / CLISP960530-sr.lha / src / lispbibl.d < prev    next >
Encoding:
Text File  |  1996-07-21  |  422.9 KB  |  10,729 lines
  1. # Haupt-Include-File für CLISP
  2. # Bruno Haible 23.6.1995
  3. # Marcus Daniels 11.11.1994
  4.  
  5.  
  6. # Implementation ist auf folgende Rechner, Betriebssysteme und C-Compiler
  7. # vorbereitet. (Nur ungefähre Liste, Genaues siehe PLATFORMS.)
  8. # Maschine     Hersteller         Betriebssystem                C-Compiler    erkennbar an
  9. # AMIGA        Commodore          AMIGA-OS (AMIGADOS)           GNU           amiga oder AMIGA, __GNUC__, evtl. MC68000 oder AMIGA3000
  10. # beliebig     beliebig           UNIX                          GNU           unix, __GNUC__, ...
  11. # beliebig     beliebig           UNIX                          CC            unix, ...
  12. # Amiga 3000   Commodore          Amiga UNIX 2.1 SVR4.0         GNU           unix, __unix__, AMIX, __AMIX__, __svr4__, m68k, __m68k__, __motorola__, __GNUC__
  13. # SUN-3        Sun                SUN-OS3 (UNIX BSD 4.2)        GNU           sun, unix, mc68020, __GNUC__
  14. # SUN-3        Sun                SUN-OS4 (UNIX SUNOS 4.1)      GNU           sun, unix, mc68020, __GNUC__
  15. # SUN-386      Sun                SUN-OS4 (UNIX SUNOS 4.0)      GNU           sun, unix, sun386, i386, __GNUC__
  16. # SUN-386      Sun                SUN-OS4 (UNIX SUNOS 4.0)      CC            sun, unix, sun386, i386
  17. # SUN-4        Sun                SUN-OS4 (UNIX SUNOS 4.1)      GNU           sun, unix, sparc, __GNUC__
  18. # SUN-4        Sun                SUN-OS4 (UNIX SUNOS 4.1)      CC            sun, unix, sparc
  19. # SUN-4        Sun                SUN-OS5 (UNIX Solaris)        GCC           sun, unix, sparc, __GNUC__
  20. # IBM-PC/386   beliebig           SUN-OS5 (UNIX Solaris)        GCC           sun, unix, __svr4__, i386, __GNUC__
  21. # HP9000-300   Hewlett-Packard    NetBSD 0.9 (UNIX BSD 4.3)     GNU           unix, __NetBSD__, mc68000, __GNUC__
  22. # HP9000-300   Hewlett-Packard    HP-UX 8.0 (UNIX SYS V)        GNU           [__]hpux, [__]unix, [__]hp9000s300, mc68000, __GNUC__
  23. # HP9000-800   Hewlett-Packard    HP-UX 8.0 (UNIX SYS V)        GNU           [__]hpux, [__]unix, [__]hp9000s800
  24. # IRIS         Silicon Graphics   IRIX (UNIX SYS V 3.2)         GNU           unix, SVR3, mips, sgi, __GNUC__
  25. # IRIS         Silicon Graphics   IRIX (UNIX SYS V)             cc -ansi      [__]unix, [__]SVR3, [__]mips, [__]sgi
  26. # IRIS         Silicon Graphics   IRIX 5 (UNIX SYS V 4)         GNU           [__]unix, [__]SYSTYPE_SVR4, [__]mips, [__]host_mips, [__]MIPSEB, [__]sgi, __DSO__, [__]_MODERN_C, __GNUC__
  27. # DECstation 5000                 RISC/OS (Ultrix V4.2A)        GNU           unix, [__]mips, [__]ultrix
  28. # DG-UX 88k    Data General       DG/UX                         GNU           unix, m88000, DGUX
  29. # DEC Alpha    DEC                OSF/1 1.3                     cc            [unix,] __unix__, __osf__, __alpha
  30. # DEC Alpha    DEC                OSF/1 1.3                     GNU           unix, __unix__, __osf__, __alpha, __alpha__, _LONGLONG
  31. # Apple MacII  Apple              A/UX (UNIX SYS V 2)           GNU           [__]unix, [__]AUX, [__]macII, [__]m68k, mc68020, mc68881, __GNUC__
  32. # NeXT         NeXT               NeXTstep 3.1 (UNIX)           cc            NeXT, m68k; NEXTAPP für NeXTstep-Applikation
  33. # Sequent      Sequent            PTX 3.2.0 V2.1.0 i386 (SYS V) GNU           unix, i386, _SEQUENT_, __GNUC__
  34. # Convex C2    Convex             ConvexOS 10.1                 GNU           __convex__, __GNUC__
  35. # IBM RS/6000  IBM                AIX 3.2                       GNU           _AIX, _AIX32, _IBMR2, __CHAR_UNSIGNED__, __GNUC__
  36. # IBM-PC/386   beliebig           LINUX (freies UNIX)           GNU           unix, linux, i386, __GNUC__
  37. # IBM-PC/386   beliebig           386BSD 0.1 (UNIX BSD 4.2)     GNU           unix, __386BSD__, i386, __GNUC__
  38. # IBM-PC/386   beliebig           NetBSD 0.9 (UNIX BSD 4.3)     GNU           unix, __NetBSD__, i386, __GNUC__
  39. # IBM-PC/386   beliebig           DJUNIX (UNIXlike auf MSDOS)   GNU           unix, i386, [__MSDOS__,] __GNUC__, __GO32__; __GO32__ muß man evtl. selbst definieren!
  40. # IBM-PC/386   beliebig           EMX (UNIXlike auf MSDOS)      GNU           [unix,] i386, __GNUC__, __EMX__
  41. # IBM-PC/386   beliebig           EMX (UNIXlike auf OS/2)       GNU           [unix,] i386, __GNUC__, __EMX__, OS2; OS2 muß man selbst definieren!
  42. # IBM-PC/386   beliebig           MSDOS + MS Windows 3.1 + RSX  GNU           [unix,] i386, __GNUC__, __EMX__, WINDOWS; WINDOWS muß man selbst definieren!
  43. # IBM-PC/386   beliebig           MSDOS                         WATCOM        MSDOS, __386__, M_I386, __WATCOMC__, __FLAT__
  44. # IBM-PC/386   beliebig           MSDOS + MS Windows 3.1        WATCOM        __WINDOWS_386__, __386__, M_I386, __WATCOMC__, __FLAT__
  45. # RM400        Siemens-Nixdorf    SINIX-N 5.42                  c89           unix, mips, MIPSEB, host_mips, sinix, SNI, _XPG_IV
  46. # Acorn        Risc PC            RISC OS 3.x                   GNU           [__]arm, [__]riscos, __GNUC__
  47. # Acorn        Risc PC            RISC OS 3.x                   Norcroft      [__]arm, [__]riscos
  48. # APPLE IIGS   Apple              ??                            ??
  49. # Für ANSI-C-Compiler: verwende Präprozessoren comment5, ansidecl.
  50. # Für traditionelle C-Compiler: verwende Präprozessoren comment5, traddecl
  51. #   und evtl. gcc-cpp, ccpaux, deelif, deerror und mergestrings.
  52.  
  53.  
  54. # diese Maschine: AMIGA oder DOSPC oder ACORN oder GENERIC_UNIX
  55. #if (defined(__unix) || defined(sinix)) && !defined(unix)
  56.   #define unix
  57. #endif
  58. #if (defined(amiga) || defined(AMIGA))
  59.   #undef AMIGA
  60.   #define AMIGA
  61. #endif
  62. #if (defined(arm) || defined(__arm)) && (defined(riscos) || defined(__riscos))
  63.   #define ACORN
  64. #endif
  65. #if (defined(i386) && defined(__EMX__)) || defined(__GO32__) || (defined(__386__) && defined(__WATCOMC__) && (defined(MSDOS) || defined(__WINDOWS_386__))) || (defined(__WINNT__) && !defined(__CYGWIN32__))
  66.   #define DOSPC
  67. #endif
  68. #if !(defined(AMIGA) || defined(DOSPC) || defined(ACORN))
  69.   #if defined(unix)
  70.     #define GENERIC_UNIX
  71.   #elif defined(__CYGWIN32__)
  72.     #define WIN32_UNIX
  73.   #else
  74.     #error "Unknown machine type -- Maschine neu einstellen!"
  75.   #endif
  76. #endif
  77. # Zusätzliche Spezifikation der Maschine:
  78. #ifdef DOSPC
  79.   #define PC386 # IBMPC-Kompatibler mit 80386/80486-Prozessor
  80. #endif
  81. #ifdef GENERIC_UNIX
  82.   #if (defined(sun) && defined(unix) && defined(sun386))
  83.     #define SUN386
  84.   #endif
  85.   #if (defined(unix) && defined(linux) && defined(i386))
  86.     #define PC386
  87.   #endif
  88.   #if (defined(sun) && defined(unix) && defined(mc68020))
  89.     #define SUN3
  90.   #endif
  91.   #if (defined(sun) && defined(unix) && defined(sparc))
  92.     #define SUN4
  93.     # evtl. SUN4_29 falls nur Adressen <2^29 unterstützt werden.
  94.   #endif
  95.   #if defined(hp9000s800) || defined(__hp9000s800)
  96.     #define HP8XX
  97.   #endif
  98. #endif
  99.  
  100. # Auswahl des Prozessors:
  101. # MC680X0 == alle Prozessoren der Motorola-68000-Serie
  102. # MC680Y0 == alle Prozessoren der Motorola-68000-Serie ab MC68020
  103. # SPARC == der Sun-SPARC-Prozessor
  104. # HPPA == alle Prozessoren der HP-Precision-Architecture
  105. # MIPS == der Mips-Prozessor
  106. # M88000 == alle Prozessoren der Motorola-88000-Serie
  107. # RS6000 == der IBM-RS/6000-Prozessor
  108. # I80X86 == alle Prozessoren der Intel-8086-Serie
  109. # I80Y86 == alle Prozessoren der Intel-8086-Serie ab 80286
  110. # I80Z86 == alle Prozessoren der Intel-8086-Serie ab 80386
  111. # VAX == der VAX-Prozessor
  112. # CONVEX == der Convex-Prozessor
  113. # ARM == der ARM-Prozessor
  114. # DECALPHA == der DEC-Alpha-Chip
  115. #ifdef AMIGA
  116.   #define MC680X0
  117.   #if defined(AMIGA3000) && !defined(MC680Y0)
  118.     #define MC680Y0
  119.   #endif
  120. #endif
  121. #ifdef DOSPC
  122.   #define I80X86
  123.   #define I80Y86
  124.   #define I80Z86
  125. #endif
  126. #if 0
  127.   #define VAX
  128. #endif
  129. #if defined(arm) || defined(__arm)
  130.   #define ARM
  131. #endif
  132. #if defined(GENERIC_UNIX) || defined(WIN32_UNIX)
  133.   #if defined(m68k) || defined(mc68000)
  134.     #define MC680X0
  135.   #endif
  136.   #if defined(mc68020) || (defined(m68k) && defined(NeXT))
  137.     #define MC680X0
  138.     #define MC680Y0
  139.   #endif
  140.   #if defined(i386) || defined(__i386) || defined(_I386)
  141.     #define I80X86
  142.     #define I80Y86
  143.     #define I80Z86
  144.   #endif
  145.   #ifdef sparc
  146.     #define SPARC
  147.   #endif
  148.   #if defined(mips) || defined(__mips)
  149.     #define MIPS
  150.   #endif
  151.   #if defined(HP8XX) || defined(hppa) || defined(__hppa)
  152.     #define HPPA
  153.   #endif
  154.   #ifdef m88000
  155.     #define M88000
  156.   #endif
  157.   #ifdef _IBMR2
  158.     #define RS6000
  159.   #endif
  160.   #ifdef __convex__
  161.     #define CONVEX
  162.   #endif
  163.   #ifdef __alpha
  164.     #define DECALPHA
  165.   #endif
  166. #endif
  167.  
  168.  
  169. # Auswahl des Betriebssystems:
  170. #ifdef AMIGA
  171.   #define AMIGAOS
  172. #endif
  173. #if (defined(riscos) || defined(__riscos)) && !defined(unix)
  174.   #define RISCOS  # Acorn RISC OS
  175.   #ifndef __GNUC__
  176.     #define RISCOS_CCBUG  # Bug in Norcrofts C-Compiler umgehen
  177.   #endif
  178.   #define ACORN_1  # Typcode "oben"
  179.   # define ACORN_2  # Typcode "unten"
  180. #endif
  181. #ifdef GENERIC_UNIX
  182.   #define UNIX
  183.   #ifdef linux
  184.     #define UNIX_LINUX  # Linux (Linus Torvalds Unix)
  185.   #endif
  186.   #if defined(hpux) || defined(__hpux)
  187.     #define UNIX_HPUX  # HP-UX
  188.   #endif
  189.   #if defined(SVR3) || defined(__SVR3) || defined(SVR4) || defined(__SVR4) || defined(SYSTYPE_SVR4) || defined(__SYSTYPE_SVR4) || defined(__svr4__) || defined(USG) || defined(UNIX_HPUX) # ??
  190.     #define UNIX_SYSV  # UNIX System V
  191.   #endif
  192.   #if defined(UNIX_SYSV) && (defined(sgi) || defined(__sgi))
  193.     #define UNIX_IRIX  # Irix
  194.     #if defined(SYSTYPE_SVR4) || defined(__SYSTYPE_SVR4)
  195.       #define UNIX_IRIX5  # Irix 5
  196.     #endif
  197.   #endif
  198.   #if defined(MIPS) && (defined(ultrix) || defined(__ultrix))
  199.     #define UNIX_DEC_ULTRIX  # DEC's (oder IBM's ?) RISC/OS Ultrix auf DEC MIPS
  200.     #ifdef __GNUC__
  201.       #define UNIX_DEC_ULTRIX_GCCBUG  # GCC 2.3.3 Bug umgehen
  202.     #endif
  203.   #endif
  204.   #if defined(USL) # defined(__svr4__) && defined(i386) && ??
  205.     # Eine Reihe von 386er Unixen (alle unter verschiedenem Namen) stammen
  206.     # von USL SysV R 4 ab:
  207.     #   386 UHC UNIX System V release 4
  208.     #   Consensys System V 4.2
  209.     #   Onsite System V 4.2
  210.     #   SINIX-Z
  211.     #define UNIX_SYSV_USL  # Unix System V R 4 von der AT&T-Tochter USL
  212.     #define UNIX_SYSV_UHC_1 # Behandlung analog HPPA && UNIX_HPUX
  213.     # define UNIX_SYSV_UHC_2 # Behandlung analog AMIGA3000 - langsamer
  214.     #ifdef SNI
  215.       #define UNIX_SINIX # Siemens is nix
  216.     #endif
  217.   #endif
  218.   #ifdef _SEQUENT_
  219.     #define UNIX_SYSV_PTX
  220.   #endif
  221.   #ifdef _AIX
  222.     #define UNIX_AIX  # IBM AIX
  223.   #endif
  224.   #ifdef DGUX
  225.     #define UNIX_DGUX  # Data General DG/UX
  226.   #endif
  227.   #ifdef __osf__
  228.     #define UNIX_OSF  # OSF/1
  229.   #endif
  230.   #ifdef AUX
  231.     #define UNIX_AUX  # Apple A/UX, ein aufgepäppeltes SVR2
  232.   #endif
  233.   #ifdef NeXT
  234.     #define UNIX_NEXTSTEP  # NeXTstep
  235.     # define NEXTAPP       # Definiere dies, um eine NeXTstep-GUI-Applikation
  236.                            # zu bekommen.
  237.     #define MAYBE_NEXTAPP  # kleiner Hack, damit die .mem Files zwischen
  238.                            # clisp mit NEXTAPP und ohne NEXTAPP kompatibel sind
  239.   #endif
  240.   #ifdef AMIX
  241.     #define UNIX_AMIX  # Amiga UNIX
  242.   #endif
  243.   #ifdef __convex__
  244.     #define UNIX_CONVEX  # ConvexOS
  245.   #endif
  246. #endif
  247. #ifdef DOSPC
  248.   #undef MSDOS  # wg. WATCOM
  249.   #define MSDOS
  250.   #ifdef __EMX__
  251.     #define EMUNIX  # UNIX-Emulation auf MSDOS/OS2-Basis von Eberhard Mattes
  252.     #if defined(OS2)
  253.       #define EMUNIX_PORTABEL # ob wir eine zwischen MSDOS und OS2 portable Version machen
  254.     #endif
  255.     # EMUNIX_OLD_8d steht für emx <= 0.8d, EMUNIX_NEW_8e steht für emx >= 0.8e
  256.     # EMUNIX_OLD_8e steht für emx <= 0.8e, EMUNIX_NEW_8f steht für emx >= 0.8f
  257.     # EMUNIX_OLD_8f steht für emx <= 0.8f, EMUNIX_NEW_8g steht für emx >= 0.8g
  258.     # EMUNIX_OLD_8g steht für emx <= 0.8g, EMUNIX_NEW_8h steht für emx >= 0.8h
  259.     # EMUNIX_OLD_8h steht für emx <= 0.8h, EMUNIX_NEW_9a steht für emx >= 0.9a
  260.   #endif
  261.   #ifdef __GO32__
  262.     #define DJUNIX  # UNIX-Emulation auf MSDOS-Basis von D.J. Delorie
  263.   #endif
  264.   #ifdef __WATCOMC__
  265.     #define WATCOM  # Bibliotheksfunktionen von WATCOM C
  266.     #ifdef __WINDOWS_386__
  267.       #define WINDOWS
  268.     #endif
  269.   #endif
  270.   #ifdef __WINNT__
  271.    #define WIN32_WINDOWS
  272.    #define WIN32_DOS
  273.   #ifdef _MSC_VER
  274.     #define MICROSOFT
  275.   #endif
  276.   #endif
  277.   # WINDOWS ist definiert, wenn wir für MS Windows 3.1 compilieren
  278. #endif
  279. #ifdef WIN32_UNIX
  280.   #define WIN32_WINDOWS 
  281. #endif
  282.  
  283.  
  284. # Eigenschaften von Compiler und Umgebung abfragen:
  285. #if defined(UNIX) || defined(WIN32_UNIX)
  286.   #include "config.h"  # von configure erzeugte Konfiguration
  287.   #include "machine.h"   # von machine erzeugte Integertyp-Charakteristika
  288.   #ifdef WIN32_UNIX
  289.     #undef VOID_CLOSEDIR
  290.     #undef HAVE_READLINK
  291.   #endif
  292. #elif defined(AMIGA) || defined(DOSPC) || defined(ACORN)
  293.   #ifdef WIN32_DOS
  294.     #include "config.h"  # von configure erzeugte Konfiguration
  295.     #undef CODE_ADDRESS_RANGE
  296.     #undef MALLOC_ADDRESS_RANGE
  297.     #undef SHLIB_ADDRESS_RANGE
  298.   #endif  
  299.   #define char_bitsize 8
  300.   #define short_bitsize 16
  301.   #if defined(DOSPC) || defined(ACORN)
  302.     #define int_bitsize 32
  303.   #else
  304.     #define int_bitsize 0 # wird nicht benötigt
  305.   #endif
  306.   #define long_bitsize 32
  307.   #ifdef __GNUC__
  308.     #if (__GNUC__ >= 2) # GCC 2 hat inzwischen funktionierenden `long long' Typ
  309.       #ifndef HAVE_LONGLONG  # (e.g. MSDOS)
  310.         #define HAVE_LONGLONG
  311.       #endif
  312.       #define long_long_bitsize 64
  313.     #endif
  314.   #endif
  315.   #define pointer_bitsize 32
  316.   #ifdef MC680X0
  317.     #define short_big_endian
  318.     #define long_big_endian
  319.   #endif
  320.   #if defined(I80X86) || defined(VAX) || defined(ARM)
  321.     #define short_little_endian
  322.     #define long_little_endian
  323.   #endif
  324.   #define stack_grows_down
  325.   #define CODE_ADDRESS_RANGE 0
  326.   #define MALLOC_ADDRESS_RANGE 0
  327.   #define SHLIB_ADDRESS_RANGE 0
  328. #endif
  329.  
  330.  
  331. # Genauere Klassifikation des Betriebssystems:
  332.   #if defined(UNIX) && defined(SIGNALBLOCK_BSD) && !defined(SIGNALBLOCK_SYSV)
  333.     #define UNIX_BSD # BSD Unix
  334.   #endif
  335.   #ifdef __NetBSD__
  336.     #define UNIX_NETBSD
  337.   #endif
  338.   #ifdef __FreeBSD__
  339.     #define UNIX_FREEBSD
  340.   #endif
  341.   #if (defined(SUN3) || defined(SUN386) || defined(SUN4)) && defined(HAVE_MMAP) && defined(HAVE_VADVISE)
  342.     #define UNIX_SUNOS4  # Sun OS Version 4
  343.   #endif
  344.   #if defined(SUN4) && !defined(HAVE_VADVISE) # && !defined(HAVE_GETPAGESIZE)
  345.     #define UNIX_SUNOS5  # Sun OS Version 5.1/5.2/5.3 (Solaris 2)
  346.   #endif
  347.  
  348.  
  349. # Auswahl des Zeichensatzes:
  350. #if (defined(SUN3) && defined(UNIX_SUNOS4)) || defined(SUN4) || defined(AMIGA) || defined(ACORN) || defined(UNIX_LINUX) || defined(UNIX_AIX)
  351.   #define ISOLATIN_CHS  # ISO 8859-1, siehe isolatin.chs
  352. #endif
  353. #ifdef HP8XX
  354.   #define HPROMAN8_CHS  # HP-Roman8, siehe hproman8.chs
  355.   # unter X-Term aber: #define ISOLATIN_CHS ??
  356. #endif
  357. #ifdef UNIX_NEXTSTEP
  358.   #define NEXTSTEP_CHS  # NeXTstep, siehe nextstep.chs
  359. #endif
  360. #ifdef DOSPC
  361.   #define IBMPC_CHS  # IBM PC, siehe ibmpc.chs
  362. #endif
  363. #if !(defined(ISOLATIN_CHS) || defined(HPROMAN8_CHS) || defined(NEXTSTEP_CHS) || defined(IBMPC_CHS))
  364.   #define ASCII_CHS  # Default: Nur Ascii-Zeichensatz ohne Sonderzeichen
  365. #endif
  366.  
  367.  
  368. # Auswahl des Compilers:
  369. #if defined(__GNUC__)
  370.   #define GNU
  371. #endif
  372. #if defined(__STDC__)
  373.   #define ANSI
  374. #endif
  375.  
  376.  
  377. # Auswahl der Floating-Point-Fähigkeiten:
  378. # FAST_DOUBLE sollte definiert werden, wenn ein Floating-Point-Coprozessor
  379. # vorhanden ist, dessen 'double'-Typ IEEE-Floating-Points mit 64 Bits sind.
  380. # FAST_FLOAT sollte definiert werden, wenn ein Floating-Point-Coprozessor
  381. # vorhanden ist, dessen 'float'-Typ IEEE-Floating-Points mit 32 Bits sind,
  382. # und der C-Compiler auch 'float'- und nicht 'double'-Operationen generiert.
  383. #ifdef SUN4
  384.   #define FAST_DOUBLE
  385.   #define FAST_FLOAT
  386. #endif
  387. #ifdef HPPA
  388.   #define FAST_DOUBLE
  389.   #define FAST_FLOAT
  390. #endif
  391. #ifdef M88000
  392.   #define FAST_DOUBLE
  393.   #define FAST_FLOAT
  394. #endif
  395. #ifdef RS6000
  396.   #define FAST_DOUBLE
  397.   #define FAST_FLOAT
  398. #endif
  399. #if defined(I80Z86) && (defined(UNIX_LINUX) || defined(UNIX_NEXTSTEP))
  400.   # Linux hat einen funktionierenden Floating-Point-Coprozessor-Emulator.
  401.   # NeXTstep läuft sowieso nur mit Floating-Point-Coprozessor.
  402.   # Aber auf Intel-Pentium-Prozessoren ist die FPU fehlerhaft.
  403.   #define FAST_DOUBLE
  404.   #define FAST_FLOAT
  405. #endif
  406. #ifdef ARM
  407.   # Bei Integers ist der Prozessor Little-Endian, bei Double-Floats Big-Endian!
  408.   #undef FAST_DOUBLE
  409. #endif
  410. #ifdef GNU
  411.   # Erst gcc-2.6 kann auch bei -traditional mit 'float's konversionslos rechnen.
  412.   #if !defined(ANSI) && !((__GNUC__ == 2) && (__GNUC_MINOR__ >= 6))
  413.     #undef FAST_FLOAT
  414.   #endif
  415. #endif
  416. #ifdef NO_FAST_FLOAT
  417.   #undef FAST_FLOAT
  418. #endif
  419.  
  420.  
  421. # Auswahl der Sprache:
  422.   #ifdef ENGLISH
  423.     #undef ENGLISH
  424.     #define ENGLISH 1
  425.   #else
  426.     #define ENGLISH 0
  427.   #endif
  428.   #ifdef DEUTSCH
  429.     #undef DEUTSCH
  430.     #define DEUTSCH 1
  431.   #else
  432.     #define DEUTSCH 0
  433.   #endif
  434.   #ifdef FRANCAIS
  435.     #undef FRANCAIS
  436.     #define FRANCAIS 1
  437.   #else
  438.     #define FRANCAIS 0
  439.   #endif
  440.   #if (DEUTSCH+ENGLISH+FRANCAIS > 1)
  441.     #error "Ambiguous choice of language -- Sprache nicht eindeutig!!"
  442.   #endif
  443.   #if (DEUTSCH+ENGLISH+FRANCAIS > 0)
  444.     #define LANGUAGE_STATIC
  445.   #else # noch keine Sprache ausgewählt
  446.     # Sprache wird zur Laufzeit von der Variablen language bestimmt.
  447.     #undef ENGLISH
  448.     #undef DEUTSCH
  449.     #undef FRANCAIS
  450.     #define ENGLISH  (language==language_english)
  451.     #define DEUTSCH  (language==language_deutsch)
  452.     #define FRANCAIS  (language==language_francais)
  453.   #endif
  454.   #ifdef ENABLE_NLS
  455.     #include <libintl.h>
  456.     extern const char *__GETTEXT(const char *asciz_string);
  457.     #define GETTEXT(str) __GETTEXT(str)
  458.   #else
  459.     #ifdef LANGUAGE_STATIC
  460.       #if ENGLISH
  461.         #define GETTEXT(str) ENGLISH_MSG
  462.       #elif DEUTSCH
  463.         #define GETTEXT(str) DEUTSCH_MSG
  464.       #elif FRANCAIS
  465.         #define GETTEXT(str) FRANCAIS_MSG
  466.       #else
  467.         #define GETTEXT(str) str
  468.       #endif
  469.     #else
  470.       # define GETTEXT(str) (DEUTSCH ? DEUTSCH_MSG : ENGLISH ? ENGLISH_MSG : FRANCAIS ? FRANCAIS_MSG : str)
  471.       #define GETTEXT(str) (DEUTSCH ? DEUTSCH_MSG : FRANCAIS ? FRANCAIS_MSG : ENGLISH_MSG)
  472.     #endif
  473.   #endif
  474.  
  475. # Auswahl der Sicherheitsstufe:
  476. # SAFETY=0 : alle Optimierungen eingeschaltet
  477. # SAFETY=1 : alle Optimierungen, aber noch STACKCHECKs
  478. # SAFETY=2 : nur einfache Assembler-Unterstützung
  479. # SAFETY=3 : keine Optimierungen
  480.   #ifndef SAFETY
  481.     #define SAFETY 0
  482.   #endif
  483.   #if SAFETY >= 3
  484.     #define NO_ASM
  485.     #define NO_FAST_DISPATCH
  486.   #endif
  487.  
  488.  
  489. # Name des Compilers: siehe constobj.d: software_version_string
  490.  
  491.  
  492. # Es gibt doch tatsächlich Compiler, deren Präprozessor in den constant-
  493. # expressions nach '#if' keine Macros mit Argumenten expandiert.
  494. # (Z.B. der cc von HP-UX 8.0.)
  495. # Solche Compiler unterstützen wir definitiv nicht.
  496.  
  497. # Der Acorn ANSI-C Compiler für ARM unter RISCOS hat "char" == "unsigned char".
  498.   #if defined(ARM) && defined(RISCOS) && !defined(GNU)
  499.     #define __CHAR_UNSIGNED__
  500.   #endif
  501.  
  502. # Eine Eigenschaft des Prozessors:
  503. # Die Reihenfolge, in der Worte/Langworte in Bytes abgelegt werden.
  504.   #if defined(short_little_endian) || defined(int_little_endian) || defined(long_little_endian)
  505.     # Z80, VAX, I80X86, DECALPHA, MIPSEL, ...:
  506.     # Low Byte zuunterst, High Byte an höherer Adresse
  507.     #if defined(BIG_ENDIAN_P)
  508.       #error "Bogus BIG_ENDIAN_P -- BIG_ENDIAN_P neu einstellen!"
  509.     #endif
  510.     #define BIG_ENDIAN_P  0
  511.   #endif
  512.   #if defined(short_big_endian) || defined(int_big_endian) || defined(long_big_endian)
  513.     # MC680X0, SPARC, HPPA, MIPSEB, M88000, RS6000, ...:
  514.     # High Byte zuunterst, Low Byte an höherer Adresse (leichter zu lesen)
  515.     #if defined(BIG_ENDIAN_P)
  516.       #error "Bogus BIG_ENDIAN_P -- BIG_ENDIAN_P neu einstellen!"
  517.     #endif
  518.     #define BIG_ENDIAN_P  1
  519.   #endif
  520.   #if !defined(BIG_ENDIAN_P)
  521.     #error "Bogus BIG_ENDIAN_P -- BIG_ENDIAN_P neu einstellen!"
  522.   #endif
  523.  
  524. # Globale Registerdeklarationen müssen schon jetzt kommen, wenn die
  525. # System-Include-Files Inline-Funktions-Definitionen enthalten.
  526.   #if defined(GNU) && (SAFETY < 2)
  527.     #if defined(M88000) && defined(UNIX_DGUX)
  528.       # CFLAGS = -ffixed-r14 -ffixed-r15 -ffixed-r16  simulieren:
  529.       register void* *       STACK    __asm__("%r14"); # s.u.
  530.       register unsigned long mv_count __asm__("%r15"); # s.u.
  531.       register void*         value1   __asm__("%r16"); # s.u.
  532.     #endif
  533.     #if defined(DECALPHA)
  534.       # Have to save our global registers during callbacks since
  535.       # other languages (FORTRAN) have other register usage conventions.
  536.       #define HAVE_SAVED_REGISTERS
  537.     #endif
  538.   #endif
  539.  
  540.  
  541. # ###################### Macros zu C ##################### #
  542.  
  543. # Definitionen für non-ANSI-C-Compiler:
  544. #if !defined(ANSI) && !defined(UNIXCONF)
  545.   #define const       # 'const' streichen
  546. #endif
  547. #if !defined(ANSI)
  548.   # 'volatile' (in der Bedeutung als Variablen-Attribut) streichen:
  549.     #define volatile
  550.   # Hiervon nicht betroffen sind:
  551.   # * 'volatile' als Attribut für die Deklaration (nicht Definition!) von
  552.   #   Funktionen, heißt bei uns 'nonreturning'.
  553.   # * '__volatile__' als Attribut für GCC-__asm__-Anweisungen.
  554. #endif
  555. #if !defined(ANSI) && !defined(__CHAR_UNSIGNED__)
  556.   #define signed      # 'signed int' --> 'int'
  557. #endif
  558. #if !defined(ANSI) && !defined(UNIXCONF)
  559.   #define void  char  # Ergebnistyp 'void', Typ 'void*'
  560. #endif
  561. #if !defined(UNIXCONF)
  562.   # Um einen Typ vom Wert void weiterzureichen: return_void(...);
  563.   #ifdef GNU
  564.     #define return_void  return # 'return void;' ist zulässig
  565.   #else
  566.     # In general it is not legal to return `void' values.
  567.     #define return_void  # Kein 'return' für Expressions vom Typ 'void' verwenden.
  568.   #endif
  569. #endif
  570. #if !defined(GNU) && !defined(UNIXCONF)
  571.   #define inline      # inline foo() {...} --> foo() {...}
  572. #endif
  573. #if !defined(UNIXCONF)
  574.   #define nowarn
  575. #else
  576.   # Um GCC-Warnungen selektiv auszuschalten:
  577.   #define nowarn  __nowarn__
  578. #endif
  579.  
  580. # Definitionen für C++-Compiler:
  581. #ifdef __cplusplus
  582.   #define BEGIN_DECLS  extern "C" {
  583.   #define END_DECLS    }
  584. #else
  585.   #define BEGIN_DECLS
  586.   #define END_DECLS
  587. #endif
  588. # C++ stört sich noch an goto's, die in den Scope von Variablen hineinspringen.
  589.  
  590. # Use _EMA_ where empty macro arguments occur. 
  591.   #define _EMA_
  592.  
  593. # Zusammenhängen zweier macroexpandierter Tokens:
  594. # Beispiel:
  595. #   #undef x
  596. #   #define y 16
  597. #   CONCAT(x,y)        ==>  'x16' (nicht 'xy' !)
  598.   #define CONCAT_(xxx,yyy)  xxx##yyy
  599.   #define CONCAT3_(aaa,bbb,ccc)  aaa##bbb##ccc
  600.   #define CONCAT4_(aaa,bbb,ccc,ddd)  aaa##bbb##ccc##ddd
  601.   #define CONCAT5_(aaa,bbb,ccc,ddd,eee)  aaa##bbb##ccc##ddd##eee
  602.   #define CONCAT6_(aaa,bbb,ccc,ddd,eee,fff)  aaa##bbb##ccc##ddd##eee##fff
  603.   #define CONCAT7_(aaa,bbb,ccc,ddd,eee,fff,ggg)  aaa##bbb##ccc##ddd##eee##fff##ggg
  604.   #define CONCAT(xxx,yyy)  CONCAT_(xxx,yyy)
  605.   #define CONCAT3(aaa,bbb,ccc)  CONCAT3_(aaa,bbb,ccc)
  606.   #define CONCAT4(aaa,bbb,ccc,ddd)  CONCAT4_(aaa,bbb,ccc,ddd)
  607.   #define CONCAT5(aaa,bbb,ccc,ddd,eee)  CONCAT5_(aaa,bbb,ccc,ddd,eee)
  608.   #define CONCAT6(aaa,bbb,ccc,ddd,eee,fff)  CONCAT6_(aaa,bbb,ccc,ddd,eee,fff)
  609.   #define CONCAT7(aaa,bbb,ccc,ddd,eee,fff,ggg)  CONCAT7_(aaa,bbb,ccc,ddd,eee,fff,ggg)
  610.  
  611. # Generierung von Sprungzielen (goto-Marken) in Macros:
  612. # GENTAG(end)  ==>  end116
  613. # Damit kann ein Macro, der Marken definiert, mehr als einmal pro Funktion,
  614. # aber immer noch nur einmal pro Source-Zeile benutzt werden.
  615. # Die Marken müssen in einem umschließenden Block mit
  616. # DECLTAG(end);
  617. # deklariert werden.
  618. # Ab GCC-2.6.1 muß dieser umschließende Block eine Expression sein:
  619. # BEGIN_DECLTAG { DECLTAG(end); ... } END_DECLTAG  expandiert dann zu
  620. # ( { DECLTAG(end); ... } );
  621.   #ifdef ANSI # mit traditionellem Präprozessor ist dieser Macro wertlos
  622.     #define GENTAG(xxx)  CONCAT(xxx,__LINE__)
  623.     #define DECLTAG(xxx)
  624.     #define BEGIN_DECLTAG
  625.     #define END_DECLTAG
  626.   #elif defined(GNU)
  627.     #if (__GNUC__ >= 2)
  628.       #define GENTAG(xxx)  xxx
  629.       #define DECLTAG(xxx)  __label__ xxx
  630.       #define BEGIN_DECLTAG  (
  631.       #define END_DECLTAG  );
  632.     #endif
  633.   #endif
  634.  
  635. # Umwandlung von Tokens in Strings:
  636. # STRING(token)  ==>  "token"
  637. #ifdef ANSI
  638.   #define STRING(token) #token
  639. #else
  640.   #define STRING(token) "token"
  641. #endif
  642. #define STRINGIFY(token) STRING(token)
  643.  
  644. # Storage-Class-Specifier in Top-Level-Deklarationen:
  645. # für Variablen:
  646. #   global           überall sichtbare Variable
  647. #   local            nur im File (lokal) sichtbare Variable
  648. #   extern           Verweis auf woanders definierte Variable
  649. # für Funktionen:
  650. #   global           überall sichtbare Funktion
  651. #   local            nur im File (lokal) sichtbare Funktion
  652. #   extern           Verweis auf woanders definierte Funktion
  653. #   local_function   Verweis auf später im File definierte Funktion
  654. #   nonreturning     Funktion, die nie zurückkommt
  655.   #define global
  656.   #define local  static
  657. # #define extern extern
  658.   #if defined(ANSI) || defined(GNU)
  659.     #define local_function  local
  660.   #else
  661.     # Es gibt Compiler, die sich über
  662.     #    typedef int handler(); local handler my_handler;
  663.     # aufregen!
  664.     #define local_function  extern
  665.   #endif
  666.   #ifdef GNU
  667.     #define nonreturning  __volatile__
  668.   #else
  669.     #define nonreturning
  670.   #endif
  671.  
  672. # Deklaration einer Funktion (nur die Fälle, die von ansidecl.d nicht erkannt
  673. # werden):
  674.   #ifdef ANSI
  675.     #define _ARGS(x) x
  676.   #else
  677.     #define _ARGS(x) ()
  678.   #endif
  679.   #ifdef ANSI
  680.     #define PARM0()  (void)
  681.     #define PARM1(arg1,decl1)  (decl1)
  682.     #define PARM2(arg1,arg2,decl1,decl2)  (decl1,decl2)
  683.     #define PARM3(arg1,arg2,arg3,decl1,decl2,decl3)  (decl1,decl2,decl3)
  684.     #define PARM4(arg1,arg2,arg3,arg4,decl1,decl2,decl3,decl4)  (decl1,decl2,decl3,decl4)
  685.     #define PARM5(arg1,arg2,arg3,arg4,arg5,decl1,decl2,decl3,decl4,decl5)  (decl1,decl2,decl3,decl4,decl5)
  686.   #else
  687.     #define PARM0()  ()
  688.     #define PARM1(arg1,decl1)  (arg1) decl1;
  689.     #define PARM2(arg1,arg2,decl1,decl2)  (arg1,arg2) decl1; decl2;
  690.     #define PARM3(arg1,arg2,arg3,decl1,decl2,decl3)  (arg1,arg2,arg3) decl1; decl2; decl3;
  691.     #define PARM4(arg1,arg2,arg3,arg4,decl1,decl2,decl3,decl4)  (arg1,arg2,arg3,arg4) decl1; decl2; decl3; decl4;
  692.     #define PARM5(arg1,arg2,arg3,arg4,arg5,decl1,decl2,decl3,decl4,decl5)  (arg1,arg2,arg3,arg4,arg5) decl1; decl2; decl3; decl4; decl5;
  693.   #endif
  694.  
  695. # Deklaration einer Funktion, die nie zurückkommt:
  696. # nonreturning_function(extern,exit,(void)); == extern void abort (void);
  697.   #ifdef GNU
  698.     #ifdef ANSI
  699.       #define nonreturning_function(storclass,funname,arguments)  \
  700.         typedef void CONCAT3(funname,_function_,__LINE__) arguments; \
  701.         storclass nonreturning CONCAT3(funname,_function_,__LINE__) funname
  702.     #else
  703.       typedef void void_function ();
  704.       #define nonreturning_function(storclass,funname,arguments)  \
  705.         storclass nonreturning void_function funname
  706.     #endif
  707.   #else
  708.     #ifdef ANSI
  709.       #define nonreturning_function(storclass,funname,arguments)  \
  710.         storclass void funname arguments
  711.     #else
  712.       #define nonreturning_function(storclass,funname,arguments)  \
  713.         storclass void funname()
  714.     #endif
  715.   #endif
  716.  
  717. # Storage-Class-Specifier in Deklarationen an Blockanfängen:
  718. # var                       leitet Variablendeklarationen ein
  719. # reg1, reg2, ..., reg10    spezifiziert, daß eine Variable in einem Register
  720. #                           sitzen soll, und die (geschätzte) Priorität
  721. #                           davon.
  722. #      (reg1 = wichtigst, z.B. Zähler der innersten Schleife)
  723.   #define var
  724. # regvarcount ist eine Schätzung, wieviele (Integer-)Variablen der Compiler
  725. # üblicherweise gleichzeitig in die Register legen kann. Die Anzahl der Nullen
  726. # bei Integer-Registern im Macro CALL_USED_REGISTERS der gcc2-Maschinen-
  727. # beschreibung ist ein guter Schätzwert.
  728. #ifdef MC680X0            # gcc2: 6+5
  729.   #define regvarcount  6  # kann mindestens 6 Variablen in die Register nehmen
  730. #endif
  731. #ifdef SPARC              # gcc2: 14
  732.   #define regvarcount  8  # kann mindestens 8 Variablen in die Register nehmen
  733. #endif
  734. #ifdef HPPA               # gcc2: 16
  735.   #define regvarcount 16  # kann sehr viele Variablen in die Register nehmen
  736. #endif
  737. #ifdef MIPS               # gcc2: 9
  738.   #define regvarcount 10  # kann viele Variablen in die Register nehmen
  739. #endif
  740. #ifdef M88000             # gcc2: 12
  741.   #define regvarcount 12  # kann viele Variablen in die Register nehmen
  742. #endif
  743. #ifdef RS6000             # gcc2: 19
  744.   #define regvarcount 16  # kann sehr viele Variablen in die Register nehmen
  745. #endif
  746. #ifdef I80X86             # gcc2: 4
  747.   #define regvarcount  4  # kann mindestens 4 Variablen in die Register nehmen
  748. #endif
  749. #ifdef VAX
  750.   #define regvarcount  6  # gcc2: 6
  751. #endif
  752. #ifdef CONVEX
  753.   #define regvarcount  6  # gcc2: 0
  754. #endif
  755. #ifdef ARM
  756.   #define regvarcount  6  # gcc2: 6
  757. #endif
  758. #ifdef DECALPHA           # gcc2: 8, dafür aber 20 call-used-Register
  759.   #define regvarcount 10  # kann viele Variablen in die Register nehmen
  760. #endif
  761. #if (regvarcount>=1)
  762.   #define reg1  register
  763. #else
  764.   #define reg1  # auto
  765. #endif
  766. #if (regvarcount>=2)
  767.   #define reg2  register
  768. #else
  769.   #define reg2  # auto
  770. #endif
  771. #if (regvarcount>=3)
  772.   #define reg3  register
  773. #else
  774.   #define reg3  # auto
  775. #endif
  776. #if (regvarcount>=4)
  777.   #define reg4  register
  778. #else
  779.   #define reg4  # auto
  780. #endif
  781. #if (regvarcount>=5)
  782.   #define reg5  register
  783. #else
  784.   #define reg5  # auto
  785. #endif
  786. #if (regvarcount>=6)
  787.   #define reg6  register
  788. #else
  789.   #define reg6  # auto
  790. #endif
  791. #if (regvarcount>=7)
  792.   #define reg7  register
  793. #else
  794.   #define reg7  # auto
  795. #endif
  796. #if (regvarcount>=8)
  797.   #define reg8  register
  798. #else
  799.   #define reg8  # auto
  800. #endif
  801. #if (regvarcount>=9)
  802.   #define reg9  register
  803. #else
  804.   #define reg9  # auto
  805. #endif
  806. #if (regvarcount>=10)
  807.   #define reg10  register
  808. #else
  809.   #define reg10  # auto
  810. #endif
  811.  
  812. # Adresse des ersten Elements eines Arrays: &!array
  813. # (Wenn klar werden soll, daß man die Adresse des ganzen Arrays übergibt.
  814. # Wenn man &array schreibt, ist das genau genommen ein Typfehler.)
  815.  
  816. # Verallgemeinerte if-Anweisung:
  817. # if (cond1) ... {elif (condi) ...} [else ...]
  818.   #define elif  else if
  819.  
  820. # Endlosschleife, nur mit  break;  oder  return...;  zu verlassen:
  821.   #define loop  while (1)
  822.  
  823. # Umgekehrte Abbruchbedingung in Schleifen:
  824. # Erlaubt   until (expression) statement
  825. # und       do statement until (expression);
  826.   #define until(expression)  while(!(expression))
  827.  
  828. # Fallunterscheidung über einen Wert >=0
  829. # switchu (expression) ...
  830.   #ifdef GNU # wird so besser optimiert
  831.     #define switchu(expression)  switch ((unsigned int)(expression))
  832.   #else
  833.     #define switchu  switch
  834.   #endif
  835.  
  836. # Ignorieren eines Wertes (statt einer Zuweisung an eine Variable)
  837. # unused ...
  838.   #ifdef GNU # um eine gcc-Warnung "statement with no effect" zu vermeiden
  839.     #define unused  (void)
  840.   #else
  841.     #define unused
  842.   #endif
  843.  
  844. # Vertauschen zweier Variableninhalte:  swap(register int, x1, x2);
  845.   #define swap(swap_type,swap_var1,swap_var2)  \
  846.     { var swap_type swap_temp;                                             \
  847.       swap_temp = swap_var1; swap_var1 = swap_var2; swap_var2 = swap_temp; \
  848.     }
  849.  
  850. # Kennzeichnung einer unerreichten Programmstelle: NOTREACHED
  851.   #define NOTREACHED  fehler_notreached(__FILE__,__LINE__);
  852.  
  853. # Überprüfung eines arithmetischen Ausdrucks: ASSERT(expr)
  854.   #define ASSERT(expr)  { if (!(expr)) { NOTREACHED } }
  855.  
  856. # alloca()
  857.   #if defined(GNU) && !defined(RISCOS) && !defined(CONVEX)
  858.     #define alloca  __builtin_alloca
  859.   #elif defined(HAVE_ALLOCA_H) || defined(RISCOS)
  860.     #include <alloca.h>
  861.     #ifndef alloca # Manche definieren 'alloca' als Macro...
  862.       #ifdef UNIX_OSF
  863.         extern char* alloca (int size);
  864.       #elif !defined(UNIX_DEC_ULTRIX)
  865.         extern void* alloca (int size); # siehe MALLOC(3V)
  866.       #endif
  867.     #endif
  868.   #elif defined(_AIX)
  869.     #pragma alloca /* AIX requires this to be the first thing in the file. */
  870.   #elif defined(WATCOM)
  871.     #include <malloc.h> # definiert 'alloca' als Macro
  872.   #elif !defined(NO_ALLOCA)
  873.     extern void* alloca (int size); # siehe MALLOC(3V)
  874.   #endif
  875.  
  876. # Synonym für Byte, Word, Longword:
  877. # CLISP_BYTE    = signed 8 bit integer
  878. # CLISP_UBYTE   = unsigned 8 bit int
  879. # CLISP_WORD    = signed 16 bit int
  880. # CLISP_UWORD   = unsigned 16 bit int
  881. # CLISP_LONG    = signed 32 bit int
  882. # CLISP_ULONG   = unsigned 32 bit int
  883. # Hingegen wird "char" nur in der Bedeutung eines Elements eines Strings
  884. # verwendet. Nie wird mit einem "char" wirklich gerechnet; das könnte von
  885. # __CHAR_UNSIGNED__ abhängen!
  886.   #if (char_bitsize==8)
  887.     #ifdef __CHAR_UNSIGNED__
  888.       typedef signed char  CLISP_BYTE;
  889.     #else
  890.       typedef char         CLISP_BYTE;
  891.     #endif
  892.     typedef unsigned char  CLISP_UBYTE;
  893.   #else
  894.     #error "No 8 bit integer type? -- Welcher Integer-Typ hat 8 Bit?"
  895.   #endif
  896.   #if (short_bitsize==16)
  897.     typedef short          CLISP_WORD;
  898.     typedef unsigned short CLISP_UWORD;
  899.   #else
  900.     #error "No 16 bit integer type? -- Welcher Integer-Typ hat 16 Bit?"
  901.   #endif
  902.   #if (long_bitsize==32)
  903.     typedef long           CLISP_LONG;
  904.     typedef unsigned long  CLISP_ULONG;
  905.   #elif (int_bitsize==32)
  906.     typedef int            CLISP_LONG;
  907.     typedef unsigned int   CLISP_ULONG;
  908.   #else
  909.     #error "No 32 bit integer type? -- Welcher Integer-Typ hat 32 Bit?"
  910.   #endif
  911.   #if (long_bitsize==64)
  912.     typedef long           CLISP_LONGLONG;
  913.     typedef unsigned long  CLISP_ULONGLONG;
  914.     #undef HAVE_LONGLONG
  915.     #define HAVE_LONGLONG
  916.   #elif defined(HAVE_LONGLONG)
  917.    #if defined(long_long_bitsize) && (long_long_bitsize==64)
  918.     typedef long long           CLISP_LONGLONG;
  919.     typedef unsigned long long  CLISP_ULONGLONG;
  920.    #else # unbrauchbarer Typ
  921.     #undef HAVE_LONGLONG
  922.    #endif
  923.   #endif
  924.   #if defined(WIDE) && !defined(HAVE_LONGLONG)
  925.     #error "No 64 bit integer type? -- Welcher Integer-Typ hat 64 Bit?"
  926.   #endif
  927.  
  928. # Wahrheitswerte:
  929.   #define TRUE   1
  930.   #define FALSE  0
  931.   typedef unsigned int  boolean;
  932.  
  933. # Typ für Vorzeichenwerte, Vergleichsergebnisse, dreiwertige enum's
  934. # mit Werten +1, 0, -1
  935.   typedef signed int  signean;
  936.   #define signean_plus    1 # +1
  937.   #define signean_null    0 #  0
  938.   #define signean_minus  -1 # -1
  939.  
  940. # Nullpointer
  941.   #undef NULL  # wg. WATCOM
  942.   #define NULL  ((void*) 0L)
  943.  
  944. # Den Offset einer Komponente 'ident' in einem Struct vom Typ 'type' bestimmen:
  945. # 0 als Pointer auf 'type' auffassen, dorthin ein Struct 'type' legen und
  946. # von dessen Komponente 'ident' die Adresse bestimmen und als Zahl liefern:
  947.   #ifndef HAVE_OFFSETOF
  948.   #define offsetof(type,ident)  ((CLISP_ULONG)&(((type*)0)->ident))
  949.   #else
  950.   #include <stddef.h>
  951.   #endif
  952. # Den Offset eines Arrays 'ident' in einem Struct vom Typ 'type' bestimmen:
  953.   #define offsetofa(type,ident)  offsetof(type,ident[0])
  954.  
  955. # Unspezifizierte Länge von Arrays in Structures:
  956. # struct { ...; ...; type x[unspecified]; }
  957. # Statt sizeof(..) muß man dann aber immer offsetof(..,x) schreiben.
  958.   #if defined(GNU) # GNU-C kann Arrays der Länge 0
  959.     #define unspecified 0
  960.   #elif 0
  961.     # Üblicherweise läßt man die Arraygrenze weg:
  962.     #define unspecified
  963.   #else
  964.     # Jedoch die HP-UX- und IRIX-Compiler lassen sich nur damit befriedigen:
  965.     #define unspecified 1
  966.   #endif
  967.  
  968. # Pointer-Arithmetik: einen gegebenen Offset (gemessen in Bytes)
  969. # zu einem Pointer addieren.
  970.   #if !(defined(GNU) || (pointer_bitsize > 32))
  971.     # Billige Methode:
  972.     #define pointerplus(pointer,offset)  ((void*)((CLISP_ULONG)(pointer)+(offset)))
  973.   #else
  974.     # Für GNU-C beim Initialisieren von static-Variablen unerläßlich
  975.     # (muß ein Bug in 'c-typeck.c' in 'initializer_constant_valid_p' sein):
  976.     # Das einzig Richtige, falls sizeof(CLISP_ULONG) < sizeof(void*):
  977.     #define pointerplus(pointer,offset)  ((CLISP_UBYTE*)(pointer)+(offset))
  978.   #endif
  979.  
  980. # Bit Nummer n (0<=n<32)
  981.   #define bit(n)  (1L<<(n))
  982. # Bit Nummer n (0<n<=32) mod 2^32
  983.   #define bitm(n)  (2L<<((n)-1))
  984. # Bit-Test von Bit n in x, n konstant, x ein oint:
  985.   #if !defined(SPARC)
  986.     #define bit_test(x,n)  ((x) & bit(n))
  987.   #else
  988.     # Auf SPARC-Prozessoren sind lange Konstanten langsamer als Shifts.
  989.     #if !defined(GNU)
  990.       #define bit_test(x,n)  \
  991.         ((n)<12 ? ((x) & bit(n)) : ((sint32)((uint32)(x) << (31-(n))) < 0))
  992.     #else # der GNU-Compiler optimiert boolean-Expressions so besser:
  993.       #define bit_test(x,n)  \
  994.         (   ( ((n)<12) && ((x) & bit(n)) )                           \
  995.          || ( ((n)>=12) && ((sint32)((uint32)(x) << (31-(n))) < 0) ) \
  996.         )
  997.     #endif
  998.   #endif
  999. # Minus Bit Nummer n (0<=n<32)
  1000.   #define minus_bit(n)  (-1L<<(n))
  1001. # Minus Bit Nummer n (0<n<=32) mod 2^32
  1002.   #define minus_bitm(n)  (-2L<<((n)-1))
  1003.  
  1004. # floor(a,b) liefert für a>=0, b>0  floor(a/b).
  1005. # b sollte eine 'constant expression' sein.
  1006.   #define floor(a_from_floor,b_from_floor)  ((a_from_floor) / (b_from_floor))
  1007.  
  1008. # ceiling(a,b) liefert für a>=0, b>0  ceiling(a/b) = floor((a+b-1)/b).
  1009. # b sollte eine 'constant expression' sein.
  1010.   #define ceiling(a_from_ceiling,b_from_ceiling)  \
  1011.     (((a_from_ceiling) + (b_from_ceiling) - 1) / (b_from_ceiling))
  1012.  
  1013. # round_down(a,b) rundet a>=0 so ab, daß es durch b>0 teilbar ist.
  1014. # b sollte eine 'constant expression' sein.
  1015.   #define round_down(a_from_round,b_from_round)  \
  1016.     (floor(a_from_round,b_from_round)*(b_from_round))
  1017.  
  1018. # round_up(a,b) rundet a>=0 so auf, daß es durch b>0 teilbar ist.
  1019. # b sollte eine 'constant expression' sein.
  1020.   #define round_up(a_from_round,b_from_round)  \
  1021.     (ceiling(a_from_round,b_from_round)*(b_from_round))
  1022.  
  1023. # nicht-lokale Ausgänge
  1024.   #include <setjmp.h>
  1025.   #if defined(UNIX) && defined(HAVE__JMP) && !defined(UNIX_LINUX)
  1026.     # Folgende Routinen sind effizienter (hantieren nicht mit Signal-Masken):
  1027.     #undef setjmp
  1028.     #undef longjmp
  1029.     #define setjmp  _setjmp
  1030.     #define longjmp  _longjmp
  1031.     #ifdef LONGJMP_RETURNS
  1032.       # _longjmp(jmpbuf,value) kann zurückkehren, wenn jmpbuf ungültig ist.
  1033.       #undef longjmp
  1034.       #define longjmp(x,y)  (_longjmp(x,y), fehler_notreached(__FILE__,__LINE__))
  1035.     #endif
  1036.   #endif
  1037. # Mit longjmp() kann man nur ein `int' übergeben.
  1038. # Wenn wir nun ein `long' übergeben wollen und sizeof(int) < sizeof(long) ist,
  1039. # brauchen wir eine globale Variable:
  1040.   #if (int_bitsize == long_bitsize)
  1041.     #define setjmpl(x)  setjmp(x)
  1042.     #define longjmpl(x,y)  longjmp(x,y)
  1043.   #else # (int_bitsize < long_bitsize)
  1044.     extern long jmpl_value;
  1045.     #define setjmpl(x)  (setjmp(x) ? jmpl_value : 0)
  1046.     #define longjmpl(x,y)  (jmpl_value = (y), longjmp(x,1))
  1047.   #endif
  1048.  
  1049. # Dynamisch allozierte Arrays mit dynamic extent:
  1050. # Beispiel:
  1051. #     { var DYNAMIC_ARRAY(reg7,my_array,uintL,n);
  1052. #       ...
  1053. #       FREE_DYNAMIC_ARRAY(my_array);
  1054. #     }
  1055. # Vorsicht: Je nach Implementierung ist my_array entweder der Array selbst
  1056. # oder ein Pointer auf den Array! Immer nur my_array als Expression verwenden!
  1057.   #if defined(GNU)
  1058.     # verkraftet dynamisch allozierte Arrays im Maschinenstack
  1059.     # { var reg7 uintL my_array[n]; ... }
  1060.     #define DYNAMIC_ARRAY(regdecl,arrayvar,arrayeltype,arraysize)  \
  1061.       arrayeltype arrayvar[arraysize]
  1062.     #define FREE_DYNAMIC_ARRAY(arrayvar)
  1063.     #ifdef DECALPHA # GCC 2.5.5 Bug umgehen
  1064.       #undef DYNAMIC_ARRAY
  1065.       #define DYNAMIC_ARRAY(regdecl,arrayvar,arrayeltype,arraysize)  \
  1066.         arrayeltype arrayvar[(arraysize)+1]
  1067.     #endif
  1068.   #elif (defined(UNIX) && (defined(HAVE_ALLOCA_H) || defined(_AIX) || !defined(NO_ALLOCA))) || defined(WATCOM) || defined(RISCOS)
  1069.     # Platz im Maschinenstack reservieren.
  1070.     # { var reg7 uintL* my_array = (uintL*)alloca(n*sizeof(uintL)); ... }
  1071.     #define DYNAMIC_ARRAY(regdecl,arrayvar,arrayeltype,arraysize)  \
  1072.       regdecl arrayeltype* arrayvar = (arrayeltype*)alloca((arraysize)*sizeof(arrayeltype))
  1073.     #define FREE_DYNAMIC_ARRAY(arrayvar)
  1074.     # kein Errorcheck??
  1075.   #else
  1076.     # Platz woanders reservieren und dann wieder freigeben.
  1077.     # { var reg7 uintL* my_array = (uintL*)malloc(n*sizeof(uintL)); ... free(my_array); }
  1078.     #ifdef HAVE_STDLIB_H
  1079.       #include <stdlib.h>
  1080.     #else
  1081.       #include <sys/types.h>
  1082.     #endif
  1083.     #ifndef malloc
  1084.       extern void* malloc (size_t size); # siehe MALLOC(3V)
  1085.     #endif
  1086.     #ifndef free
  1087.       extern void free (void* ptr); # siehe MALLOC(3V)
  1088.     #endif
  1089.     #define NEED_MALLOCA
  1090.     extern void* malloca (size_t size); # siehe SPVW.D
  1091.     extern void freea (void* ptr); # siehe SPVW.D
  1092.     #define DYNAMIC_ARRAY(regdecl,arrayvar,arrayeltype,arraysize)  \
  1093.       regdecl arrayeltype* arrayvar = (arrayeltype*)malloca((arraysize)*sizeof(arrayeltype))
  1094.     #define FREE_DYNAMIC_ARRAY(arrayvar)  freea(arrayvar)
  1095.   #endif
  1096.  
  1097. # Signed/Unsigned-Integer-Typen mit vorgegebener Mindestgröße:
  1098.   typedef CLISP_UBYTE   uint1;   # unsigned 1 bit Integer
  1099.   typedef CLISP_BYTE    sint1;   # signed 1 bit Integer
  1100.   typedef CLISP_UBYTE   uint2;   # unsigned 2 bit Integer
  1101.   typedef CLISP_BYTE    sint2;   # signed 2 bit Integer
  1102.   typedef CLISP_UBYTE   uint3;   # unsigned 3 bit Integer
  1103.   typedef CLISP_BYTE    sint3;   # signed 3 bit Integer
  1104.   typedef CLISP_UBYTE   uint4;   # unsigned 4 bit Integer
  1105.   typedef CLISP_BYTE    sint4;   # signed 4 bit Integer
  1106.   typedef CLISP_UBYTE   uint5;   # unsigned 5 bit Integer
  1107.   typedef CLISP_BYTE    sint5;   # signed 5 bit Integer
  1108.   typedef CLISP_UBYTE   uint6;   # unsigned 6 bit Integer
  1109.   typedef CLISP_BYTE    sint6;   # signed 6 bit Integer
  1110.   typedef CLISP_UBYTE   uint7;   # unsigned 7 bit Integer
  1111.   typedef CLISP_BYTE    sint7;   # signed 7 bit Integer
  1112.   typedef CLISP_UBYTE   uint8;   # unsigned 8 bit Integer
  1113.   typedef CLISP_BYTE    sint8;   # signed 8 bit Integer
  1114.   typedef CLISP_UWORD   uint9;   # unsigned 9 bit Integer
  1115.   typedef CLISP_WORD    sint9;   # signed 9 bit Integer
  1116.   typedef CLISP_UWORD   uint10;  # unsigned 10 bit Integer
  1117.   typedef CLISP_WORD    sint10;  # signed 10 bit Integer
  1118.   typedef CLISP_UWORD   uint11;  # unsigned 11 bit Integer
  1119.   typedef CLISP_WORD    sint11;  # signed 11 bit Integer
  1120.   typedef CLISP_UWORD   uint12;  # unsigned 12 bit Integer
  1121.   typedef CLISP_WORD    sint12;  # signed 12 bit Integer
  1122.   typedef CLISP_UWORD   uint13;  # unsigned 13 bit Integer
  1123.   typedef CLISP_WORD    sint13;  # signed 13 bit Integer
  1124.   typedef CLISP_UWORD   uint14;  # unsigned 14 bit Integer
  1125.   typedef CLISP_WORD    sint14;  # signed 14 bit Integer
  1126.   typedef CLISP_UWORD   uint15;  # unsigned 15 bit Integer
  1127.   typedef CLISP_WORD    sint15;  # signed 15 bit Integer
  1128.   typedef CLISP_UWORD   uint16;  # unsigned 16 bit Integer
  1129.   typedef CLISP_WORD    sint16;  # signed 16 bit Integer
  1130.   typedef CLISP_ULONG   uint17;  # unsigned 17 bit Integer
  1131.   typedef CLISP_LONG    sint17;  # signed 17 bit Integer
  1132.   typedef CLISP_ULONG   uint18;  # unsigned 18 bit Integer
  1133.   typedef CLISP_LONG    sint18;  # signed 18 bit Integer
  1134.   typedef CLISP_ULONG   uint19;  # unsigned 19 bit Integer
  1135.   typedef CLISP_LONG    sint19;  # signed 19 bit Integer
  1136.   typedef CLISP_ULONG   uint20;  # unsigned 20 bit Integer
  1137.   typedef CLISP_LONG    sint20;  # signed 20 bit Integer
  1138.   typedef CLISP_ULONG   uint21;  # unsigned 21 bit Integer
  1139.   typedef CLISP_LONG    sint21;  # signed 21 bit Integer
  1140.   typedef CLISP_ULONG   uint22;  # unsigned 22 bit Integer
  1141.   typedef CLISP_LONG    sint22;  # signed 22 bit Integer
  1142.   typedef CLISP_ULONG   uint23;  # unsigned 23 bit Integer
  1143.   typedef CLISP_LONG    sint23;  # signed 23 bit Integer
  1144.   typedef CLISP_ULONG   uint24;  # unsigned 24 bit Integer
  1145.   typedef CLISP_LONG    sint24;  # signed 24 bit Integer
  1146.   typedef CLISP_ULONG   uint25;  # unsigned 25 bit Integer
  1147.   typedef CLISP_LONG    sint25;  # signed 25 bit Integer
  1148.   typedef CLISP_ULONG   uint26;  # unsigned 26 bit Integer
  1149.   typedef CLISP_LONG    sint26;  # signed 26 bit Integer
  1150.   typedef CLISP_ULONG   uint27;  # unsigned 27 bit Integer
  1151.   typedef CLISP_LONG    sint27;  # signed 27 bit Integer
  1152.   typedef CLISP_ULONG   uint28;  # unsigned 28 bit Integer
  1153.   typedef CLISP_LONG    sint28;  # signed 28 bit Integer
  1154.   typedef CLISP_ULONG   uint29;  # unsigned 29 bit Integer
  1155.   typedef CLISP_LONG    sint29;  # signed 29 bit Integer
  1156.   typedef CLISP_ULONG   uint30;  # unsigned 30 bit Integer
  1157.   typedef CLISP_LONG    sint30;  # signed 30 bit Integer
  1158.   typedef CLISP_ULONG   uint31;  # unsigned 31 bit Integer
  1159.   typedef CLISP_LONG    sint31;  # signed 31 bit Integer
  1160.   typedef CLISP_ULONG   uint32;  # unsigned 32 bit Integer
  1161.   typedef CLISP_LONG    sint32;  # signed 32 bit Integer
  1162.   #ifdef HAVE_LONGLONG
  1163.   typedef CLISP_ULONGLONG  uint33;  # unsigned 33 bit Integer
  1164.   typedef CLISP_LONGLONG   sint33;  # signed 33 bit Integer
  1165.   typedef CLISP_ULONGLONG  uint48;  # unsigned 48 bit Integer
  1166.   typedef CLISP_LONGLONG   sint48;  # signed 48 bit Integer
  1167.   typedef CLISP_ULONGLONG  uint64;  # unsigned 64 bit Integer
  1168.   typedef CLISP_LONGLONG   sint64;  # signed 64 bit Integer
  1169.   #endif
  1170.   #define exact_uint_size_p(n) (((n)==char_bitsize)||((n)==short_bitsize)||((n)==int_bitsize)||((n)==long_bitsize))
  1171.   #ifdef ANSI # mit traditionellem Präprozessor sind diese Macros wertlos
  1172.     #define signed_int_with_n_bits(n) CONCAT(sint,n)
  1173.     #define unsigned_int_with_n_bits(n) CONCAT(uint,n)
  1174.   #endif
  1175. # Verwende 'uintn' und 'sintn' für Integers mit genau vorgegebener Breite.
  1176. # exact_uint_size_p(n) gibt an, ob der uint mit n Bits auch wirklich
  1177. # nur n Bits hat.
  1178.  
  1179. # Ab hier bedeuten 'uintX' und 'sintX' unsigned bzw. signed integer -
  1180. # Typen der Wortbreite X (X=B,W,L,Q).
  1181.   #define intBsize 8
  1182.   #ifdef ANSI
  1183.     typedef signed_int_with_n_bits(intBsize)    sintB;
  1184.     typedef unsigned_int_with_n_bits(intBsize)  uintB;
  1185.   #else
  1186.     typedef sint/**/intBsize  sintB;
  1187.     typedef uint/**/intBsize  uintB;
  1188.   #endif
  1189.   #define intWsize 16
  1190.   #ifdef ANSI
  1191.     typedef signed_int_with_n_bits(intWsize)    sintW;
  1192.     typedef unsigned_int_with_n_bits(intWsize)  uintW;
  1193.   #else
  1194.     typedef sint/**/intWsize  sintW;
  1195.     typedef uint/**/intWsize  uintW;
  1196.   #endif
  1197.   #define intLsize 32
  1198.   #ifdef ANSI
  1199.     typedef signed_int_with_n_bits(intLsize)    sintL;
  1200.     typedef unsigned_int_with_n_bits(intLsize)  uintL;
  1201.   #else
  1202.     typedef sint/**/intLsize  sintL;
  1203.     typedef uint/**/intLsize  uintL;
  1204.   #endif
  1205.   #if defined(DECALPHA)
  1206.     # Maschine hat echte 64-Bit-Zahlen in Hardware.
  1207.     #define intQsize 64
  1208.     #ifdef ANSI
  1209.       typedef signed_int_with_n_bits(intQsize)    sintQ;
  1210.       typedef unsigned_int_with_n_bits(intQsize)  uintQ;
  1211.     #else
  1212.       typedef sint/**/intQsize  sintQ;
  1213.       typedef uint/**/intQsize  uintQ;
  1214.     #endif
  1215.     typedef sintQ  sintL2;
  1216.     typedef uintQ  uintL2;
  1217.   #else
  1218.     # Emuliere 64-Bit-Zahlen mit Hilfe von zwei 32-Bit-Zahlen.
  1219.     typedef struct { sintL hi; uintL lo; } sintL2; # signed integer mit 64 Bit
  1220.     typedef struct { uintL hi; uintL lo; } uintL2; # unsigned integer mit 64 Bit
  1221.   #endif
  1222. # Verwende 'uintX' und 'sintX' für Integers mit ungefähr vorgegebener Breite
  1223. # und möglichst geringem Speicherplatz.
  1224.  
  1225. # Ab hier bedeuten 'uintP' und 'sintP' unsigned bzw. signed integer - Typen,
  1226. # die so breit sind wie ein void* - Pointer.
  1227.   #ifdef ANSI
  1228.     typedef signed_int_with_n_bits(pointer_bitsize)    sintP;
  1229.     typedef unsigned_int_with_n_bits(pointer_bitsize)  uintP;
  1230.   #else
  1231.     typedef sint/**/pointer_bitsize  sintP;
  1232.     typedef uint/**/pointer_bitsize  uintP;
  1233.   #endif
  1234.  
  1235. # Ab hier bedeuten 'uintXY' und 'sintXY' unsigned bzw. signed integer -
  1236. # Typen der Wortbreite X oder Y (X,Y=B,W,L).
  1237.   #if (defined(MC680X0) && !defined(HPUX_ASSEMBLER)) || defined(VAX)
  1238.     # Der 68000 hat gute uintB-, uintW-, uintL-Verarbeitung, insbesondere
  1239.     # DBRA-Befehle für uintW.
  1240.     #define intBWsize intBsize
  1241.     #define intWLsize intWsize
  1242.     #define intBWLsize intBsize
  1243.   #elif (defined(MC680X0) && defined(HPUX_ASSEMBLER)) || defined(SPARC) || defined(HPPA) || defined(MIPS) || defined(M88000) || defined(RS6000) || defined(CONVEX)
  1244.     # Der Sparc-Prozessor kann mit uintB und uintW schlecht rechnen.
  1245.     # Anderen 32-Bit-Prozessoren geht es genauso.
  1246.     #define intBWsize intWsize
  1247.     #define intWLsize intLsize
  1248.     #define intBWLsize intLsize
  1249.   #elif defined(I80Z86)
  1250.     # Wird auf einem 80386 mit uintB und uintW gerechnet, so gibt das viele
  1251.     # Zero-Extends, die - da es zu wenig Register gibt - andere Variablen
  1252.     # unnötigerweise in den Speicher schieben.
  1253.     #define intBWsize intWsize
  1254.     #define intWLsize intLsize
  1255.     #define intBWLsize intLsize
  1256.   #elif defined(ARM)
  1257.     # Der ARM kann mit uintW sehr schlecht rechnen.
  1258.     #define intBWsize intBsize
  1259.     #define intWLsize intLsize
  1260.     #define intBWLsize intBsize
  1261.   #elif defined(DECALPHA)
  1262.     # Auch 64-Bit-Prozessoren können mit uintB und uintW schlecht rechnen.
  1263.     #define intBWsize intWsize
  1264.     #define intWLsize intLsize
  1265.     #define intBWLsize intLsize
  1266.   #else
  1267.     #error "Preferred integer sizes depend on CPU -- Größen intBWsize, intWLsize, intBWLsize neu einstellen!"
  1268.   #endif
  1269.   #ifdef ANSI
  1270.     typedef signed_int_with_n_bits(intBWsize)    sintBW;
  1271.     typedef unsigned_int_with_n_bits(intBWsize)  uintBW;
  1272.     typedef signed_int_with_n_bits(intWLsize)    sintWL;
  1273.     typedef unsigned_int_with_n_bits(intWLsize)  uintWL;
  1274.     typedef signed_int_with_n_bits(intBWLsize)    sintBWL;
  1275.     typedef unsigned_int_with_n_bits(intBWLsize)  uintBWL;
  1276.   #else
  1277.     typedef sint/**/intBWsize  sintBW;
  1278.     typedef uint/**/intBWsize  uintBW;
  1279.     typedef sint/**/intWLsize  sintWL;
  1280.     typedef uint/**/intWLsize  uintWL;
  1281.     typedef sint/**/intBWLsize  sintBWL;
  1282.     typedef uint/**/intBWLsize  uintBWL;
  1283.   #endif
  1284. # Verwende 'uintXY' und 'sintXY' für Integers mit vorgegebener Mindestbreite,
  1285. # mit denen sich leicht rechnen läßt.
  1286.  
  1287. # Schleife, die ein Statement eine gewisse Anzahl mal ausführt:
  1288. # dotimesW(countvar,count,statement);  falls count in ein uintW paßt,
  1289. # dotimesL(countvar,count,statement);  falls count nur in ein uintL paßt,
  1290. # dotimespW(countvar,count,statement);  falls count in ein uintW paßt und >0 ist,
  1291. # dotimespL(countvar,count,statement);  falls count nur in ein uintL paßt und >0 ist.
  1292. # Die Variable countvar muß bereits deklariert sein, vom Typ uintW bzw. uintL
  1293. # und wird durch diese Anweisung verändert!
  1294. # Sie darf in statement nicht verwendet werden!
  1295. # Die Expression count wird nur einmal (zu Beginn) ausgewertet.
  1296.   #if defined(GNU) && defined(MC680X0) && !defined(HPUX_ASSEMBLER)
  1297.     # GNU-C auf einem 680X0 läßt sich dazu überreden, den DBRA-Befehl zu verwenden:
  1298.     #define fast_dotimesW
  1299.     # Um zu entscheiden, wie man GNU-C am besten dazu überredet, betrachte man
  1300.     # den Code, der für spvw.d:gc_markphase() produziert wird.
  1301.     # Oder ein kleines Testprogramm (dbratest.c), das mit
  1302.     # "gcc -O6 -da -S dbratest.c" compiliert wird, und betrachte dbratest.s
  1303.     # und dbratest.c.flow sowie dbratest.c.combine.
  1304.     #if (__GNUC__<2) # GNU C Version 1
  1305.       #define dotimesW_(countvar_from_dotimesW,count_from_dotimesW,statement_from_dotimesW)  \
  1306.         { countvar_from_dotimesW = (count_from_dotimesW);     \
  1307.           if (!(countvar_from_dotimesW==0))                   \
  1308.             { countvar_from_dotimesW--;                       \
  1309.               do {statement_from_dotimesW}                    \
  1310.                  until ((sintW)--countvar_from_dotimesW==-1); \
  1311.         }   }
  1312.       #define dotimespW_(countvar_from_dotimespW,count_from_dotimespW,statement_from_dotimespW)  \
  1313.         { countvar_from_dotimespW = (count_from_dotimespW)-1;                         \
  1314.           do {statement_from_dotimespW} until ((sintW)--countvar_from_dotimespW==-1); \
  1315.         }
  1316.     #else
  1317.       #define dotimesW_(countvar_from_dotimesW,count_from_dotimesW,statement_from_dotimesW)  \
  1318.         { countvar_from_dotimesW = (count_from_dotimesW);        \
  1319.           if (!(countvar_from_dotimesW==0))                      \
  1320.             { countvar_from_dotimesW--;                          \
  1321.               do {statement_from_dotimesW}                       \
  1322.                  until ((sintW)(--countvar_from_dotimesW)+1==0); \
  1323.         }   }
  1324.       #define dotimespW_(countvar_from_dotimespW,count_from_dotimespW,statement_from_dotimespW)  \
  1325.         { countvar_from_dotimespW = (count_from_dotimespW)-1;                            \
  1326.           do {statement_from_dotimespW} until ((sintW)(--countvar_from_dotimespW)+1==0); \
  1327.         }
  1328.     #endif
  1329.   #else
  1330.     #define dotimesW_(countvar_from_dotimesW,count_from_dotimesW,statement_from_dotimesW)  \
  1331.       { countvar_from_dotimesW = (count_from_dotimesW);         \
  1332.         until (countvar_from_dotimesW==0)                       \
  1333.           {statement_from_dotimesW; countvar_from_dotimesW--; } \
  1334.       }
  1335.     #define dotimespW_(countvar_from_dotimespW,count_from_dotimespW,statement_from_dotimespW)  \
  1336.       { countvar_from_dotimespW = (count_from_dotimespW);                   \
  1337.         do {statement_from_dotimespW} until (--countvar_from_dotimespW==0); \
  1338.       }
  1339.   #endif
  1340.   #if defined(GNU) && defined(MC680X0) && !defined(HPUX_ASSEMBLER)
  1341.     # GNU-C auf einem 680X0 läßt sich dazu überreden, den DBRA-Befehl
  1342.     # auf intelligente Weise zu verwenden:
  1343.     #define fast_dotimesL
  1344.     #define dotimesL_(countvar_from_dotimesL,count_from_dotimesL,statement_from_dotimesL)  \
  1345.       { countvar_from_dotimesL = (count_from_dotimesL);           \
  1346.         if (!(countvar_from_dotimesL==0))                         \
  1347.           { countvar_from_dotimesL--;                             \
  1348.             do {statement_from_dotimesL}                          \
  1349.                until ((sintL)(--countvar_from_dotimesL) == -1);   \
  1350.       }   }
  1351.     #define dotimespL_(countvar_from_dotimespL,count_from_dotimespL,statement_from_dotimespL)  \
  1352.       { countvar_from_dotimespL = (count_from_dotimespL)-1;                             \
  1353.         do {statement_from_dotimespL} until ((sintL)(--countvar_from_dotimespL) == -1); \
  1354.       }
  1355.   #endif
  1356.   #ifndef dotimesL_
  1357.     #define dotimesL_(countvar_from_dotimesL,count_from_dotimesL,statement_from_dotimesL)  \
  1358.       { countvar_from_dotimesL = (count_from_dotimesL);         \
  1359.         until (countvar_from_dotimesL==0)                       \
  1360.           {statement_from_dotimesL; countvar_from_dotimesL--; } \
  1361.       }
  1362.     #define dotimespL_(countvar_from_dotimespL,count_from_dotimespL,statement_from_dotimespL)  \
  1363.       { countvar_from_dotimespL = (count_from_dotimespL);                   \
  1364.         do {statement_from_dotimespL} until (--countvar_from_dotimespL==0); \
  1365.       }
  1366.   #endif
  1367.   #if defined(GNU) && defined(__OPTIMIZE__)
  1368.     # Es ist mir nun schon zweimal passiert, daß ich dotimesL auf eine
  1369.     # Variable vom Typ uintC angewandt habe. Damit Jörg und Marcus nicht
  1370.     # mehr suchen müssen, überprüfe ich das jetzt.
  1371.     # Der Dummy-Aufruf wird, wenn's gut geht, von gcc wegoptimiert.
  1372.     # Ansonsten bekommt man einen Fehler beim Linken.
  1373.     #define dotimes_check_sizeof(countvar,type)  \
  1374.       if (!(sizeof(countvar)==sizeof(type))) { dotimes_called_with_count_of_wrong_size(); }
  1375.     extern void dotimes_called_with_count_of_wrong_size (void); # nicht existente Funktion
  1376.   #else
  1377.     #define dotimes_check_sizeof(countvar,type)
  1378.   #endif
  1379.   #define dotimesW(countvar_from_dotimesW,count_from_dotimesW,statement_from_dotimesW) \
  1380.     { dotimes_check_sizeof(countvar_from_dotimesW,uintW); \
  1381.       dotimesW_(countvar_from_dotimesW,count_from_dotimesW,statement_from_dotimesW); \
  1382.     }
  1383.   #define dotimespW(countvar_from_dotimespW,count_from_dotimespW,statement_from_dotimespW) \
  1384.     { dotimes_check_sizeof(countvar_from_dotimespW,uintW); \
  1385.       dotimespW_(countvar_from_dotimespW,count_from_dotimespW,statement_from_dotimespW); \
  1386.     }
  1387.   #define dotimesL(countvar_from_dotimesL,count_from_dotimesL,statement_from_dotimesL) \
  1388.     { dotimes_check_sizeof(countvar_from_dotimesL,uintL); \
  1389.       dotimesL_(countvar_from_dotimesL,count_from_dotimesL,statement_from_dotimesL); \
  1390.     }
  1391.   #define dotimespL(countvar_from_dotimespL,count_from_dotimespL,statement_from_dotimespL) \
  1392.     { dotimes_check_sizeof(countvar_from_dotimespL,uintL); \
  1393.       dotimespL_(countvar_from_dotimespL,count_from_dotimespL,statement_from_dotimespL); \
  1394.     }
  1395. # doconsttimes(count,statement);
  1396. # führt statement count mal aus (count mal der Code!),
  1397. # wobei count eine constant-expression >=0, <=8 ist.
  1398.   #define doconsttimes(count_from_doconsttimes,statement_from_doconsttimes)  \
  1399.     { if (0 < (count_from_doconsttimes)) { statement_from_doconsttimes; } \
  1400.       if (1 < (count_from_doconsttimes)) { statement_from_doconsttimes; } \
  1401.       if (2 < (count_from_doconsttimes)) { statement_from_doconsttimes; } \
  1402.       if (3 < (count_from_doconsttimes)) { statement_from_doconsttimes; } \
  1403.       if (4 < (count_from_doconsttimes)) { statement_from_doconsttimes; } \
  1404.       if (5 < (count_from_doconsttimes)) { statement_from_doconsttimes; } \
  1405.       if (6 < (count_from_doconsttimes)) { statement_from_doconsttimes; } \
  1406.       if (7 < (count_from_doconsttimes)) { statement_from_doconsttimes; } \
  1407.     }
  1408. # DOCONSTTIMES(count,macroname);
  1409. # ruft count mal den Macro macroname auf (count mal der Code!),
  1410. # wobei count eine constant-expression >=0, <=8 ist.
  1411. # Dabei bekommt macroname der Reihe nach die Werte 0,...,count-1 übergeben.
  1412.   #define DOCONSTTIMES(count_from_DOCONSTTIMES,macroname_from_DOCONSTTIMES)  \
  1413.     { if (0 < (count_from_DOCONSTTIMES)) { macroname_from_DOCONSTTIMES((0 < (count_from_DOCONSTTIMES) ? 0 : 0)); } \
  1414.       if (1 < (count_from_DOCONSTTIMES)) { macroname_from_DOCONSTTIMES((1 < (count_from_DOCONSTTIMES) ? 1 : 0)); } \
  1415.       if (2 < (count_from_DOCONSTTIMES)) { macroname_from_DOCONSTTIMES((2 < (count_from_DOCONSTTIMES) ? 2 : 0)); } \
  1416.       if (3 < (count_from_DOCONSTTIMES)) { macroname_from_DOCONSTTIMES((3 < (count_from_DOCONSTTIMES) ? 3 : 0)); } \
  1417.       if (4 < (count_from_DOCONSTTIMES)) { macroname_from_DOCONSTTIMES((4 < (count_from_DOCONSTTIMES) ? 4 : 0)); } \
  1418.       if (5 < (count_from_DOCONSTTIMES)) { macroname_from_DOCONSTTIMES((5 < (count_from_DOCONSTTIMES) ? 5 : 0)); } \
  1419.       if (6 < (count_from_DOCONSTTIMES)) { macroname_from_DOCONSTTIMES((6 < (count_from_DOCONSTTIMES) ? 6 : 0)); } \
  1420.       if (7 < (count_from_DOCONSTTIMES)) { macroname_from_DOCONSTTIMES((7 < (count_from_DOCONSTTIMES) ? 7 : 0)); } \
  1421.     }
  1422.  
  1423. # Ab hier bedeutet uintC einen unsigned-Integer-Typ, mit dem sich besonders
  1424. # leicht zählen läßt. Teilmengenrelation: uintW <= uintC <= uintL.
  1425. # uintCoverflow(x) stellt fest, ob nach Ausführen eines x++ ein Overflow
  1426. # eingetreten ist.
  1427.   #define intCsize intWLsize
  1428.   #define uintC uintWL
  1429.   #define sintC sintWL
  1430.   #if (intCsize==intWsize)
  1431.     #define dotimesC dotimesW
  1432.     #define dotimespC dotimespW
  1433.   #endif
  1434.   #if (intCsize==intLsize)
  1435.     #define dotimesC dotimesL
  1436.     #define dotimespC dotimespL
  1437.   #endif
  1438.   #define uintCoverflow(x)  ((intCsize<intLsize) && ((x)==0))
  1439. # Verwende 'uintC' für Zähler, die meist klein sind.
  1440.  
  1441. # Die Arithmetik benutzt "Digit Sequences" aus "Digits".
  1442. # Das sind unsigned ints mit intDsize Bits (sollte =8 oder =16 oder =32 sein).
  1443. # Falls HAVE_DD: "Doppel-Digits" sind unsigned ints mit 2*intDsize<=32 Bits.
  1444.   #if defined(MC680X0) && !defined(MC680Y0)
  1445.     #define intDsize 16
  1446.     #define intDDsize 32  # = 2*intDsize
  1447.     #define log2_intDsize  4  # = log2(intDsize)
  1448.   #elif defined(MC680Y0) || defined(I80Z86) || defined(SPARC) || defined(HPPA) || defined(MIPS) || defined(M88000) || defined(RS6000) || defined(VAX) || defined(CONVEX) || defined(ARM) || defined(DECALPHA)
  1449.     #define intDsize 32
  1450.     #define intDDsize 64  # = 2*intDsize
  1451.     #define log2_intDsize  5  # = log2(intDsize)
  1452.   #else
  1453.     #error "Preferred digit size depends on CPU -- Größe intDsize neu einstellen!"
  1454.   #endif
  1455.   #ifdef ANSI
  1456.     typedef unsigned_int_with_n_bits(intDsize)  uintD;
  1457.     typedef signed_int_with_n_bits(intDsize)    sintD;
  1458.   #else
  1459.     typedef uint/**/intDsize  uintD;
  1460.     typedef sint/**/intDsize  sintD;
  1461.   #endif
  1462.   #if (intDDsize<=32) || ((intDDsize<=64) && defined(DECALPHA))
  1463.     #define HAVE_DD 1
  1464.     #ifdef ANSI
  1465.       typedef unsigned_int_with_n_bits(intDDsize)  uintDD;
  1466.       typedef signed_int_with_n_bits(intDDsize)    sintDD;
  1467.     #else
  1468.       typedef uint/**/intDDsize  uintDD;
  1469.       typedef sint/**/intDDsize  sintDD;
  1470.     #endif
  1471.   #else
  1472.     #define HAVE_DD 0
  1473.   #endif
  1474.  
  1475. # Auch einige andere Kürzel wie 'oint', 'tint', 'aint', 'cint' werden noch
  1476. # für entsprechende Integer-Typen verwendet werden:
  1477. #   Integertyp     enthält Information äquivalent zu
  1478. #      oint           LISP-Objekt
  1479. #      tint           Typcode eines LISP-Objekts
  1480. #      aint           Adresse eines LISP-Objekts
  1481. #      cint           LISP-Character
  1482.  
  1483. # Üblicherweise ist sizeof(oint) = sizeof(aint) = sizeof(uintL) = 32 Bit.
  1484. # Bei Modell WIDE ist sizeof(oint) > sizeof(uintL).
  1485. # Modell WIDE_HARD steht für sizeof(aint) > sizeof(uintL).
  1486. #   Dieses Modell muß dann gewählt werden, wenn
  1487. #   sizeof(void*) > sizeof(uintL) = 32 Bit ist. Es setzt
  1488. #   sizeof(long) = sizeof(void*) = 64 Bit voraus, denn einige 64-Bit-Zahlen
  1489. #   tauchen als Präprozessor-Konstanten auf.
  1490. # Modell WIDE_SOFT steht für sizeof(oint) = 64 Bit und sizeof(aint) = 32 Bit.
  1491. #   Dieses Modell kann auf jeder 32-Bit-Maschine gewählt werden, wenn der
  1492. #   Compiler (soft- oder hardwaremäßige) 64-Bit-Zahlen hat. Es muß dann
  1493. #   gewählt werden, wenn ansonsten nicht genug Platz für die Typbits in einem
  1494. #   32-Bit-Pointer wäre.
  1495.  
  1496. #ifdef DECALPHA
  1497.   #define WIDE_HARD
  1498. #endif
  1499.  
  1500. #if defined(WIDE) && !(defined(WIDE_HARD) || defined(WIDE_SOFT))
  1501.   #define WIDE_SOFT
  1502. #endif
  1503. #if (defined(WIDE_HARD) || defined(WIDE_SOFT)) && !defined(WIDE)
  1504.   #define WIDE
  1505. #endif
  1506. # Nun ist defined(WIDE) == defined(WIDE_HARD) || defined(WIDE_SOFT)
  1507.  
  1508. #ifdef WIDE_SOFT
  1509.   #ifdef GNU
  1510.     # Benutze die GNU-C-Erweiterungen, um die breiten oints als structs aufzufassen.
  1511.     #define WIDE_STRUCT
  1512.   #endif
  1513.   # Bestimmt die Anordnung der Teile eines oints:
  1514.   #define WIDE_ENDIANNESS TRUE
  1515. #endif
  1516.  
  1517. #if defined(GNU) && (SAFETY >= 3)
  1518.   #if (__GNUC__ >= 2)
  1519.     #if (__GNUC_MINOR__ >= 7) # gcc-2.6.3 Bug umgehen
  1520.       # Typüberprüfungen durch den C-Compiler
  1521.       #define OBJECT_STRUCT
  1522.     #endif
  1523.   #endif
  1524. #endif
  1525.  
  1526.  
  1527. # ###################### Betriebssystem-Routinen ##################### #
  1528.  
  1529. # allgemein standardisierte Konstanten für Steuerzeichen:
  1530.   #define BS    8  #  #\Backspace     Backspace
  1531.   #define TAB   9  #  #\Tab           Tabulator
  1532.   #define LF   10  #  #\Linefeed      Zeilenvorschub
  1533.   #define CR   13  #  #\Return        Carriage return, zum Zeilenanfang
  1534.   #define PG   12  #  #\Page          Form Feed, neue Seite
  1535.  
  1536. #ifdef AMIGAOS
  1537.  
  1538. #include "amiga.c"
  1539.  
  1540. # statement im Unterbrechungsfalle (Ctrl-C gedrückt) ausführen:
  1541. # interruptp(statement);
  1542.   #define interruptp(statement) \
  1543.     { # Ctrl-C-Signal abfragen und löschen:                             \
  1544.       if (SetSignal(0L,(CLISP_ULONG)(SIGBREAKF_CTRL_C)) & (SIGBREAKF_CTRL_C)) \
  1545.         { statement }                                                   \
  1546.     }
  1547.   # vgl. AMIGA.D und exec.library/SetSignal
  1548. # wird verwendet von EVAL, IO, SPVW, STREAM
  1549.  
  1550. #endif # AMIGAOS
  1551.  
  1552. #ifdef RISCOS
  1553.  
  1554. #include "acorn.c"
  1555.  
  1556. # Unterbrechungen noch nicht implementiert.
  1557.   #define interruptp(statement)
  1558.  
  1559. # Verdecken der Funktion read:
  1560.   #define read LISPread
  1561.  
  1562. #endif # RISCOS
  1563.  
  1564. #if defined(UNIX) || defined(DJUNIX) || defined(EMUNIX) || defined(WATCOM) || defined(WIN32_DOS) || defined(WIN32_UNIX)
  1565.  
  1566. #if defined(UNIX) || defined(WIN32_UNIX)
  1567. #include "unix.c"
  1568. #endif
  1569. #ifdef MSDOS
  1570. #include "msdos.c"
  1571. #endif
  1572.  
  1573. # statement im Unterbrechungsfalle ausführen:
  1574. # interruptp(statement);
  1575.  #if defined(UNIX) || (defined(EMUNIX) && !defined(WINDOWS)) || defined(WIN32_UNIX)
  1576.   # Eine Tastatur-Unterbrechung (Signal SIGINT, erzeugt durch Ctrl-C)
  1577.   # wird eine Sekunde lang aufgehoben. In dieser Zeit kann sie mittels
  1578.   # 'interruptp' auf fortsetzbare Art behandelt werden. Nach Ablauf dieser
  1579.   # Zeit wird das Programm nichtfortsetzbar unterbrochen.
  1580.   #define PENDING_INTERRUPTS
  1581.   extern uintB interrupt_pending;
  1582.   #define interruptp(statement)  if (interrupt_pending) { statement; }
  1583.  #endif
  1584.  #if defined(DJUNIX)
  1585.   # DJUNIX kennt keine Signale, nicht mal Ctrl-C.
  1586.   # Hat auch kein alarm() oder ualarm().
  1587.   #define interruptp(statement)  if (_go32_was_ctrl_break_hit()) { statement; }
  1588.  #endif
  1589.  #if defined(WATCOM) && !defined(WINDOWS)
  1590.   # WATCOM hat kein alarm() oder ualarm().
  1591.   #define interruptp(statement)  FALSE
  1592.  #endif
  1593.  #if defined(WINDOWS)
  1594.   # Eine Unterbrechung (erzeugt durch einen Windows-Event) wird aufgehoben.
  1595.   # Sie kann mittels 'interruptp' auf fortsetzbare Art behandelt werden.
  1596.   #define PENDING_INTERRUPTS
  1597.   extern uintB interrupt_pending;
  1598.   #define interruptp(statement)  if (interrupt_pending) { statement; }
  1599.  #endif
  1600.  #if defined(WIN32_UNIX) || defined(WIN32_DOS)
  1601.    #define PENDING_INTERRUPTS
  1602.    extern uintB interrupt_pending;
  1603.    #define interruptp(statement) if (interrupt_pending) { statement; }
  1604.  #endif
  1605. # wird verwendet von EVAL, IO, SPVW, STREAM
  1606.  
  1607. # Verdecken der Systemfunktion read:
  1608.   #define read LISPread
  1609. # Consensys macht "#define DS 3". Grr...
  1610.   #undef DS
  1611. # 386BSD macht "#define CBLOCK 64". Grr...
  1612.   #undef CBLOCK
  1613. # BSDI 1.1 macht "#define IMMUTABLE". Grr...
  1614.   #ifdef __bsdi__
  1615.     #undef IMMUTABLE
  1616.   #endif
  1617.  
  1618. #endif # UNIX || DJUNIX || EMUNIX || WATCOM
  1619.  
  1620. # ##################### Weitere System-Abhängigkeiten ##################### #
  1621.  
  1622. # Erst solche, die bis auf die Lisp-Ebene hin sichtbar sind:
  1623.  
  1624. # Einstellung der Tabelle von Zeichennamen:
  1625.   #ifdef AMIGA
  1626.     #define AMIGA_CHARNAMES
  1627.   #endif
  1628.   #ifdef MSDOS
  1629.     #define MSDOS_CHARNAMES
  1630.   #endif
  1631.   #if defined(UNIX) || defined(RISCOS) || defined(WIN32_UNIX)
  1632.     #define UNIX_CHARNAMES
  1633.   #endif
  1634. # Bei Erweiterung: CONSTOBJ, CHARSTRG, FORMAT.LSP erweitern.
  1635.  
  1636. # Ob ein Stream *KEYBOARD-INPUT* gebildet wird,
  1637. # und ob er für den Stream *TERMINAL-IO* verwendet wird:
  1638.   #if defined(MSDOS) || (defined(UNIX) && !defined(NEXTAPP) || defined(MAYBE_NEXTAPP)) || defined(RISCOS)
  1639.     #define KEYBOARD
  1640.     #if 0 # || defined(WINDOWS) ??
  1641.       #define TERMINAL_USES_KEYBOARD
  1642.     #endif
  1643.   #endif
  1644. # Bei Erweiterung: STREAM, USER1.LSP erweitern.
  1645.  
  1646. # Ob wir die GNU Readline-Library für *TERMINAL-IO* benutzen:
  1647.   #if ((defined(UNIX) && !defined(NEXTAPP)) || (defined(MSDOS) && !defined(WATCOM) && !defined(WINDOWS))) && !defined(NO_READLINE)
  1648.     # Auf WATCOM ist die Readline-Library noch nicht portiert.
  1649.     # Unter Windows und bei NEXTAPP haben wir Besseres vor.
  1650.     #define GNU_READLINE
  1651.   #endif
  1652. # Bei Erweiterung: READLINE erweitern.
  1653.  
  1654. # Ob es Window-Streams und eine Package SCREEN gibt:
  1655.   #if defined(MSDOS) || (defined(UNIX) && !defined(NEXTAPP) || defined(MAYBE_NEXTAPP)) || defined(WIN32_UNIX)
  1656.     #define SCREEN
  1657.   #endif
  1658. # Bei Erweiterung: STREAM erweitern (viel Arbeit!).
  1659.  
  1660. # Ob es File-Handle-Streams gibt:
  1661.   #if defined(UNIX) || defined(MSDOS) || defined(AMIGAOS) # || defined(RISCOS)
  1662.     #define HANDLES
  1663.   #endif
  1664. # Bei Erweiterung: STREAM erweitern.
  1665.  
  1666. # Ob es Pipe-Streams gibt:
  1667.   #if defined(UNIX) || defined(EMUNIX_PORTABEL)
  1668.     #define PIPES
  1669.     #if defined(UNIX) || defined(EMUNIX_PORTABEL)
  1670.       #define PIPES2  # bidirektionale Pipes
  1671.     #endif
  1672.   #endif
  1673. # Bei Erweiterung: STREAM und USER2.LSP erweitern.
  1674.  
  1675. # Ob es Socket-Streams gibt:
  1676.   #if defined(UNIX) && defined(HAVE_GETHOSTBYNAME)
  1677.     # Damit Socket-Streams sinnvoll sind, muß socket.d compilierbar sein.
  1678.     # Dazu muß netdb.h oder sun/netdb.h existieren, was zufällig auch der
  1679.     # Existenz von gethostbyname() entspricht.
  1680.     #define XSOCKETS
  1681.     #define SOCKET_STREAMS
  1682.   #endif
  1683. # Bei Erweiterung: STREAM erweitern.
  1684.  
  1685. # Whether there are generic streams:
  1686.   #if 1
  1687.     #define GENERIC_STREAMS
  1688.   #endif
  1689. # Bei Erweiterung: Nichts weiter zu tun.
  1690.  
  1691. # Ob die für die Funktionen MACHINE-TYPE, MACHINE-VERSION, MACHINE-INSTANCE
  1692. # benötigte Information vom Betriebssystem geholt werden kann:
  1693.   #ifdef UNIX
  1694.     #define MACHINE_KNOWN
  1695.   #endif
  1696. # Bei Erweiterung: MISC erweitern.
  1697.  
  1698. # Ob es LOGICAL-PATHNAMEs gibt:
  1699.   #if 1
  1700.     #define LOGICAL_PATHNAMES
  1701.   #endif
  1702. # Bei Erweiterung: Nichts weiter zu tun.
  1703.  
  1704. # Ob die Funktion USER-HOMEDIR-PATHNAME existiert:
  1705.   #if defined(UNIX) || defined(RISCOS) || defined(WIN32_UNIX)
  1706.     #define USER_HOMEDIR
  1707.   #endif
  1708. # Bei Erweiterung: PATHNAME erweitern.
  1709.  
  1710. # Ob ein Stream *PRINTER-OUTPUT* bzw. eine Funktion MAKE-PRINTER-STREAM
  1711. # zur Verfügung gestellt werden:
  1712.   #ifdef AMIGAOS
  1713.     #define PRINTER_AMIGAOS
  1714.   #endif
  1715. # Ob es Printer-Streams gibt:
  1716.   #if defined(PRINTER_AMIGAOS)
  1717.     #define PRINTER
  1718.   #endif
  1719. # Bei Erweiterung: STREAM erweitern.
  1720.  
  1721. # Ob externe Kommunikation via Rexx unterstützt wird.
  1722.   #ifdef AMIGAOS
  1723.     #define REXX
  1724.     # define REXX_SERVER  # noch nicht ?JCH?
  1725.   #endif
  1726. # Bei Erweiterung: REXX erweitern.
  1727.  
  1728. # Ob Graphik-Operationen unterstützt werden.
  1729.   #if (defined(EMUNIX) && !defined(WINDOWS)) || defined(UNIX_LINUX)
  1730.     #define GRAPHICS
  1731.     #define GRAPHICS_SWITCH  # Umschalten zwischen Text-Modus und Grafik-Modus
  1732.   #endif
  1733. # Bei Erweiterung: GRAPH erweitern.
  1734.  
  1735. # Ob das Betriebssystem ein Environment verwaltet, das Strings zu Strings
  1736. # assoziiert:
  1737.   #if defined(UNIX) || defined(MSDOS) || defined(AMIGAOS) || defined(RISCOS) || defined(WIN32_UNIX)
  1738.     #define HAVE_ENVIRONMENT
  1739.   #endif
  1740. # Bei Erweiterung: Nichts weiter zu tun.
  1741.  
  1742. # Ob das Betriebssystem einen bevorzugten Kommando-Interpreter hat:
  1743.   #if defined(UNIX) || defined(MSDOS) || defined(AMIGAOS) || defined(RISCOS) || defined(WIN32_UNIX)
  1744.     #define HAVE_SHELL
  1745.   #endif
  1746. # Bei Erweiterung: PATHNAME erweitern.
  1747.  
  1748. # Ob ein Foreign Function Interface zur Verfügung gestellt wird:
  1749.   #if (defined(UNIX) && !defined(UNIX_BINARY_DISTRIB)) || defined(DYNAMIC_FFI)
  1750.     #define HAVE_FFI
  1751.   #endif
  1752. # Bei Erweiterung: ??
  1753.  
  1754. # Ob ein externer Disassembler zur Verfügung steht:
  1755.   #if defined(UNIX) || defined(WIN32_UNIX)
  1756.     #define HAVE_DISASSEMBLER
  1757.   #endif
  1758. # Bei Erweiterung: PATHNAME erweitern.
  1759.  
  1760. # Dann die, die nur intern bedeutsam sind:
  1761.  
  1762. # Ob die GC nicht mehr referenzierte Files schließt:
  1763.   #if defined(UNIX) || defined(WINDOWS) || defined(AMIGAOS) || defined(RISCOS) || defined(WIN32_UNIX)
  1764.     #define GC_CLOSES_FILES
  1765.   #endif
  1766. # Bei Erweiterung: nichts zu tun.
  1767.  
  1768. # Wie die Zeitmessungen durchgeführt werden:
  1769.   #if defined(WIN32_UNIX) || defined(WIN32_DOS)
  1770.     #define TIME_WIN32
  1771.   #elif defined(MSDOS)
  1772.     #define TIME_MSDOS
  1773.   #endif
  1774.   #ifdef AMIGAOS
  1775.     #define TIME_AMIGAOS
  1776.   #endif
  1777.   #ifdef RISCOS
  1778.     #define TIME_RISCOS
  1779.   #endif
  1780.   #ifdef UNIX
  1781.     #if defined(HAVE_GETTIMEOFDAY) || defined(HAVE_FTIME)
  1782.       #define TIME_UNIX
  1783.     #elif defined(HAVE_TIMES_CLOCK)
  1784.       #define TIME_UNIX_TIMES
  1785.     #endif
  1786.   #endif
  1787.   #if defined(TIME_MSDOS) || defined(TIME_AMIGAOS) || defined(TIME_UNIX_TIMES) || defined(TIME_RISCOS)
  1788.     # Die Zeitauflösung ist nur mittel, so daß man für Zeitdifferenz-Messungen
  1789.     # ohne weiteres eine 32-Bit-Zahl nehmen kann.
  1790.     #define TIME_1
  1791.     # Wir holen die Uhrzeit einmal beim System-Start. Alle weiteren
  1792.     # Uhrzeiten werden relativ zu dieser genommen.
  1793.     #define TIME_RELATIVE
  1794.   #endif
  1795.   #if defined(TIME_UNIX) || defined(TIME_WIN32)
  1796.     # Die Zeitauflösung ist so hoch, daß man für Zeitdifferenz-Messungen gleich
  1797.     # zwei 32-Bit-Zahlen braucht: Sekunden und Sekundenbruchteile.
  1798.     #define TIME_2
  1799.     # In diesem Fall können wir auch gleich immer mit absoluten und genauen
  1800.     # Uhrzeiten rechnen.
  1801.     #define TIME_ABSOLUTE
  1802.   #endif
  1803. # Bei Erweiterung: TIME erweitern.
  1804.  
  1805. # Ob die Funktion SYS::%SLEEP ein oder zwei Argumente übergeben bekommt:
  1806.   #if defined(TIME_MSDOS) || defined(TIME_AMIGAOS) || defined(TIME_RISCOS)
  1807.     #define SLEEP_1
  1808.   #endif
  1809.   #if defined(TIME_UNIX) || defined(TIME_UNIX_TIMES) || defined(TIME_WIN32)
  1810.     #define SLEEP_2
  1811.   #endif
  1812. # Bei Erweiterung: TIME, DEFS1.LSP erweitern.
  1813.  
  1814. # Ob das Betriebssystem uns die Run-Time liefern kann, oder ob wir sie
  1815. # selber akkumulieren müssen (was bei Multitasking-Betriebssystemen ein wenig
  1816. # verfälschend ist: AMIGAOS kann diese Information nicht liefern, RISCOS??):
  1817.   #if defined(UNIX) || defined(WIN32_UNIX) || defined(WIN32_DOS)
  1818.     #define HAVE_RUN_TIME
  1819.   #endif
  1820. # Bei Erweiterung: TIME erweitern.
  1821.  
  1822. # Ob das Betriebssystem Virtual Memory zur Verfügung stellt.
  1823.   #if defined(UNIX) || defined(EMUNIX) || defined(DJUNIX) || defined(WINDOWS) || defined(WIN32_UNIX) || defined(WIN32_DOS)
  1824.     #define VIRTUAL_MEMORY
  1825.   #endif
  1826. # Bei Erweiterung: nichts zu tun.
  1827.  
  1828. # Ob das Betriebssystem Unterbrechungen (Ctrl-C o.ä.) als Signal auszuliefern
  1829. # in der Lage ist:
  1830.   #if defined(UNIX) || ((defined(EMUNIX) || defined(WATCOM)) && !defined(WINDOWS)) || defined(RISCOS) || defined(WIN32_UNIX) || defined(WIN32_DOS)
  1831.     #define HAVE_SIGNALS
  1832.   #endif
  1833. # Ob wir auf asynchrone Signale auch reagieren können:
  1834. # (Bei WIDE_SOFT ist das Schreiben eines Pointers i.a. keine Elementar-Operation mehr!)
  1835.   #if defined(WIDE_SOFT) && !(defined(GNU) && defined(SPARC))
  1836.     #define NO_ASYNC_INTERRUPTS
  1837.   #endif
  1838. # Bei Erweiterung: SPVW erweitern, interruptp() schreiben.
  1839.  
  1840. # Arten der Pathname-Verwaltung:
  1841.   #ifdef AMIGAOS
  1842.     #define PATHNAME_AMIGAOS
  1843.   #endif
  1844.   #ifdef MSDOS
  1845.     #if defined(OS2) || defined(WIN32_DOS)
  1846.     #define PATHNAME_OS2
  1847.    #else
  1848.     #define PATHNAME_MSDOS
  1849.    #endif
  1850.   #endif
  1851.   #ifdef RISCOS
  1852.     #define PATHNAME_RISCOS
  1853.   #endif
  1854.   #ifdef UNIX
  1855.     #define PATHNAME_UNIX
  1856.   #endif
  1857.   #ifdef WIN32_UNIX
  1858.     #define PATHNAME_UNIX
  1859.   #endif
  1860. # Die Komponenten von Pathnames:
  1861.   #if defined(PATHNAME_AMIGAOS) || defined(PATHNAME_MSDOS) || defined(PATHNAME_OS2)
  1862.     #define HAS_HOST      0
  1863.     #define HAS_DEVICE    1
  1864.     #define HAS_VERSION   0
  1865.   #endif
  1866.   #ifdef PATHNAME_UNIX
  1867.     #define HAS_HOST      0
  1868.     #define HAS_DEVICE    0
  1869.     #define HAS_VERSION   0
  1870.   #endif
  1871.   #ifdef PATHNAME_RISCOS
  1872.     #define HAS_HOST      1
  1873.     #define HAS_DEVICE    1
  1874.     #define HAS_VERSION   0
  1875.     #define FLIP_NAME_TYPE # Name und Type zum Betriebssystem hin vertauschen
  1876.   #endif
  1877. # Handhabung der File "Extension" (pathname-type):
  1878.   #ifdef PATHNAME_MSDOS
  1879.     #define PATHNAME_EXT83  # Name und Type getrennt, Abschneiden nach 8 bzw. 3 Zeichen
  1880.   #endif
  1881.   #if defined(PATHNAME_RISCOS)
  1882.     #define PATHNAME_EXT  # Name und Type getrennt, aber keine Längenbegrenzung
  1883.   #endif
  1884.   #if defined(PATHNAME_UNIX) || defined(PATHNAME_AMIGAOS) || defined(PATHNAME_OS2)
  1885.     #define PATHNAME_NOEXT  # Keine explizite Extension.
  1886.   #endif
  1887. # Bei Erweiterung: PATHNAME erweitern.
  1888.  
  1889. # Ob es einen Typ FOREIGN gibt (eine Verpackung für diverse Pointer):
  1890.   #if defined(DYNAMIC_FFI) || defined(AMIGAOS)
  1891.     #define FOREIGN  void*
  1892.   #endif
  1893. # Bei Erweiterung: Nichts weiter zu tun.
  1894.  
  1895. # Ob Simple-Strings am Stück an Streams durchgereicht werden:
  1896.   #if defined(UNIX) || defined(AMIGAOS) || defined(OS2) || defined(RISCOS)
  1897.     #define STRM_WR_SS
  1898.   #endif
  1899. # Bei Veränderung: Nichts weiter zu tun.
  1900.  
  1901. # Ob an diversen Schlüsselstellen der STACK überprüft wird:
  1902.   #define STACKCHECKS  (SAFETY >= 1) # beim Aufruf von SUBRs und FSUBRs
  1903.   #define STACKCHECKC  (SAFETY >= 1) # beim Abinterpretieren compilierter Closures
  1904.   #define STACKCHECKR  (SAFETY >= 1) # im Reader
  1905.   #define STACKCHECKP  (SAFETY >= 1) # im Printer
  1906. # Bei Veränderung: Nichts weiter zu tun.
  1907.  
  1908. # Ob subr_tab statisch zu initialisieren versucht wird.
  1909.   #if (1 || defined(ANSI) || defined(GNU)) && !(defined(WIDE_SOFT) && !defined(WIDE_STRUCT)) && !defined(WATCOM)
  1910.     #define INIT_SUBR_TAB
  1911.   #endif
  1912. # Bei Veränderung: Nichts weiter zu tun.
  1913.  
  1914. # Ob symbol_tab statisch zu initialisieren versucht wird.
  1915. # (Es macht die Initialisierung einfacher, aber bei GNU-C auf einem Amiga
  1916. # reicht der Platz zum Compilieren von SPVWTABS nicht.
  1917. # WATCOM stürzt ab mit "Abnormal program termination: Page fault".
  1918. # Und Nicht-ANSI-Compiler verweigern das Initialisieren von Unions.)
  1919.   #if (defined(ANSI) || defined(GNU)) && !(defined(WIDE_SOFT) && !defined(WIDE_STRUCT)) && !(defined(AMIGA) || defined(WATCOM))
  1920.     #define INIT_SYMBOL_TAB
  1921.   #endif
  1922. # Bei Veränderung: Nichts weiter zu tun.
  1923.  
  1924. # Ob object_tab statisch zu initialisieren versucht wird.
  1925.   #if (1 || defined(ANSI) || defined(GNU)) && !(defined(WIDE_SOFT) && !defined(WIDE_STRUCT)) && !defined(WATCOM)
  1926.     #define INIT_OBJECT_TAB
  1927.   #endif
  1928. # Bei Veränderung: Nichts weiter zu tun.
  1929.  
  1930.  
  1931. # ############### Liste von implementierten CLtL2-Features ################ #
  1932.  
  1933. #undef  X3J13_003
  1934. #define X3J13_005  # 18.5.1993
  1935. #define X3J13_014  # 22.1.1995
  1936. #define X3J13_149  # 22.7.1993
  1937. #define X3J13_161  # 20.5.1993
  1938. #define X3J13_175  # 25.7.1993
  1939.  
  1940.  
  1941. # ##################### Speicherstruktur von Objekten ##################### #
  1942.  
  1943. /*
  1944.  
  1945. FESTLEGUNG DER BEDEUTUNG DES TYP-INFOBYTES UND DER SPEICHERFORMATE DER
  1946. ======================================================================
  1947.                        VERSCHIEDENEN DATENTYPEN
  1948.                        ========================
  1949.  
  1950. 1. Typ-Infobyte
  1951. ---------------
  1952.  
  1953. Das Typ-Infobyte besteht aus den höchstwertigen 8 Bits (Bits 24-31)
  1954. des Langworts, das ein Datum repräsentiert. Außer in einigen speziellen
  1955. Fällen ("kleine Daten" wie Zeichen, Fixnums u.ä.) enthalten die übrigen
  1956. 24 Bits die Speicheradresse des Objekts (wie Cons, Symbol, Vektor...).
  1957. Bit 7 des Infobytes (Bit 31 des Langworts) dient als Markierungsbit
  1958. für den Garbage Collector und ist außerhalb desselben stets gelöscht
  1959. (einzige Ausnahme: Hilfsroutine für PRINT-CIRCLE). Bit 6 (Bit 30) ist
  1960. genau dann gesetzt, wenn es sich um ein Cons handelt (CONS_BIT), Bit 5
  1961. (Bit 29) genau dann, wenn es sich um ein Symbol handelt (SYMBOL_BIT).
  1962. Bit 4 (Bit 28) ist nur bei Zahlen gesetzt (NUMBER_BIT). Die übrigen
  1963. 4 Bits dienen der näheren Unterscheidung. Die Bedeutungen im einzelnen:
  1964.  
  1965. Bits 76543210       Bedeutung (Typ)
  1966.  
  1967.      00000000       Maschinenpointer  (*)
  1968.      00000???       array
  1969.      000000??       einfacher vector (d.h. eindimensionaler Array
  1970.                                       ohne zusätzl. Features)
  1971.      00000001       simple-bit-vector
  1972.      00000010       simple-string
  1973.      00000011       simple-vector
  1974.      000001??       übrige Arrays
  1975.      00000100       sonstige Arrays (Rang /= 1 oder andere Elementtypen)
  1976.      00000101       bit-vector oder byte-vector, kein simple-bit-vector
  1977.      00000110       string, kein simple-string
  1978.      00000111       (vector t), kein simple-vector
  1979.      00001...       Records:
  1980.      00001000        closure
  1981.      00001001        structure
  1982.      00001010        stream
  1983.      00001011        sonstige (package, readtable, hash-table ...)
  1984.      00001100        instance
  1985.      00001101       character         (*)
  1986.      00001110       subr              (*)
  1987.      00001111....0  frame-pointer     (*) [STACK muß Alignment 2 haben!]
  1988.      000011110...1  read-label        (*)
  1989.      000011111...1  system            (*) (UNBOUND, SPECDECL u.ä.)
  1990.      0001???V       number (V = Vorzeichen bei reellen Zahlen)
  1991.      0001000V       fixnum            (*)
  1992.      0001001V       short-float       (*)
  1993.      0001010V       bignum
  1994.      0001011V       single-float
  1995.      0001100V       ratio
  1996.      0001101V       double-float
  1997.      00011100       complex
  1998.      0001111V       long-float
  1999.      0010????       symbol
  2000.      0100????       cons
  2001.  
  2002. (Objekte der mit (*) gekennzeichneten Typen sind nicht im Speicher
  2003. verschiebbar und brauchen daher bei der GC nicht berücksichtigt zu
  2004. werden.)
  2005.  
  2006. 2. Speicherformate
  2007. ------------------
  2008.  
  2009. 2.0. Maschinenpointer
  2010.  
  2011. Ein Maschinenpointer ist eine fürs LISP-System bedeutungslose Adresse.
  2012. (Beispielsweise Pointer in den SP oder in den STACK, die keine Typinfo
  2013. tragen. Können z.B. vorübergehend im Stack liegen.)
  2014. Maschinenpointer, die nicht in 24 Bit passen, müssen als Foreign-Pointer
  2015. in einen Simple-Bit-Vector verpackt werden.
  2016.  
  2017. 2.1. CONS
  2018.  
  2019. Ein Cons umfaßt 8 Byte, aufgeteilt in 2 Langworte. Das erste enthält
  2020. den CDR, das zweite den CAR.
  2021.  
  2022.      +-+-----+       +-------+-------+
  2023.      |T| ADR |  ADR: |  CDR  |  CAR  |
  2024.      +-+-----+       +-------+-------+
  2025.  
  2026. ADR: Adresse des Records für CAR und CDR
  2027. T: Typ-Info für CONS #b0100????
  2028. Conses befinden sich im Speicherbereich für Zwei-Pointer-Objekte.
  2029.  
  2030. 2.2. SYMBOL
  2031.  
  2032. Ein Symbol umfaßt 24 Byte (6 Langworte). Das zweite enthält den aktuellen
  2033. dynamischen Wert, das dritte die globale Funktionsdefinition (wenn nicht
  2034. vorhanden, steht in beiden Fällen dort der Wert #UNBOUND). Das vierte
  2035. Langwort enthält die Property-Liste (zunächst NIL), das fünfte den Namen
  2036. des Symbols (ein [einfacher] String). Im sechsten Langwort befindet sich
  2037. die Home-Package, und das erste ist frei für die GC, bis auf einige
  2038. Flags (KEYWORD, CONSTANT, SPECIAL).
  2039.  
  2040.      +-+-----+       +-------+-------+-------+-------+-------+-------+
  2041.      |T| ADR |  ADR: |F      | VALUE | FUNCT.| PLIST | NAME  | PACK. |
  2042.      +-+-----+       +-------+-------+-------+-------+-------+-------+
  2043.  
  2044. ADR: Adresse der Recordstruktur
  2045. T: Typ-Info für SYMBOL #b0010????
  2046. F: Bits 2..0 sind die Flags
  2047. Symbole befinden sich im Speicherbereich für Objekte variabler Länge.
  2048.  
  2049. 2.3. CHARACTER
  2050.  
  2051. Code, Bit- und Font-Attribute befinden sich direkt im darstellenden
  2052. Langwort: Bits 0-7 geben den (ASCII-)Code des Zeichens, Bits 8-11 sind
  2053. die Control-Bits (control: Bit 8, meta: Bit 9, super: Bit 10, hyper:
  2054. Bit 11) und Bits 12-15 die Fontnummer (0 bis 15); die Bits 16-23 sind
  2055. stets 0, nur Bit 16 wird bei den Streams als Markierung benutzt.
  2056.  
  2057.      +-+-+--+-+
  2058.      |T|0|FB|C|
  2059.      +-+-+--+-+
  2060.  
  2061. T = #b00001100 Typ-Info für CHARACTER
  2062. 0 = #b00000000
  2063. F = 4 Bits für Fontnummer (obere 4 Bits)
  2064. B = 4 Control-Bits (untere 4 Bits)
  2065. C = 8 Bits für Code
  2066.  
  2067. 2.4. SUBR, FSUBR
  2068.  
  2069. Die unteren 24 Bits enthalten die Startadresse des Maschinenunter-
  2070. programms, das die betreffende Funktion ausführt (zum Format des
  2071. Codes siehe unten).
  2072.  
  2073.      +-+-----+
  2074.      |T| ADR |
  2075.      +-+-----+
  2076.  
  2077. T = #b00001101 oder #b00001110 Typ-Info für SUBR oder FSUBR
  2078.  
  2079. 2.5. FRAME-POINTER
  2080.  
  2081. Die unteren 24 Bits enthalten die Adresse des Frame-Anfangs (im LISP-
  2082. Stack), "Anfang" heißt Adresse des Langworts mit dem Frame-Infobyte.
  2083.  
  2084.      +-+-----+
  2085.      |T| ADR |
  2086.      +-+-----+
  2087.  
  2088. T = #b00001111 Typ-Info für FRAME-POINTER
  2089. Zum Aufbau der Frames siehe EVALBIBL.
  2090.  
  2091. 2.6. READ-LABEL
  2092.  
  2093. Die unteren 22 Bits (Bit 23 ist gesetzt, Bit 22 gelöscht) enthalten
  2094. die Nummer n des Labels #n= .
  2095.  
  2096.      +-+-----+
  2097.      |T| VAL |
  2098.      +-+-----+
  2099.  
  2100. T = #b00001111 Typ-Info für SYSTEM, VAL = #b10??????????????????????
  2101.  
  2102. 2.7. SYSTEM
  2103.  
  2104. Die unteren 22 Bits (Bits 22,23 sind gesetzt) enthalten irgendeine
  2105. spezielle Markierung (z.B. #b1111111111111111111111 für #UNBOUND).
  2106.  
  2107.      +-+-----+
  2108.      |T|FLAG |
  2109.      +-+-----+
  2110.  
  2111. T = #b00001111 Typ-Info für SYSTEM, FLAG = #b11??????????????????????
  2112.  
  2113. 2.8. FIXNUM
  2114.  
  2115. Bit 24 enthält das Vorzeichen (1 für negativ, 0 für >= 0), die unteren
  2116. 24 Bits enthalten den Wert in Zweierkomplementdarstellung (der Werte-
  2117. bereich geht also von -2^24 bis +2^24-1).
  2118.  
  2119.      +-+-----+
  2120.      |T|WERT |
  2121.      +-+-----+
  2122.  
  2123. T = #b0001000V Typ-Info für FIXNUM
  2124.  
  2125. 2.9. BIGNUM
  2126.  
  2127. Bignums werden in Zweierkomplementdarstellung variabler Länge abge-
  2128. speichert. Das höchstwertige Bit gibt das Vorzeichen an.
  2129. Die Zahl ist durch einen Vektor von Bits gegeben:
  2130.  
  2131.       +-+-----+        +-------+---+--------------------+
  2132.       |T| ADR |   ADR: |       |LEN|  ...   DATA   ...  |
  2133.       +-+-----+        +-------+---+--------------------+
  2134.  
  2135. ADR: Adresse des Zahlvektors
  2136. T = #b0001010V Typ-Info für BIGNUM (V = Vorzeichen)
  2137. LEN = Länge der Zahl (in Digits), ( >= 2 )
  2138. DATA = Zahl in Zweierkomplementdarstellung
  2139. Bignums befinden sich im Speicherbereich für Objekte variabler Länge.
  2140.  
  2141. 2.10. SHORT-FLOAT
  2142.  
  2143. Bit 24 = Vorzeichen, Rest = Wert (Bits 16-23 für Exponent, Bits 0-15
  2144. für Mantisse)
  2145.  
  2146.      +-+-----+
  2147.      |T|WERT |
  2148.      +-+-----+
  2149.  
  2150. T = #b0001001V Typ-Info für SHORT-FLOAT
  2151.  
  2152. 2.11. SINGLE-FLOAT
  2153.  
  2154. Wird im Bereich für Objekte variabler Länge abgespeichert:
  2155.  
  2156.       +-+-----+         +-------+-------+
  2157.       |T| ADR |    ADR: |       | WERT  |
  2158.       +-+-----+         +-------+-------+
  2159.  
  2160. ADR: Adresse des Zahl-"Vektors"
  2161. T: Typ-Info für SINGLE-FLOAT #b0001011V (V = Vorzeichen)
  2162. WERT: Zahlwert (1 Bit Vorz., 8 Bit Exponent, 23 Bit Mantisse)
  2163. Single-Floats befinden sich im Speicherbereich für Objekte variabler Länge.
  2164.  
  2165. 2.12. DOUBLE-FLOAT
  2166.  
  2167. Wird im Bereich für Objekte variabler Länge abgespeichert:
  2168.  
  2169.       +-+-----+         +-------+---------------+
  2170.       |T| ADR |    ADR: |       |     WERT      |
  2171.       +-+-----+         +-------+---------------+
  2172.  
  2173. ADR: Adresse des Zahl-"Vektors"
  2174. T: Typ-Info für DOUBLE-FLOAT #b0001101V (V = Vorzeichen)
  2175. WERT: Zahlwert (1 Bit Vorz., 11 Bit Exponent, 52 Bit Mantisse)
  2176. Double-Floats befinden sich im Speicherbereich für Objekte variabler Länge.
  2177.  
  2178. 2.13. LONG-FLOAT
  2179.  
  2180. Long-floats sind Realzahlen variabler Genauigkeit (precision). Sie
  2181. werden als Vektoren abgespeichert (ähnlich wie BIGNUMs).
  2182.  
  2183.       +-+-----+       +-------+---+-------+------------------+
  2184.       |T| ADR |  ADR: |       |LEN| EXPO  | ... MANTISSE ... |
  2185.       +-+-----+       +-------+---+-------+------------------+
  2186.  
  2187. ADR: Adresse des Zahlvektors
  2188. T = #b0001111V Typ-Info für LONG-FLOAT (V = Vorzeichen)
  2189. LEN = Länge der Mantisse in Digits
  2190. EXPO = Exponent (in Zweierkomplementdarstellung)
  2191. MANTISSE = Mantisse (16*LEN Bits)
  2192. Long-Floats befinden sich im Speicherbereich für Objekte variabler Länge.
  2193.  
  2194. 2.14. RATIO
  2195.  
  2196. Brüche werden wie CONSes abgespeichert:
  2197.  
  2198.      +-+-----+       +-------+-------+
  2199.      |T| ADR |  ADR: |  NUM  | DENOM |
  2200.      +-+-----+       +-------+-------+
  2201.  
  2202. ADR: Adresse des Records für Zähler und Nenner
  2203. T: Typ-Info für RATIO #b0001100V (V = Vorzeichen)
  2204. NUM: Zähler (FIXNUM oder BIGNUM /= 0 mit Vorzeichen V)
  2205. DENOM: Nenner (FIXNUM oder BIGNUM, positiv, > 1)
  2206. Zähler und Nenner sind teilerfremde ganze Zahlen.
  2207. Ratios befinden sich im Speicherbereich für Zwei-Pointer-Objekte.
  2208.  
  2209. 2.15. COMPLEX
  2210.  
  2211. Komplexe Zahlen werden wie CONSes abgespeichert:
  2212.  
  2213.      +-+-----+       +-------+-------+
  2214.      |T| ADR |  ADR: | REAL  | IMAG  |
  2215.      +-+-----+       +-------+-------+
  2216.  
  2217. ADR2 Adresse des Records für Real-  und Imaginärteil
  2218. T: Typ-Info für COMPLEX #b00011100
  2219. REAL: Realteil (NUMBER)
  2220. IMAG: Imaginärteil (NUMBER, /= INTEGER 0)
  2221. Complexs befinden sich im Speicherbereich für Zwei-Pointer-Objekte.
  2222.  
  2223. 2.16. SIMPLE-VECTOR
  2224.  
  2225. Simple-Vectors sind Records von LISP-Objekten:
  2226.  
  2227.       +-+-----+      +-------+-------+-------+-----+-------+
  2228.       |T| ADR | ADR: |       |  LEN  | OBJ1  | ... | OBJn  |
  2229.       +-+-----+      +-------+-------+-------+-----+-------+
  2230.  
  2231. ADR: Adresse des Records
  2232. T: Typ-Info für SIMPLE-VECTOR #b00000011
  2233. LEN: Anzahl n der Objekte im Vektor
  2234. OBJi: LISP-Objekte (die Vektor-Elemente)
  2235. Simple-Vectors befinden sich im Speicherbereich für Objekte variabler Länge.
  2236.  
  2237. 2.17. SIMPLE-BIT-VECTOR
  2238.  
  2239.       +-+-----+      +-------+-------+------------------+
  2240.       |T| ADR | ADR: |       |  LEN  |  ...  BITS  ...  |
  2241.       +-+-----+      +-------+-------+------------------+
  2242.  
  2243. ADR: Adresse des Bit-Vektors
  2244. T: Typ-Info für SIMPLE-BIT-VECTOR #b00000001
  2245. LEN: Länge des Vektors (Anzahl Bits)
  2246. BITS: Die Bits des Vektors, aufgefüllt auf durch 16 teilbare Anzahl
  2247.       (Bit Nummer x ist Bit (7-(x mod 8)) im Byte (ADR+DATA_+(x div 8)).)
  2248. Simple-Bit-Vectors befinden sich im Speicherbereich für Objekte variabler Länge.
  2249.  
  2250. 2.18. SIMPLE-STRING
  2251.  
  2252.       +-+-----+      +-------+-------+-------------------+
  2253.       |T| ADR | ADR: |       |  LEN  |  ...  CHARS  ...  |
  2254.       +-+-----+      +-------+-------+-------------------+
  2255.  
  2256. ADR: Adresse des Zeichen-Vektors
  2257. T: Typ-Info für SIMPLE-STRING #b00000010
  2258. LEN: Anzahl Zeichen im String
  2259. CHARS: Die Zeichen (im ASCII-Code, aufgefüllt auf gerade Anzahl)
  2260. Simple-Strings befinden sich im Speicherbereich für Objekte variabler Länge.
  2261.  
  2262. 2.19. ARRAY
  2263.  
  2264.       +-+-----+
  2265.       |T| ADR |
  2266.       +-+-----+
  2267.  
  2268.       +-------+-+-+---+-------+-------+-------+-------+-----+-------+-------+
  2269. ADR:  |       |F| |RK | DATA  | TSIZE +[D.OFF]| DIM1  | ... | DIMn  |[FILLP]|
  2270.       +-------+-+-+---+-------+-------+-------+-------+-----+-------+-------+
  2271.  
  2272. ADR: Adresse des Datenrecords für den Array
  2273. T: #b000001?? Typ-Info für Array
  2274. F: nähere Information (8 Bits):
  2275.      Bit 7: 1 = adjustable
  2276.      Bit 6: 1 = Fill-Pointer ist vorhanden (nur bei n = 1 möglich)
  2277.      Bit 5: 1 = displaced
  2278.      Bit 4: 1 = Platz für Displaced-Offset ist vorhanden
  2279.               (<==> Array adjustable oder displaced)
  2280.      Bits 0-3: Element-Typ, im Fall T = #b00000111
  2281.           nötig: T, BIT, STRING-CHAR
  2282.           wünschenswert: SINGLE-FLOAT, LONG-FLOAT, evtl. FIXNUM
  2283.              (dann müssen aber die Macros VECTORP und ARRAY1P in
  2284.               BIBTYPE geändert werden!)
  2285.            Bit 3210       Bedeutung (Element-Typ)
  2286.                1000          BIT
  2287.                0001          2BIT
  2288.                0010          4BIT
  2289.                0011          8BIT
  2290.                0100          16BIT
  2291.                0101          32BIT
  2292.                1110          T
  2293.                1111          STRING-CHAR
  2294.          Der Element-Typ ist auch der Element-Typ des Datenvektors. (Ausnahme:
  2295.          Byte-Vektoren. Deren letzter Datenvektor ist ein Simple-Bit-Vektor.)
  2296. RK: Rang n (von 0 bis 65535)
  2297. DATA: Vektor mit Arrayelementen (in lexikographischer Ordung gemäß den
  2298.       Indices) oder (falls displaced) Array, auf den displaced wurde.
  2299. TSIZE: Total-Size (als vorzeichenlose 32-Bit-Zahl)
  2300. D.OFF: Falls F,Bit 4 = 1: Falls F,Bit 5 = 1: displaced-offset, sonst
  2301.        beliebig (nur Platzhalter für den Fall, daß bei ADJUST-ARRAY
  2302.        die :DISPLACED-TO-Option angegeben wird).
  2303. DIMi: i-te Dimension (als vorzeichenlose 32-Bit-Zahl)
  2304. FILLP: Falls F,Bit 6 = 1: Fill-Pointer (als vorzeichenlose 32-Bit-Zahl)
  2305.  
  2306. (Die Gesamtgröße des Arrays (d.h. TSIZE = DIM1*...*DIMn) ist gleich der Länge
  2307. des Datenvektors, falls nicht displaced, abgesehen von obiger Ausnahme.)
  2308.  
  2309. Arrays befinden sich im Speicherbereich für Objekte variabler Länge.
  2310.  
  2311. 2.20. Records (CLOSURE, STRUCTURE, INSTANCE, STREAM etc.)
  2312.  
  2313.       +-+-----+      +-------+-+-+---+-------+-----+-------+
  2314.       |T| ADR | ADR: |       |F|t| L | DAT1  | ... | DATn  |
  2315.       +-+-----+      +-------+-+-+---+-------+-----+-------+
  2316.  
  2317. ADR: Adresse des Records
  2318. T: #b000010?? Typ-Info für Records
  2319. F: 8 Flag-Bits für zusätzliche lokale Information
  2320.      (z.B. bei Hash-Tables für Test (EQ, EQL, EQUAL) und ob
  2321.       Rehash nach GC nötig ist)
  2322. t: 8 Bits nähere Typinformation bei T = #b00001011:
  2323.      #b11111111 = Hash-Table
  2324.      #b00000000 = Package
  2325.      #b00000001 = Readtable
  2326.      #b00000010 = Pathname
  2327.      #b00000011 = Random-State
  2328.      #b00000100 = Byte
  2329.      #b00000101 = Load-time-Eval
  2330.      #b00000110 = Symbol-Macro
  2331. L: Länge des Records (in Pointern) (ein Wort)
  2332. DATi: Elemente des Records
  2333. Records befinden sich im Speicherbereich für Objekte variabler Länge.
  2334.  
  2335. 2.21. Records im Einzelnen
  2336.  
  2337. 2.21.1. Closures
  2338.  
  2339. Interpretierte Closures:
  2340.   F=t=0, L=21, die Daten sind:
  2341.   NAME            Name der Funktion (:LAMBDA als Default)
  2342.   FORM            gesamter Lambdabody (lambda-list {decl|doc} {form}) oder NIL
  2343.   DOCSTRING       Docstring oder NIL
  2344.   BODY            Liste der auszuführenden Formen
  2345.   VAR_ENV         Variablen-Environment             | Environments,
  2346.   FUN_ENV         Funktionsdefinitions-Environment  | die beim Aufruf
  2347.   BLOCK_ENV       Block-Environment                 | der Closure zu
  2348.   GO_ENV          Tagbody-Environment               | aktivieren sind
  2349.   DECL_ENV        Deklarations-Environment          |
  2350.   VARS            Vektor mit allen Variablen in der richtigen Reihenfolge
  2351.   VARFLAGS        parallel dazu: Byte-Vektor, in dem jeweils evtl.
  2352.                     DYNAM_BIT und SVAR_BIT gesetzt sind (DYNAM_BIT,
  2353.                     wenn die Variable dynamisch gebunden werden muß,
  2354.                     SVAR_BIT, wenn eine supplied-p-Variable folgt)
  2355.   SPEC_ANZ        Anzahl der dynamischen Referenzen
  2356.   REQ_ANZ         Anzahl der required-Parameter
  2357.   OPT_ANZ         Anzahl der optional-Parameter
  2358.   OPT_INITS       Liste der Initialisierungsformen der optional-Parameter
  2359.   KEY_ANZ         Anzahl der Keyword-Parameter
  2360.   KEYWORDS        Liste der zugehörigen Keywords (oder 0, falls überhaupt
  2361.                     keine Keywords zugelassen sind)
  2362.   KEY_INITS       Liste der Initialisierungsformen der Keyword-Parameter
  2363.   ALLOW_FLAG      Flag für &ALLOW-OTHER-KEYS (NIL oder T)
  2364.   REST_FLAG       Flag für &REST-Parameter (NIL oder T)
  2365.   AUX_ANZ         Anzahl der &AUX-Variablen
  2366.   AUX_INITS       Liste der Initialisierungsformen der &AUX-Variablen
  2367.  
  2368. Compilierte Closures:
  2369. F=t=0, die Daten sind:
  2370.   Name            Name der Funktion
  2371.   CODEVEC         Bytecode-Vektor
  2372.   [VenvConst]
  2373.   {BlockConst}*
  2374.   {TagbodyConst}*
  2375.   {Keyword}*
  2376.   {sonstige Const}*
  2377. VenvConst, BlockConst, TagbodyConst : diese LISP-Objekte werden innerhalb der
  2378. Funktion als Konstanten betrachtet. Sie werden beim Aufbau der Funktion zur
  2379. Laufzeit mitgegeben. Sollten diese drei Teile fehlen (d.h. diese Funktion ist
  2380. von der Inkarnation unabhängig, weil sie auf keine lexikalischen Variablen,
  2381. Blocks oder Tags zugreift, die im compilierten Code außerhalb von ihr definiert
  2382. werden), so heißt die Funktion autonom.
  2383. Keyword : die Keywords in der richtigen Reihenfolge. Werden vom Interpreter bei
  2384. der Parameterübergabe gebraucht.
  2385. sonstige Const: sonstige Konstanten, auf die vom Innern der Funktion aus Bezug
  2386. genommen wird. Sie sind untereinander und zu allen Keywords paarweise nicht EQL.
  2387. CODEVEC = Code-Vektor, ein SIMPLE-BIT-VECTOR,
  2388.    2 Bytes : Anzahl der required parameter
  2389.    2 Bytes : Anzahl der optionalen Parameter
  2390.    1 Byte : Flags. Bit 0: ob &REST - Parameter angegeben
  2391.                    Bit 7: ob Keyword-Parameter angegeben
  2392.                    Bit 6: &ALLOW-OTHER-KEYS-Flag
  2393.    1 Byte : Kürzel für den Argumenttyp, für schnelleres FUNCALL
  2394.    Falls Keyword-Parameter angegeben:
  2395.      4 Bytes : 2 Bytes : Anzahl der Keyword-Parameter
  2396.                2 Bytes : Offset in FUNC der Keywords
  2397.    dann
  2398.    eine Folge von Byte-Instruktionen.
  2399.  
  2400. 2.21.2. Structures
  2401.  
  2402. t=0, L>0, erstes Element ist das LIST* aller Structure-Typen, der die
  2403. Structure angehört (alles Symbole): (name_1 ... name_i-1 name_i)
  2404. Siehe RECORD.D
  2405.  
  2406. 2.21.3. Instanzen
  2407.  
  2408. t=0, L>0, erstes Element ist die Klasse, von der das Objekt eine direkte
  2409. Instanz ist. (Oberklassen werden nicht direkt aufgeführt.) Dann die Slots,
  2410. die instanz-alloziert sind.
  2411.  
  2412. 2.21.4. Streams
  2413.  
  2414. t codiert den Typ des Streams:
  2415.   Bit 0-7 genauerer Typ
  2416. F codiert den Zustand des Streams:
  2417.   Bit 0-3 =0
  2418.   Bit 4 gesetzt, falls READ-BYTE möglich ist
  2419.   Bit 5 gesetzt, falls WRITE-BYTE möglich ist
  2420.   Bit 6 gesetzt, falls READ-CHAR möglich ist
  2421.   Bit 7 gesetzt, falls WRITE-CHAR möglich ist
  2422. L >=6, die festen Daten sind:
  2423. RD_BY          Pseudofunktion zum Lesen eines Bytes
  2424. WR_BY          Pseudofunktion zum Schreiben eines Bytes
  2425. RD_CH          Pseudofunktion zum Lesen eines Characters
  2426. WR_CH          Pseudofunktion zum Schreiben eines Characters
  2427. RD_CH_LAST     letztes gelesenes Zeichen und Flag
  2428. WR_CH_LPOS     Position in der Zeile
  2429.  
  2430. 2.21.5. Packages
  2431.  
  2432. F=0, L=7, die Daten sind:
  2433. EXTERNAL_SYMBOLS     Symboltabelle der extern präsenten Symbole
  2434. INTERNAL_SYMBOLS     Symboltabelle der intern präsenten Symbole
  2435. SHADOWING_SYMBOLS    Liste der Shadowing-Symbole
  2436. USE_LIST             Use-List
  2437. USED_BY_LIST         Used-By-List
  2438. NAME                 Package-Name
  2439. NICKNAMES            Liste der Nicknames der Package
  2440. Siehe PACKAGE.D
  2441.  
  2442. 2.21.6. Hash-Tables
  2443.  
  2444. t=-1.
  2445. F codiert den Typ und den Zustand der Hashtabelle:
  2446.   Bit 0 gesetzt, wenn EQ-Hashtabelle
  2447.   Bit 1 gesetzt, wenn EQL-Hashtabelle
  2448.   Bit 2 gesetzt, wenn EQUAL-Hashtabelle
  2449.   Bit 3-6 =0
  2450.   Bit 7 gesetzt, wenn Tabelle nach GC reorganisiert werden muß
  2451. L=10, die Daten sind:
  2452. SIZE                Fixnum>0 = Länge der ITABLE
  2453. MAXCOUNT            Fixnum>0 = Länge der NTABLE
  2454. ITABLE              Index-Vektor der Länge SIZE, enthält Indizes
  2455. NTABLE              Next-Vektor der Länge MAXCOUNT, enthält Indizes
  2456. KVTABLE             Key-Value-Vektor, Vektor der Länge 2*MAXCOUNT
  2457. FREELIST            Start-Index der Freiliste im Next-Vektor
  2458. COUNT               Anzahl der Einträge in der Table, Fixnum >=0, <=MAXCOUNT
  2459. REHASH_SIZE         Wachstumsrate bei Reorganisation. Float >1.1
  2460. MINCOUNT_THRESHOLD  Verhältnis MINCOUNT/MAXCOUNT = 1/rehash-size^2
  2461. MINCOUNT            Fixnum>=0, untere Grenze für COUNT
  2462. Siehe HASHTABL.D
  2463.  
  2464. 2.21.7. Readtables
  2465.  
  2466. F=0, L=3, die Daten sind:
  2467. SYNTAX_TABLE           Syntaxcodes, ein Bitvektor mit 256 Bytes
  2468. MACRO_TABLE            Read-Macros, ein Vektor mit 256 Funktionen/Vektoren/NILs
  2469. CASE                   Case, ein Fixnum in {0,1,2}
  2470. Siehe IO.D
  2471.  
  2472. 2.21.8. Pathnames
  2473.  
  2474. F=0, L<=6, die Daten sind:
  2475. evtl. HOST             Host
  2476. evtl. DEVICE           Drive
  2477.       DIRECTORY        Disknummer und Subdirectory-Path
  2478.       NAME             Name
  2479.       TYPE             Extension
  2480. evtl. VERSION          Version
  2481.  
  2482. 2.21.9. Random-states
  2483.  
  2484. F=0, L=1, die Daten sind:
  2485. SEED                   letzte Zahl, ein Simple-Bit-Vector mit 64 Bits
  2486.  
  2487. 2.21.10. Bytes
  2488.  
  2489. F=0, L=2, die Daten sind:
  2490. SIZE            Größe des spezifizierten Bytes, ein Fixnum
  2491. POSITION        Position des spezifizierten Bytes, ein Fixnum
  2492. Siehe ARIDECL.TXT
  2493.  
  2494. 2.21.11. Load-time-Evals
  2495.  
  2496. F=0, L=1, die Daten sind:
  2497. FORM            Form, die erst zur Zeit des Ladens evaluiert werden soll
  2498.  
  2499. 2.21.12. Symbol-Macros
  2500.  
  2501. F=0, L=1, die Daten sind:
  2502. EXPANSION       Expansion des Symbols, eine Form.
  2503.  
  2504.  
  2505. 3. Code-Aufbau
  2506. --------------
  2507.  
  2508. Der Code ist compiliert. Für Fehlermeldungen ist der Name nötig. Da man in C
  2509. nicht Daten in unmittelbarer Nähe von Funktionen unterbringen kann, muß man
  2510. Name und Funktionsadresse in einer Tabelle aller SUBRs bzw. FSUBRs unter-
  2511. bringen. Ein SUBR ist ein Pointer in die SUBR-Tabelle, ein FSUBR ist ein
  2512. Pointer in die FSUBR-Tabelle. Um sowohl schnellen FUNCALL als auch
  2513. Argumente-überprüfenden APPLY zu ermöglichen, stehen noch weitere
  2514. Informationen in der Tabelle (Argumentanzahlen etc.):
  2515.  
  2516. FSUBR-Tabellen-Eintrag:
  2517.   .L   Adresse der C-Funktion (ohne Argumente, ohne Wert)
  2518.   .L   Adresse des Namens des FSUBR (LISP-Objekt)
  2519.   .W   Kürzel für den Argumente-Typ des FSUBR
  2520.   .W   REQ_ANZ : Anzahl required Parameter
  2521.   .W   OPT_ANZ : Anzahl optionaler Parameter
  2522.   .W   BODY_FLAG : Body-Flag
  2523.  
  2524. SUBR-Tabellen-Eintrag:
  2525.   .L   Adresse der C-Funktion (ohne Argumente, ohne Wert)
  2526.   .L   Adresse des Namens des SUBR (LISP-Objekt)
  2527.   .L   Adresse des Vektors mit den Keywords oder NIL (LISP-Objekt)
  2528.   .W   Kürzel für den Argumente-Typ des SUBR
  2529.   .W   REQ_ANZ : Anzahl required Parameter
  2530.   .W   OPT_ANZ : Anzahl optionaler Parameter
  2531.   .B   REST_FLAG : Flag für beliebig viele Argumente
  2532.   .B   KEY_FLAG : Flag für Keywords
  2533.   .W   KEY_ANZ : Anzahl Keywordparameter
  2534.  
  2535. */
  2536.  
  2537. # ######################## LISP-Objekte allgemein ######################### #
  2538.  
  2539. #if !defined(WIDE)
  2540.  
  2541. # Ein Objektpointer ist erst einmal ein leerer Pointer (damit man in C nichts
  2542. # Unbeabsichtigtes mit ihm machen kann):
  2543.   #ifdef OBJECT_STRUCT
  2544.     typedef struct { uintL one; } object;
  2545.   #else
  2546.     typedef  void *  object;
  2547.   #endif
  2548. # Aber in der Repräsentation steckt eine Adresse und Typbits.
  2549.  
  2550. # Ein (unsigned) Integer von der Größe eines Objekts:
  2551.   typedef  uintL  oint;
  2552.   typedef  sintL  soint;
  2553.  
  2554. #else # defined(WIDE)
  2555.  
  2556. # Ein Objekt besteht aus getrennten 32 Bit Adresse und 32 Bit Typinfo.
  2557.   typedef  uint64  oint;
  2558.   typedef  sint64  soint;
  2559.   #ifdef WIDE_STRUCT
  2560.     #if BIG_ENDIAN_P==WIDE_ENDIANNESS
  2561.       #define TYPEDEF_OBJECT  \
  2562.         typedef  union { struct { /* tint */ uintL type; /* aint */ uintL addr; } both; \
  2563.                          oint one _attribute_aligned_object_;                           \
  2564.                        }                                                                \
  2565.                  object;
  2566.     #else
  2567.       #define TYPEDEF_OBJECT  \
  2568.         typedef  union { struct { /* aint */ uintL addr; /* tint */ uintL type; } both; \
  2569.                          oint one _attribute_aligned_object_;                           \
  2570.                        }                                                                \
  2571.                  object;
  2572.     #endif
  2573.   #else
  2574.     typedef  oint  object;
  2575.   #endif
  2576.  
  2577. #endif
  2578.  
  2579. # Es muß sizeof(object) = sizeof(oint) gelten!
  2580.  
  2581. # Umwandlungen zwischen object und oint:
  2582. # as_oint(expr)   object --> oint
  2583. # as_object(x)    oint --> object
  2584.   #if defined(WIDE_STRUCT) || defined(OBJECT_STRUCT)
  2585.     #define as_oint(expr)  ((expr).one)
  2586.     #if 1
  2587.       #define as_object(o)  ((object){one:(o)})
  2588.     #else
  2589.       extern __inline__ object as_object (register oint o)
  2590.         { register object obj; obj.one = o; return obj; }
  2591.     #endif
  2592.   #else
  2593.     #define as_oint(expr)  (oint)(expr)
  2594.     #define as_object(o)  (object)(o)
  2595.   #endif
  2596.  
  2597. # Was von einer Adresse auch wirklich auf den Adreßbus geschickt wird:
  2598. #if defined(MC68000)
  2599.   #define addressbus_mask  0x00FFFFFFUL  # 68000 wirft 8 Bits weg
  2600. #elif defined(SUN3) && !defined(UNIX_SUNOS4)
  2601.   #define addressbus_mask  0x0FFFFFFFUL  # SUN3 unter SunOS 3.5 wirft 4 Bits weg
  2602. #elif 1
  2603.   #define addressbus_mask  ~0UL  # Default: nichts wird weggeworfen
  2604. #else
  2605.   #error "Unknown address bus mask -- Größe addressbus_mask neu einstellen!"
  2606. #endif
  2607.  
  2608. # Aufteilung eines oint in Typbits und Adresse:
  2609. # Stets ist  oint_type_mask  subset  (2^oint_type_len-1)<<oint_type_shift
  2610. # und        oint_addr_mask superset (2^oint_addr_len-1)<<oint_addr_shift .
  2611. #if defined(WIDE_HARD)
  2612.   #if defined(DECALPHA) && defined(UNIX_OSF)
  2613.     #if defined(NO_SINGLEMAP)
  2614.       # Wenn MAP_MEMORY nicht gefordert ist, ist das das sicherste.
  2615.       # Bits 63..48 = Typcode, Bits 47..0 = Adresse
  2616.       #define oint_type_shift 48
  2617.       #define oint_type_len 16
  2618.       #define oint_type_mask 0xFFFF000000000000UL
  2619.       #define oint_addr_shift 0
  2620.       #define oint_addr_len 48
  2621.       #define oint_addr_mask 0x0000FFFFFFFFFFFFUL
  2622.       #define oint_data_shift 0
  2623.       #define oint_data_len 32
  2624.       #define oint_data_mask 0x00000000FFFFFFFFUL
  2625.     #else
  2626.       # Gewöhnliche Pointer liegen im Bereich 1*2^32..2*2^32.
  2627.       # Bits 63..33 = Typcode, Bits 32..0 = Adresse
  2628.       #if 1 # Was ist besser??
  2629.         #define oint_type_shift 32
  2630.         #define oint_type_len 32
  2631.       #else
  2632.         #define oint_type_shift 33
  2633.         #define oint_type_len 31
  2634.       #endif
  2635.       #define oint_type_mask 0xFFFFFFFE00000000UL
  2636.       #define oint_addr_shift 0
  2637.       #define oint_addr_len 33
  2638.       #define oint_addr_mask 0x00000001FFFFFFFFUL
  2639.       #define oint_data_shift 0
  2640.       #define oint_data_len 32
  2641.       #define oint_data_mask 0x00000000FFFFFFFFUL
  2642.     #endif
  2643.   #endif
  2644. #elif defined(WIDE_SOFT)
  2645.   # Getrennte 32-Bit-Wörter für Typcode und Adresse.
  2646.   #if WIDE_ENDIANNESS
  2647.     # Bits 63..32 = Typcode, Bits 31..0 = Adresse
  2648.     #define oint_type_shift 32
  2649.     #define oint_type_len 32
  2650.     #define oint_type_mask 0xFFFFFFFF00000000ULL
  2651.     #define oint_addr_shift 0
  2652.     #define oint_addr_len 32
  2653.     #define oint_addr_mask 0x00000000FFFFFFFFULL
  2654.   #else # umgekehrt ist es etwas langsamer:
  2655.     # Bits 63..32 = Adresse, Bits 31..0 = Typcode
  2656.     #define oint_type_shift 0
  2657.     #define oint_type_len 32
  2658.     #define oint_type_mask 0x00000000FFFFFFFFULL
  2659.     #define oint_addr_shift 32
  2660.     #define oint_addr_len 32
  2661.     #define oint_addr_mask 0xFFFFFFFF00000000ULL
  2662.   #endif
  2663. #elif (defined(MC680X0) && !defined(AMIGA3000) && !defined(UNIX_AMIX) && !(defined(UNIX_LINUX) && CODE_ADDRESS_RANGE) && !defined(UNIX_NEXTSTEP)) || (defined(I80Z86) && !defined(WATCOM_BLAKE) && !defined(UNIX_SYSV_UHC_2) && !defined(UNIX_SYSV_UHC_1) && !(defined(UNIX_LINUX) && CODE_ADDRESS_RANGE) && !defined(UNIX_NEXTSTEP) && !defined(UNIX_SYSV_PTX) && !defined(WIN32_DOS) && !defined(WIN32_UNIX)) || defined(SPARC) || (defined(MIPS) && !defined(UNIX_IRIX) && !defined(UNIX_DEC_ULTRIX)) || defined(M88000) || (defined(RS6000) && !defined(UNIX_AIX)) || defined(VAX) || (defined(CONVEX) && !defined(UNIX_CONVEX)) || defined(ACORN_1)
  2664.   # Bits 31..24 = Typcode, Bits 23..0 = Adresse
  2665.   #define oint_type_shift 24
  2666.   #define oint_type_len 8
  2667.   #define oint_type_mask 0xFF000000UL
  2668.   #define oint_addr_shift 0
  2669.   #define oint_addr_len 24
  2670.   #define oint_addr_mask 0x00FFFFFFUL
  2671. #elif defined(ACORN_2)
  2672.   # Bits 31..8 = Adresse, Bits 7..0 = Typcode
  2673.   #define oint_type_shift 0
  2674.   #define oint_type_len 8
  2675.   #define oint_type_mask 0x000000FFUL
  2676.   #define oint_addr_shift 8
  2677.   #define oint_addr_len 24
  2678.   #define oint_addr_mask 0xFFFFFF00UL
  2679. #elif defined(ACORN_3)
  2680.   # Bits 31..26 = Typcode, Bits 25..0 = Adresse
  2681.   #define oint_type_shift 26
  2682.   #define oint_type_len 6
  2683.   #define oint_type_mask 0xFC000000UL
  2684.   #define oint_addr_shift 0
  2685.   #define oint_addr_len 26
  2686.   #define oint_addr_mask 0x03FFFFFFUL
  2687. #elif defined(ACORN_4)
  2688.   # Bits 31..6 = Adresse, Bits 5..0 = Typcode
  2689.   #define oint_type_shift 0
  2690.   #define oint_type_len 6
  2691.   #define oint_type_mask 0x0000003FUL
  2692.   #define oint_addr_shift 6
  2693.   #define oint_addr_len 26
  2694.   #define oint_addr_mask 0xFFFFFFC0UL
  2695. #elif defined(AMIGA3000)
  2696.   # Bits 31..6 = Adresse/2, Bits 5..0 = Typcode
  2697.   #define oint_type_shift 0
  2698.   #define oint_type_len 6
  2699.   #define oint_type_mask 0x0000003FUL
  2700.   #define oint_addr_shift 6
  2701.   #define oint_addr_len 26
  2702.   #define oint_addr_mask 0xFFFFFFC0UL
  2703.   #define addr_shift 1
  2704. #elif defined(UNIX_SYSV_UHC_2)
  2705.   # Bits 31..6 = Adresse/4, Bits 5..0 = Typcode
  2706.   #define oint_type_shift 0
  2707.   #define oint_type_len 6
  2708.   #define oint_type_mask 0x0000003FUL
  2709.   #define oint_addr_shift 6
  2710.   #define oint_addr_len 26
  2711.   #define oint_addr_mask 0xFFFFFFC0UL
  2712.   #define addr_shift 2  # funktioniert nicht wegen STACK_alignment ??
  2713. #elif (defined(HPPA) && defined(UNIX_HPUX)) || (defined(MC680X0) && defined(UNIX_AMIX))
  2714.   # Bits 29..24 = Typcode, Bits 31..30,23..0 = Adresse
  2715.   #define oint_type_shift 24
  2716.   #define oint_type_len 6
  2717.   #define oint_type_mask 0x3F000000UL
  2718.   #define oint_addr_shift 0
  2719.   #define oint_addr_len 24 # vernünftig nutzbar sind nur die unteren 24 Bit
  2720.   #define oint_addr_mask 0xC0FFFFFFUL
  2721.   # Beachte: unten wird aint = uint24 = uint32 sein.
  2722. #elif defined(UNIX_SYSV_UHC_1)
  2723.   # Bits 31..28,26..24 = Typcode, Bits 23..0 = Adresse
  2724.   #define oint_type_shift 24
  2725.   #define oint_type_len 8
  2726.   #define oint_type_mask 0xF7000000UL
  2727.   #define oint_addr_shift 0
  2728.   #define oint_addr_len 24
  2729.   #define oint_addr_mask 0x08FFFFFFUL
  2730. #elif defined(UNIX_LINUX) && (CODE_ADDRESS_RANGE != 0) # Linux with ELF binary format
  2731.   # Bits 31..28,26..24 = Typcode, Bits 23..0 = Adresse
  2732.   #define oint_type_shift 24
  2733.   #define oint_type_len 8
  2734.   #define oint_type_mask 0xF7000000UL
  2735.   #define oint_addr_shift 0
  2736.   #define oint_addr_len 24
  2737.   #define oint_addr_mask 0x08FFFFFFUL
  2738.   # Shared libraries are mapped in at 0x50000000 or 0x40000000, via mmap().
  2739.   #define vm_addr_mask 0xBFFFFFFFUL
  2740. #elif defined(MIPS) && (defined(UNIX_IRIX) || defined(UNIX_DEC_ULTRIX))
  2741.   # Bits 31..29,27..24 = Typcode, Bits 23..0 = Adresse
  2742.   #define oint_type_shift 24
  2743.   #define oint_type_len 8
  2744.   #define oint_type_mask 0xEF000000UL
  2745.   #define oint_addr_shift 0
  2746.   #define oint_addr_len 24
  2747.   #define oint_addr_mask 0x10FFFFFFUL
  2748. #elif defined(RS6000) && defined(UNIX_AIX)
  2749.   # Bits 31..30,28..24 = Typcode, Bits 23..0 = Adresse
  2750.   #define oint_type_shift 24
  2751.   #define oint_type_len 8
  2752.   #define oint_type_mask 0xDF000000UL
  2753.   #define oint_addr_shift 0
  2754.   #define oint_addr_len 24
  2755.   #define oint_addr_mask 0x20FFFFFFUL
  2756. #elif defined(WATCOM_BLAKE)
  2757.   # Bits 30..25 = Typcode, Bits 31,24..0 = Adresse
  2758.   #define oint_type_shift 25
  2759.   #define oint_type_len 6
  2760.   #define oint_type_mask 0x7E000000UL
  2761.   #define oint_addr_shift 0
  2762.   #define oint_addr_len 25
  2763.   #define oint_addr_mask 0x81FFFFFFUL
  2764. #elif defined(WIN32_DOS) || defined(WIN32_UNIX)
  2765.   #define oint_type_shift 24
  2766.   #define oint_type_len 8
  2767.   #define oint_type_mask 0xDF000000UL
  2768.   #define oint_addr_shift 0
  2769.   #define oint_addr_len 24
  2770.   #define oint_addr_mask 0x20FFFFFFUL
  2771. #elif defined(UNIX_NEXTSTEP)
  2772.   # Bits 31..24 = Typcode, Bits 23..0 = Adresse
  2773.   #define oint_type_shift 24
  2774.   #define oint_type_len 8
  2775.   #define oint_type_mask 0xFF000000UL
  2776.   #define oint_addr_shift 0
  2777.   #define oint_addr_len 24
  2778.   #define oint_addr_mask 0x00FFFFFFUL
  2779.   # UNIX_NEXTSTEP has shared libraries at 0x05000000, related storage at
  2780.   # 0x04000000, a stack from 0x03F80000..0x04000000. We avoid this address
  2781.   # range of VM addresses by not using bits 26 and 24 in our typecode
  2782.   # bit encoding scheme.
  2783.   #define vm_addr_mask 0xFAFFFFFFUL
  2784. #elif defined(UNIX_SYSV_PTX)
  2785.   # Bits 31..24 = Typcode, Bits 23..0 = Adresse
  2786.   #define oint_type_shift 24
  2787.   #define oint_type_len 8
  2788.   #define oint_type_mask 0xFF000000UL
  2789.   #define oint_addr_shift 0
  2790.   #define oint_addr_len 24
  2791.   #define oint_addr_mask 0x00FFFFFFUL
  2792.   # UNIX_SYSV_PTX has its stack above (or below??) 0x40000000. We avoid this
  2793.   # address range of VM addresses by not using bit 30 in our typecode bit
  2794.   # encoding scheme.
  2795.   #define vm_addr_mask 0xBFFFFFFFUL
  2796. #elif defined(UNIX_NETBSD) # experimentell??
  2797.   # Bits 31..24 = Typcode, Bits 23..0 = Adresse
  2798.   #define oint_type_shift 24
  2799.   #define oint_type_len 8
  2800.   #define oint_type_mask 0xFF000000UL
  2801.   #define oint_addr_shift 0
  2802.   #define oint_addr_len 24
  2803.   #define oint_addr_mask 0x00FFFFFFUL
  2804.   # NetBSD 1.0 has its shared libraries above 0x10000000. We avoid this
  2805.   # address range of VM addresses by not using bit 28 in our typecode bit
  2806.   # encoding scheme.
  2807.   #define vm_addr_mask 0xEFFFFFFFUL
  2808. #elif defined(CONVEX) && defined(UNIX_CONVEX)
  2809.   # Bits 30..24 = Typcode, Bits 31,23..0 = Adresse
  2810.   #define oint_type_shift 24
  2811.   #define oint_type_len 8
  2812.   #define oint_type_mask 0x7F000000UL
  2813.   #define oint_addr_shift 0
  2814.   #define oint_addr_len 24
  2815.   #define oint_addr_mask 0x80FFFFFFUL
  2816.   # UNIX_CONVEX user space addresses are in the range 0x80000000..0xFFFFFFFF.
  2817.   # Memory mapping works in the range 0x80000000..0xBFFFFFFFUL.
  2818.   #define vm_addr_mask 0xBFFFFFFFUL
  2819. #else
  2820.   #error "How to split a pointer into type and address? -- Größen oint_type_shift, oint_addr_shift neu einstellen!"
  2821. #endif
  2822.  
  2823. # Meist nutzen wir den ganzen Platz einer Adresse für die Daten von Fixnums etc.
  2824. # Stets ist  [oint_data_shift..oint_data_shift+oint_data_len-1] subset
  2825. #            [oint_addr_shift..oint_addr_shift+oint_addr_len-1],
  2826. # also       oint_data_len <= oint_addr_len,
  2827. # aber auch  oint_data_len <= intLsize = 32 .
  2828. #ifndef oint_data_len
  2829.   #define oint_data_shift oint_addr_shift
  2830.   #define oint_data_len oint_addr_len
  2831.   #define oint_data_mask oint_addr_mask
  2832. #endif
  2833.  
  2834. # Integertyp für Typbits:
  2835.   #ifdef ANSI
  2836.     typedef unsigned_int_with_n_bits(oint_type_len)  tint;
  2837.   #else
  2838.     typedef uint/**/oint_type_len  tint;
  2839.   #endif
  2840.  
  2841. # Integertyp für Adressen:
  2842.   #ifdef ANSI
  2843.     typedef unsigned_int_with_n_bits(oint_addr_len)  aint;
  2844.     typedef signed_int_with_n_bits(oint_addr_len)  saint;
  2845.   #else
  2846.     typedef uint/**/oint_addr_len  aint;
  2847.     typedef sint/**/oint_addr_len  saint;
  2848.   #endif
  2849.  
  2850. # Anzahl der Bits, um die eine Adresse zuletzt noch geshiftet wird:
  2851.   #ifndef addr_shift
  2852.     #define addr_shift 0
  2853.   #endif
  2854.  
  2855. # Maske der Bits eines tint, die wirklich zum Typ gehören:
  2856. # tint_type_mask = oint_type_mask >> oint_type_shift
  2857. # (eine Constant Expression, in der keine 'long long's vorkommen!)
  2858.   #ifdef WIDE_SOFT
  2859.     #define tint_type_mask  (bitm(oint_type_len)-1)
  2860.   #else
  2861.     #define tint_type_mask  (oint_type_mask >> oint_type_shift)
  2862.   #endif
  2863.  
  2864. # Um zu einem object/oint etwas zu addieren:
  2865. # objectplus(obj,offset)
  2866.   #if !(defined(WIDE_SOFT) || defined(OBJECT_STRUCT))
  2867.     #define objectplus(obj,offset)  ((object)pointerplus(obj,offset))
  2868.   #else # defined(WIDE_SOFT) || defined(OBJECT_STRUCT)
  2869.     #define objectplus(obj,offset)  as_object(as_oint(obj)+(soint)(offset))
  2870.   #endif
  2871.  
  2872. # Bitoperationen auf Größen vom Typ oint:
  2873. # ...wbit... statt ...bit..., "w" = "wide".
  2874.   #if !defined(WIDE_SOFT)
  2875.     #define wbit  bit
  2876.     #define wbitm  bitm
  2877.     #define wbit_test  bit_test
  2878.     #define minus_wbit  minus_bit
  2879.   #else
  2880.     #define wbit(n)  (1LL<<(n))
  2881.     #define wbitm(n)  (2LL<<((n)-1))
  2882.     #define wbit_test(x,n)  ((x) & wbit(n))
  2883.     #define minus_wbit(n)  (-1LL<<(n))
  2884.   #endif
  2885.  
  2886. # Typinfo:
  2887. # typecode(object) und mtypecode(object) liefern den Typcode eines
  2888. # Objektes obj. Bei mtypecode muß er dazu im Speicher liegen.
  2889.   #if !(exact_uint_size_p(oint_type_len) && (tint_type_mask == bit(oint_type_len)-1))
  2890.     #define typecode(expr)  \
  2891.       ((tint)(as_oint(expr) >> oint_type_shift) & (oint_type_mask >> oint_type_shift))
  2892.     #define mtypecode(expr)  typecode(expr)
  2893.   #else
  2894.     # Der Typ 'tint' hat genau oint_type_len Bits, und tint_type_mask = 2^oint_type_len-1.
  2895.     # Also kann man sich das ANDen sparen.
  2896.     # Allerdings ist auf einem 68000 ein ROL.L #8 schneller, auf einer SPARC ein Shift.
  2897.       #define typecode(expr)  \
  2898.         ((tint)(as_oint(expr) >> oint_type_shift))
  2899.       #if defined(MC68000) && defined(GNU) && !defined(NO_ASM) && (oint_type_shift==24) && (oint_type_len==8)
  2900.         # GNU C auf einem 68000, ersetze LSR.L #24 durch ROL.L #8 :
  2901.         #undef typecode
  2902.         #define typecode(expr)  \
  2903.           ({var tint __typecode;                                               \
  2904.             __asm__ ("roll #8,%0" : "=d" (__typecode) : "0" (as_oint(expr)) ); \
  2905.             __typecode;                                                        \
  2906.            })
  2907.       #elif defined(SPARC) && !defined(WIDE)
  2908.         #undef typecode
  2909.         #define typecode(expr)  \
  2910.           ((as_oint(expr) << (32-oint_type_len-oint_type_shift)) >> (32-oint_type_len))
  2911.       #elif defined(WIDE) && defined(WIDE_STRUCT)
  2912.         #undef typecode
  2913.         #define typecode(expr)  ((expr).both.type)
  2914.       #endif
  2915.     # Außerdem kann man Zugriffe im Speicher auch ohne Shift machen:
  2916.       #if !defined(WIDE) && (((oint_type_shift==24) && BIG_ENDIAN_P) || ((oint_type_shift==0) && !BIG_ENDIAN_P))
  2917.         #define mtypecode(expr)  (*(tint*)&(expr))
  2918.         #define fast_mtypecode
  2919.       #elif !defined(WIDE) && (((oint_type_shift==24) && !BIG_ENDIAN_P) || ((oint_type_shift==0) && BIG_ENDIAN_P))
  2920.         #define mtypecode(expr)  (*((tint*)&(expr)+3))
  2921.         #define fast_mtypecode
  2922.       #elif defined(WIDE)
  2923.         #ifdef WIDE_STRUCT
  2924.           #define mtypecode(expr)  ((expr).both.type)
  2925.         #elif (oint_type_len==16)
  2926.           #if (oint_type_shift==0) == BIG_ENDIAN_P
  2927.             #define mtypecode(expr)  (*((tint*)&(expr)+3))
  2928.           #else # (oint_type_shift==48) == BIG_ENDIAN_P
  2929.             #define mtypecode(expr)  (*(tint*)&(expr))
  2930.           #endif
  2931.         #elif (oint_type_len==32)
  2932.           #if (oint_type_shift==0) == BIG_ENDIAN_P
  2933.             #define mtypecode(expr)  (*((tint*)&(expr)+1))
  2934.           #else # (oint_type_shift==32) == BIG_ENDIAN_P
  2935.             #define mtypecode(expr)  (*(tint*)&(expr))
  2936.           #endif
  2937.         #endif
  2938.         #define fast_mtypecode
  2939.       #else # keine Optimierung möglich
  2940.         #define mtypecode(expr)  typecode(expr)
  2941.       #endif
  2942.   #endif
  2943.  
  2944. # Extraktion des Adreßfelds ohne Typinfo:
  2945. # untype(obj)
  2946.   #if defined(WIDE) && defined(WIDE_STRUCT)
  2947.     #define untype(expr)  ((expr).both.addr)
  2948.   #elif !(defined(SPARC) && (oint_addr_len+oint_addr_shift<32))
  2949.     #define untype(expr)    \
  2950.       ((aint)(as_oint(expr) >> oint_addr_shift) & (aint)(oint_addr_mask >> oint_addr_shift))
  2951.   #else
  2952.     # Auf einem SPARC-Prozessor sind lange Konstanten langsamer als Shifts:
  2953.     # Evtl. kann man sich ein ANDen sparen.
  2954.     #define untype(expr)  \
  2955.       ((aint)((as_oint(expr) << (32-oint_addr_len-oint_addr_shift)) >> (32-oint_addr_len)))
  2956.   #endif
  2957.  
  2958. # Objekt aus Typinfo und Adreßfeld:
  2959. # type_untype_object(type,address)
  2960.   #if defined(WIDE) && defined(WIDE_STRUCT)
  2961.     #if BIG_ENDIAN_P==WIDE_ENDIANNESS
  2962.       #define type_untype_object(type,address)  ((object){{(tint)(type),(aint)(address)}})
  2963.     #else
  2964.       #define type_untype_object(type,address)  ((object){{(aint)(address),(tint)(type)}})
  2965.     #endif
  2966.   #elif !(oint_addr_shift==0)
  2967.     #define type_untype_object(type,address)  \
  2968.       (as_object(  ((oint)(tint)(type) << oint_type_shift) + \
  2969.                    ((oint)(aint)(address) << oint_addr_shift) ))
  2970.   #else # bei oint_addr_shift=0 braucht man nicht zu schieben:
  2971.     #if defined(WIDE_SOFT)
  2972.       # Vorsicht: Konversion von address zum oint durch Zero-Extend!
  2973.       #define type_untype_object(type,address)              \
  2974.         objectplus((oint)(aint)(address),(oint)(tint)(type)<<oint_type_shift)
  2975.     #elif defined(OBJECT_STRUCT)
  2976.       #define type_untype_object(type,address)              \
  2977.         as_object((oint)pointerplus((address),(oint)(tint)(type)<<oint_type_shift))
  2978.     #else # Normalfall
  2979.       # Damit das für gcc-2.5.8 ein gültiger Initialisierer ist (NIL_IS_CONSTANT),
  2980.       # darf man nicht vom Pointer zum oint und dann wieder zum Pointer casten,
  2981.       # sondern muß im Bereich der Pointer bleiben.
  2982.       #define type_untype_object(type,address)              \
  2983.         as_object(pointerplus((address),(oint)(tint)(type)<<oint_type_shift))
  2984.     #endif
  2985.   #endif
  2986.  
  2987. # Objekt aus Typinfo und direkten Daten (als "Adresse"):
  2988. # type_data_object(type,data)
  2989.   #if defined(WIDE) && defined(WIDE_STRUCT)
  2990.     #if BIG_ENDIAN_P==WIDE_ENDIANNESS
  2991.       #define type_data_object(type,data)  ((object){{(tint)(type),(aint)(data)}})
  2992.     #else
  2993.       #define type_data_object(type,data)  ((object){{(aint)(data),(tint)(type)}})
  2994.     #endif
  2995.   #elif !(oint_addr_shift==0)
  2996.     #define type_data_object(type,data)  \
  2997.       (as_object(  ((oint)(tint)(type) << oint_type_shift) + \
  2998.                    ((oint)(aint)(data) << oint_addr_shift) ))
  2999.   #else # bei oint_addr_shift=0 braucht man nicht zu schieben:
  3000.     #define type_data_object(type,data)  \
  3001.       (as_object( ((oint)(tint)(type) << oint_type_shift) + (oint)(aint)(data) ))
  3002.   #endif
  3003.  
  3004. # Extraktion der Adresse ohne Typinfo:
  3005. # upointer(obj)
  3006. # (upointer steht für "untyped pointer".)
  3007.   #if (addr_shift==0)
  3008.     #define upointer  untype
  3009.   #else
  3010.     #define optimized_upointer(obj)  \
  3011.       ((aint)((as_oint(obj) << (32-oint_addr_len-oint_addr_shift)) >> (32-oint_addr_len-addr_shift)))
  3012.     #define upointer(obj)  (untype(obj)<<addr_shift)
  3013.   #endif
  3014.  
  3015. # Objekt aus Typinfo und Adresse:
  3016. # type_pointer_object(type,address)
  3017.   #if (addr_shift==0)
  3018.     # (Kein Cast auf aint, damit NIL als Initializer zu gebrauchen ist.)
  3019.     #define type_pointer_object(type,address)  \
  3020.       type_untype_object(type,address)
  3021.   #elif defined(WIDE_SOFT) && !defined(WIDE_STRUCT)
  3022.     #define type_pointer_object(type,address)  \
  3023.       type_untype_object(type,(aint)(address)>>addr_shift)
  3024.   #else # effizienter,
  3025.     # setzt aber voraus, daß address durch 2^addr_shift teilbar ist:
  3026.     #define type_pointer_object(type,address)  \
  3027.       (as_object(  ((oint)(tint)(type) << oint_type_shift) + \
  3028.                    ((oint)(aint)(address) << (oint_addr_shift-addr_shift)) ))
  3029.   #endif
  3030.  
  3031. # Objekt aus konstanter Typinfo und konstanter Adresse:
  3032. # type_constpointer_object(type,address)
  3033.   #define type_constpointer_object(type,address)  type_pointer_object(type,address)
  3034.  
  3035. # oint aus konstanter Typinfo und Adresse = 0:
  3036. # type_zero_oint(type)
  3037.   #if defined(WIDE_SOFT) && defined(WIDE_STRUCT)
  3038.     #define type_zero_oint(type)  as_oint(type_untype_object(type,0))
  3039.   #else
  3040.     #define type_zero_oint(type)  ((oint)(tint)(type) << oint_type_shift)
  3041.   #endif
  3042.  
  3043.  
  3044. #if (oint_type_len >= 8) && (oint_addr_shift == 0) && (addr_shift == 0) && !defined(WIDE_SOFT) && !(defined(SUN3) && !defined(UNIX_SUNOS4) && !defined(WIDE_SOFT))
  3045. # Falls tint_type_mask mindestens 8 Bit umfaßt und nicht WIDE_SOFT,
  3046. # ist evtl. Memory-Mapping möglich.
  3047.  
  3048.   #if (defined(HAVE_MMAP_ANON) || defined(HAVE_MMAP_DEVZERO) || defined(HAVE_MACH_VM)) && !(defined(MULTIMAP_MEMORY) || defined(IMMUTABLE)) && !defined(NO_SINGLEMAP)
  3049.     # Zugriff auf Lisp-Objekte wird vereinfacht dadurch, daß jedes Lisp-Objekt
  3050.     # an eine Adresse gelegt wird, das seine Typinformation bereits enthält.
  3051.       #define SINGLEMAP_MEMORY
  3052.   #endif
  3053.  
  3054.   #if defined(UNIX_SUNOS4) && (oint_addr_shift==0) && !defined(MULTIMAP_MEMORY) && !defined(SINGLEMAP_MEMORY) && !defined(NO_MULTIMAP_FILE)
  3055.     # Zugriff auf Lisp-Objekte geschieht mittels Memory-Mapping: Jede Speicher-
  3056.     # seite ist unter mehreren Adressen zugreifbar.
  3057.       #define MULTIMAP_MEMORY
  3058.       #define MULTIMAP_MEMORY_VIA_FILE
  3059.   #endif
  3060.  
  3061.   #if defined(HAVE_SHM) && (oint_addr_shift==0) && !defined(MULTIMAP_MEMORY) && !defined(SINGLEMAP_MEMORY) && !defined(NO_MULTIMAP_SHM)
  3062.     # Zugriff auf Lisp-Objekte geschieht mittels Memory-Mapping: Jede Speicher-
  3063.     # seite ist unter mehreren Adressen zugreifbar.
  3064.       #define MULTIMAP_MEMORY
  3065.       #define MULTIMAP_MEMORY_VIA_SHM
  3066.   #endif
  3067.  
  3068.   #if defined(UNIX_LINUX) && (oint_addr_shift==0) && !defined(MULTIMAP_MEMORY) && !defined(SINGLEMAP_MEMORY) && !defined(NO_MULTIMAP_FILE)
  3069.     # Zugriff auf Lisp-Objekte geschieht mittels Memory-Mapping: Jede Speicher-
  3070.     # seite ist unter mehreren Adressen zugreifbar.
  3071.       #define MULTIMAP_MEMORY
  3072.       #define MULTIMAP_MEMORY_VIA_FILE
  3073.   #endif
  3074.  
  3075.   #ifdef IMMUTABLE
  3076.     #ifdef SUN4_29
  3077.       #error "Immutable objects don't work on this SUN4 architecture!"
  3078.     #endif
  3079.     #ifndef MULTIMAP_MEMORY
  3080.       #error "Immutable objects require working shared memory!"
  3081.     #endif
  3082.     # Welche Typen immutabler Objekte gibt es?
  3083.     #define IMMUTABLE_CONS   # Conses
  3084.     #define IMMUTABLE_ARRAY  # alle Arten Arrays
  3085.   #endif
  3086.  
  3087.   #if defined(MULTIMAP_MEMORY) || defined(SINGLEMAP_MEMORY)
  3088.     #define MAP_MEMORY
  3089.   #endif
  3090.  
  3091. #endif
  3092.  
  3093. #if (defined(HAVE_MMAP_ANON) || defined(HAVE_MMAP_DEVZERO) || defined(HAVE_MACH_VM)) && !defined(MAP_MEMORY) && !defined(NO_TRIVIALMAP)
  3094.   # mmap() erlaubt eine flexiblere Art der Speicherverwaltung als malloc().
  3095.   # Es ist kein wirkliches Memory-Mapping, sondern nur eine bequemere Art,
  3096.   # zwei große Speicherblöcke zu verwalten.
  3097.   #define TRIVIALMAP_MEMORY
  3098. #endif
  3099.  
  3100.  
  3101. # Art der Garbage Collection: normal oder generational.
  3102. #if defined(VIRTUAL_MEMORY) && (defined(SINGLEMAP_MEMORY) || defined(TRIVIALMAP_MEMORY)) && defined(HAVE_WORKING_MPROTECT) && defined(CAN_HANDLE_WP_FAULT) && (SAFETY < 3) && !defined(NO_GENERATIONAL_GC)
  3103.   # Für "generational garbage collection" sind einige Voraussetzungen nötig.
  3104.   # Unter Linux geht es erst ab Linux 1.1.52, das wird in makemake überprüft.
  3105.   #define GENERATIONAL_GC
  3106. #endif
  3107.  
  3108.  
  3109. #ifdef MULTIMAP_MEMORY
  3110.   #if defined(IMMUTABLE) && defined(GENERATIONAL_GC) # && !defined(UNIX_LINUX)
  3111.     # Es belastet das Betriebssystem weniger, wenn wir den Speicher nur
  3112.     # 2x mappen: 1x bei 0x00 read-write, 1x bei 0x40 read-only.
  3113.     #define MINIMAL_MULTIMAP_MEMORY
  3114.   #endif
  3115.   #ifndef MINIMAL_MULTIMAP_MEMORY
  3116.     # Normalerweise hat man ca. 42 read-write und bei IMMUTABLE 8 read-only
  3117.     # Mappings.
  3118.     #define NORMAL_MULTIMAP_MEMORY
  3119.   #endif
  3120. #endif
  3121.  
  3122. #ifdef MAP_MEMORY
  3123.   #ifdef MINIMAL_MULTIMAP_MEMORY
  3124.     # Durchs Memory-Mapping ist jetzt das Immutable-Bit einer Adresse redundant.
  3125.     #define immutable_bit_t  6
  3126.     #define immutable_bit_o  30
  3127.     #undef addressbus_mask
  3128.     #define addressbus_mask  ~(1UL<<immutable_bit_o)
  3129.   #else
  3130.     #if defined(SUN4_29)
  3131.       # Durchs Memory-Mapping sind jetzt die Bits 28..24 einer Adresse redundant.
  3132.       #undef addressbus_mask
  3133.       #define addressbus_mask  0xE0FFFFFFUL
  3134.     #elif defined(DECALPHA) && defined(UNIX_OSF)
  3135.       # Durchs Memory-Mapping sind jetzt die Bits 37..33 einer Adresse redundant.
  3136.       #undef addressbus_mask
  3137.       #define addressbus_mask  0xFFFFFFC1FFFFFFFFUL
  3138.     #else
  3139.       # Durchs Memory-Mapping sind jetzt die Bits 31..24 einer Adresse redundant.
  3140.       #undef addressbus_mask
  3141.       #define addressbus_mask  oint_addr_mask  # meist = 0x00FFFFFFUL
  3142.     #endif
  3143.   #endif
  3144.   # Aber evtl. sind einige Typbit-Kombinationen nicht erlaubt.
  3145.   #ifdef vm_addr_mask
  3146.     #define tint_allowed_type_mask  ((oint_type_mask & vm_addr_mask) >> oint_type_shift)
  3147.   #endif
  3148. #endif
  3149.  
  3150.  
  3151. # Der Typ `object' liegt nun vollständig fest.
  3152. #ifdef WIDE_STRUCT
  3153.   #ifdef GENERATIONAL_GC
  3154.     # Die Generational GC kann es nicht brauchen, daß ein einzelner
  3155.     # Objektpointer sich auf zwei Seiten erstreckt.
  3156.     # Erzwinge daher  alignof(object) = sizeof(object).
  3157.     #define _attribute_aligned_object_  __attribute__ ((aligned(8)))
  3158.   #else
  3159.     #define _attribute_aligned_object_
  3160.   #endif
  3161.   TYPEDEF_OBJECT
  3162. #endif
  3163.  
  3164.  
  3165. # Objekte variabler Länge müssen an durch 2 (o.ä.) teilbaren Adressen liegen:
  3166. #if defined(VAX) # ?? gcc/config/vax/vax.h sagt: Alignment = 4
  3167.   #define varobject_alignment  1
  3168. #endif
  3169. #if defined(MC680X0)
  3170.   #if !(addr_shift==0)
  3171.     #define varobject_alignment  bit(addr_shift)  # wegen der gedrängten Typcodeverteilung
  3172.   #else
  3173.     #define varobject_alignment  2
  3174.   #endif
  3175. #endif
  3176. #if defined(I80Z86) || defined(RS6000) || defined(CONVEX) || defined(ARM)
  3177.   #define varobject_alignment  4
  3178. #endif
  3179. #if defined(SPARC) || defined(HPPA) || defined(MIPS) || defined(M88000) || defined(DECALPHA)
  3180.   #define varobject_alignment  8
  3181. #endif
  3182. #if defined(GENERATIONAL_GC) && (varobject_alignment < 4)
  3183.   #undef varobject_alignment
  3184.   #define varobject_alignment  4
  3185. #endif
  3186. #if defined(GENERATIONAL_GC) && defined(WIDE) && (varobject_alignment < 8)
  3187.   #undef varobject_alignment
  3188.   #define varobject_alignment  8
  3189. #endif
  3190. # varobject_alignment sollte definiert sein:
  3191. #ifndef varobject_alignment
  3192.   #error "varobject_alignment depends on CPU -- varobject_alignment neu einstellen!!"
  3193. #endif
  3194. # varobject_alignment sollte eine Zweierpotenz sein:
  3195. #if !((varobject_alignment & (varobject_alignment-1)) ==0)
  3196.   #error "Bogus varobject_alignment -- varobject_alignment neu einstellen!!"
  3197. #endif
  3198. # varobject_alignment sollte ein Vielfaches von 2^addr_shift sein:
  3199. #if (varobject_alignment % bit(addr_shift))
  3200.   #error "Bogus varobject_alignment -- varobject_alignment neu einstellen!!"
  3201. #endif
  3202.  
  3203.  
  3204. # Es folgt die Festlegung der einzelnen Typbits und Typcodes.
  3205.  
  3206. # Feststellen, ob ein Typ bei GC keine Veränderung erfährt
  3207. # (z.B. weil er keinen Pointer darstellt):
  3208.   #if 0 && defined(GNU)
  3209.     #define immediate_type_p(type)  \
  3210.       ({var reg1 boolean _erg;                 \
  3211.         switch (type)                          \
  3212.           { case_machine:                      \
  3213.             case_char: case_subr: case_system: \
  3214.             case_fixnum: case_sfloat:          \
  3215.             /* bei WIDE auch: case_ffloat: */  \
  3216.               _erg = TRUE; break;              \
  3217.             default: _erg = FALSE; break;      \
  3218.           }                                    \
  3219.         _erg;                                  \
  3220.        })
  3221.   #endif
  3222.  
  3223. #ifndef tint_allowed_type_mask
  3224.   #define tint_allowed_type_mask  tint_type_mask
  3225. #endif
  3226.  
  3227. # Wir haben 6 bis 8 Typbits zur Verfügung: TB7, [TB6,] [TB5,] TB4, ..., TB0.
  3228. # Alle müssen in tint_allowed_type_mask und damit auch in tint_type_mask
  3229. # gesetzt sein. Wir verteilen sie unter der Annahme, daß in tint_type_mask
  3230. # höchstens ein Bit fehlt. TB6 und TB5 werden, falls nicht benutzbar,
  3231. # auf -1 gesetzt.
  3232. #if ((0xFF & ~tint_allowed_type_mask) == 0)
  3233.   #define TB7 7
  3234.   #define TB6 6
  3235.   #define TB5 5
  3236.   #define TB4 4
  3237.   #define TB3 3
  3238.   #define TB2 2
  3239.   #define TB1 1
  3240.   #define TB0 0
  3241. #elif (oint_type_len==6)
  3242.   #define TB7 5
  3243.   #define TB6 -1
  3244.   #define TB5 -1
  3245.   #define TB4 4
  3246.   #define TB3 3
  3247.   #define TB2 2
  3248.   #define TB1 1
  3249.   #define TB0 0
  3250. #elif (oint_type_len>=8) && !((0xFF & ~tint_allowed_type_mask) == 0)
  3251.   # Manchem Bit müssen wir aus dem Weg gehen:
  3252.   #define tint_avoid  (0xFF & ~tint_allowed_type_mask)
  3253.   #if ((tint_avoid & (tint_avoid-1)) == 0)
  3254.     # tint_avoid besteht aus genau einem Bit, das es zu vermeiden gilt.
  3255.     #if (tint_avoid > bit(0))
  3256.       #define TB0 0
  3257.     #else
  3258.       #define TB0 1
  3259.     #endif
  3260.     #if (tint_avoid > bit(1))
  3261.       #define TB1 1
  3262.     #else
  3263.       #define TB1 2
  3264.     #endif
  3265.     #if (tint_avoid > bit(2))
  3266.       #define TB2 2
  3267.     #else
  3268.       #define TB2 3
  3269.     #endif
  3270.     #if (tint_avoid > bit(3))
  3271.       #define TB3 3
  3272.     #else
  3273.       #define TB3 4
  3274.     #endif
  3275.     #if (tint_avoid > bit(4))
  3276.       #define TB4 4
  3277.     #else
  3278.       #define TB4 5
  3279.     #endif
  3280.     #if (tint_avoid > bit(5))
  3281.       #define TB5 5
  3282.     #else
  3283.       #define TB5 6
  3284.     #endif
  3285.     #define TB6 -1
  3286.     #if (tint_avoid > bit(6))
  3287.       #define TB7 6
  3288.     #else
  3289.       #define TB7 7
  3290.     #endif
  3291.   #else
  3292.     # tint_avoid darf höchstens zwei Bits enthalten:
  3293.     #if ((tint_avoid & (tint_avoid-1)) & ((tint_avoid & (tint_avoid-1)) - 1))
  3294.       #error "Bogus oint_type_mask -- oint_type_mask neu einstellen!"
  3295.     #endif
  3296.     # Das eine verbotene Bit können wir immer noch als GC-Bit nutzen,
  3297.     # vorausgesetzt, es ist in tint_type_mask enthalten:
  3298.     #define tint_maybegc_type_mask  (0xFF & tint_type_mask & ~tint_allowed_type_mask)
  3299.     #if (tint_maybegc_type_mask==0)
  3300.       #error "Bogus oint_type_mask, vm_addr_mask -- oint_type_mask, vm_addr_mask neu einstellen!"
  3301.     #endif
  3302.     # Davon nehmen wir das kleinere Bit als GC-Bit:
  3303.     #define tint_avoid1  (tint_maybegc_type_mask & -tint_maybegc_type_mask)
  3304.     #if (tint_avoid1 == bit(0))
  3305.       #define TB7 0
  3306.     #elif (tint_avoid1 == bit(1))
  3307.       #define TB7 1
  3308.     #elif (tint_avoid1 == bit(2))
  3309.       #define TB7 2
  3310.     #elif (tint_avoid1 == bit(3))
  3311.       #define TB7 3
  3312.     #elif (tint_avoid1 == bit(4))
  3313.       #define TB7 4
  3314.     #elif (tint_avoid1 == bit(5))
  3315.       #define TB7 5
  3316.     #elif (tint_avoid1 == bit(6))
  3317.       #define TB7 6
  3318.     #elif (tint_avoid1 == bit(7))
  3319.       #define TB7 7
  3320.     #else
  3321.       #error "Bogus tint_avoid1!"
  3322.     #endif
  3323.     #define TB6 -1
  3324.     # Und das größere Bit gilt es noch zu vermeiden:
  3325.     #define tint_avoid2  (tint_avoid & ~tint_avoid1)
  3326.     #if (TB7 > 0) && (tint_avoid2 > bit(0))
  3327.       #define TB0 0
  3328.     #elif (TB7 > 1) || (tint_avoid2 > bit(1))
  3329.       #define TB0 1
  3330.     #else
  3331.       #define TB0 2
  3332.     #endif
  3333.     #if (TB7 > 1) && (tint_avoid2 > bit(1))
  3334.       #define TB1 1
  3335.     #elif (TB7 > 2) || (tint_avoid2 > bit(2))
  3336.       #define TB1 2
  3337.     #else
  3338.       #define TB1 3
  3339.     #endif
  3340.     #if (TB7 > 2) && (tint_avoid2 > bit(2))
  3341.       #define TB2 2
  3342.     #elif (TB7 > 3) || (tint_avoid2 > bit(3))
  3343.       #define TB2 3
  3344.     #else
  3345.       #define TB2 4
  3346.     #endif
  3347.     #if (TB7 > 3) && (tint_avoid2 > bit(3))
  3348.       #define TB3 3
  3349.     #elif (TB7 > 4) || (tint_avoid2 > bit(4))
  3350.       #define TB3 4
  3351.     #else
  3352.       #define TB3 5
  3353.     #endif
  3354.     #if (TB7 > 4) && (tint_avoid2 > bit(4))
  3355.       #define TB4 4
  3356.     #elif (TB7 > 5) || (tint_avoid2 > bit(5))
  3357.       #define TB4 5
  3358.     #else
  3359.       #define TB4 6
  3360.     #endif
  3361.     #if (TB7 > 5) && (tint_avoid2 > bit(5))
  3362.       #define TB5 5
  3363.     #elif (TB7 > 6) || (tint_avoid2 > bit(6))
  3364.       #define TB5 6
  3365.     #else
  3366.       #define TB5 7
  3367.     #endif
  3368.   #endif
  3369. #else
  3370.   #error "Bogus TB7..TB0 -- TB7..TB0 neu einstellen!"
  3371. #endif
  3372.  
  3373. #if (TB7==7)&&(TB6==6)&&(TB5==5)&&(TB4==4)&&(TB3==3)&&(TB2==2)&&(TB1==1)&&(TB0==0)
  3374.   #if defined(SUN3) && !defined(UNIX_SUNOS4) && !defined(WIDE_SOFT)
  3375.     #define SUN3_TYPECODES
  3376.   #elif defined(SUN4_29) && defined(MAP_MEMORY)
  3377.     #define PACKED_TYPECODES
  3378.   #elif defined(DECALPHA) && defined(UNIX_OSF) && defined(MAP_MEMORY)
  3379.     #define PACKED_TYPECODES
  3380.   #elif defined(MINIMAL_MULTIMAP_MEMORY)
  3381.     #define PACKED_TYPECODES
  3382.   #else
  3383.     #define STANDARD_TYPECODES
  3384.   #endif
  3385. #endif
  3386. #if (oint_type_len>=8) && (TB6==-1)
  3387.   #if defined(DECALPHA) && defined(UNIX_OSF) && defined(MAP_MEMORY)
  3388.     #define PACKED_TYPECODES
  3389.   #else
  3390.     #define SEVENBIT_TYPECODES
  3391.   #endif
  3392. #endif
  3393. #if (oint_type_len==6)
  3394.   #define SIXBIT_TYPECODES
  3395. #endif
  3396.  
  3397. #if (defined(IMMUTABLE_CONS) || defined(IMMUTABLE_ARRAY)) && !(defined(STANDARD_TYPECODES) || defined(PACKED_TYPECODES))
  3398.   # Currently only STANDARD_TYPECODES and PACKED_TYPECODES have support for
  3399.   # immutable objects.
  3400.   #error "Not enough type bits to support IMMUTABLE !"
  3401. #endif
  3402.  
  3403. #ifdef STANDARD_TYPECODES
  3404.  
  3405. #if defined(UNIX_LINUX) && (CODE_ADDRESS_RANGE == 0)
  3406.   # Zugriffe sind nur auf Pointer >=0, <0x60000000 erlaubt.
  3407.   # Deswegen brauchen wir die Typcode-Verteilung aber nicht zu ändern.
  3408. #endif
  3409.  
  3410. # Typbits:
  3411. # in Typcodes (tint):
  3412.   #define garcol_bit_t     7  # gesetzt nur während der Garbage Collection!
  3413.   #define cons_bit_t       6  # gesetzt nur bei CONS
  3414.   #define symbol_bit_t     5  # gesetzt nur bei SYMBOL
  3415.   #define number_bit_t     4  # gesetzt nur bei Zahlen
  3416.   #define notsimple_bit_t  2  # bei Arrays: gelöscht bei Simple-Arrays
  3417.   #define sign_bit_t       0  # Vorzeichen bei reellen Zahlen (gesetzt <==> Zahl <0)
  3418.   #define float_bit_t      1
  3419.   #define float1_bit_t     3
  3420.   #define float2_bit_t     2
  3421.   #define ratio_bit_t      3
  3422.   #define bignum_bit_t     2
  3423. # in Objekten (oint):
  3424.   #define garcol_bit_o     (garcol_bit_t+oint_type_shift)    # gesetzt nur während der Garbage Collection!
  3425.   #define cons_bit_o       (cons_bit_t+oint_type_shift)      # gesetzt nur bei CONS
  3426.   #define symbol_bit_o     (symbol_bit_t+oint_type_shift)    # gesetzt nur bei SYMBOL
  3427.   #define number_bit_o     (number_bit_t+oint_type_shift)    # gesetzt nur bei Zahlen
  3428.   #define notsimple_bit_o  (notsimple_bit_t+oint_type_shift) # bei Arrays: gelöscht bei Simple-Arrays
  3429.   #define sign_bit_o       (sign_bit_t+oint_type_shift)      # Vorzeichen bei reellen Zahlen
  3430.   #define float_bit_o      (float_bit_t+oint_type_shift)
  3431.   #define float1_bit_o     (float1_bit_t+oint_type_shift)
  3432.   #define float2_bit_o     (float2_bit_t+oint_type_shift)
  3433.   #define ratio_bit_o      (ratio_bit_t+oint_type_shift)
  3434.   #define bignum_bit_o     (bignum_bit_t+oint_type_shift)
  3435.  
  3436. # konstante Typcodes:
  3437.   #define machine_type   0x00  # %00000000  ; Maschinenpointer
  3438.   #define sbvector_type  0x01  # %00000001  ; Simple-Bit-Vector
  3439.   #define sstring_type   0x02  # %00000010  ; Simple-String
  3440.   #define svector_type   0x03  # %00000011  ; Simple-Vector
  3441.   #define array_type     0x04  # %00000100  ; sonstiger Array (Rang /=1 oder
  3442.                                #            ; - später vielleicht - anderer Elementtyp)
  3443.   #define bvector_type   0x05  # %00000101  ; sonstiger Bit-Vector oder Byte-Vector
  3444.   #define string_type    0x06  # %00000110  ; sonstiger String
  3445.   #define vector_type    0x07  # %00000111  ; sonstiger (VECTOR T)
  3446.   #define closure_type   0x08  # %00001000  ; Closure
  3447.   #define structure_type 0x09  # %00001001  ; Structure
  3448.   #define stream_type    0x0A  # %00001010  ; Stream
  3449.   #define orecord_type   0x0B  # %00001011  ; OtherRecord (Package, Byte, ...)
  3450.   #define instance_type  0x0C  # %00001100  ; CLOS-Instanz
  3451.   #define char_type      0x0D  # %00001101  ; Character
  3452.   #define subr_type      0x0E  # %00001110  ; SUBR
  3453.   #define system_type    0x0F  # %00001111  ; Frame-Pointer, Read-Label, SYSTEM
  3454.   #define fixnum_type    0x10  # %00010000  ; Fixnum
  3455.   #define sfloat_type    0x12  # %00010010  ; Short-Float
  3456.   #define bignum_type    0x14  # %00010100  ; Bignum
  3457.   #define ffloat_type    0x16  # %00010110  ; Single-Float
  3458.   #define ratio_type     0x18  # %00011000  ; Ratio
  3459.   #define dfloat_type    0x1A  # %00011010  ; Double-float
  3460.   #define complex_type   0x1C  # %00011100  ; Complex
  3461.   #define lfloat_type    0x1E  # %00011110  ; Long-Float
  3462.   #ifndef IMMUTABLE_ARRAY
  3463.   #define symbol_type    0x20  # %00100000  ; Symbol
  3464.           # Bits für Symbole in VAR/FUN-Frames (im LISP-Stack):
  3465.           #define active_bit  1  # gesetzt: Bindung ist aktiv
  3466.           #define dynam_bit   2  # gesetzt: Bindung ist dynamisch
  3467.           #define svar_bit    3  # gesetzt: nächster Parameter ist supplied-p-Parameter für diesen
  3468.           #define oint_symbolflags_shift  oint_type_shift
  3469.           # Bits für Symbole im Selbstpointer:
  3470.           #define constant_bit_t  1  # zeigt an, ob das Symbol eine Konstante ist
  3471.           #define special_bit_t   2  # zeigt an, ob das Symbol SPECIAL-proklamiert ist
  3472.           #define keyword_bit_t   3  # zeigt an, ob das Symbol ein Keyword ist
  3473.   #else
  3474.   #define imm_array_mask     0x20  # Maske, die immutable von normalen Arrays unterscheidet
  3475.   #define imm_sbvector_type  0x21  # %00100001  ; immutabler Simple-Bit-Vector
  3476.   #define imm_sstring_type   0x22  # %00100010  ; immutabler Simple-String
  3477.   #define imm_svector_type   0x23  # %00100011  ; immutabler Simple-Vector
  3478.   #define imm_array_type     0x24  # %00100100  ; immutabler sonstiger Array (Rang /=1 oder
  3479.                                    #            ; - später vielleicht - anderer Elementtyp)
  3480.   #define imm_bvector_type   0x25  # %00100101  ; immutabler sonstiger Bit-Vector oder Byte-Vector
  3481.   #define imm_string_type    0x26  # %00100110  ; immutabler sonstiger String
  3482.   #define imm_vector_type    0x27  # %00100111  ; immutabler sonstiger (VECTOR T)
  3483.   #define symbol_type    0x28  # %00101000  ; Symbol
  3484.           # Bits für Symbole in VAR/FUN-Frames (im LISP-Stack):
  3485.           #define active_bit  0  # gesetzt: Bindung ist aktiv
  3486.           #define dynam_bit   1  # gesetzt: Bindung ist dynamisch
  3487.           #define svar_bit    2  # gesetzt: nächster Parameter ist supplied-p-Parameter für diesen
  3488.           #define oint_symbolflags_shift  oint_type_shift
  3489.           # Bits für Symbole im Selbstpointer:
  3490.           #define constant_bit_t  0  # zeigt an, ob das Symbol eine Konstante ist
  3491.           #define special_bit_t   1  # zeigt an, ob das Symbol SPECIAL-proklamiert ist
  3492.           #define keyword_bit_t   2  # zeigt an, ob das Symbol ein Keyword ist
  3493.   #undef symbol_bit_t
  3494.   #undef symbol_bit_o
  3495.   #endif
  3496.   #define cons_type      0x40  # %01000000  ; Cons
  3497.   #ifdef IMMUTABLE_CONS
  3498.   #define imm_cons_type  0x41  # %01000001  ; immutable Cons
  3499.   #endif
  3500.  
  3501. #ifndef WIDE
  3502.   # Typ ist GC-invariant, wenn
  3503.   # Typinfobyte=0 oder char_type <= Typinfobyte < bignum_type.
  3504.     #define immediate_type_p(type)  \
  3505.       ((type==0) || ((char_type<=type) && (type<bignum_type)))
  3506. #else
  3507.   # Typ ist GC-invariant, wenn
  3508.   # Typinfobyte eines von 0x00,0x0D..0x13,0x16..0x17 ist.
  3509.     #define immediate_type_p(type)  \
  3510.       ((type<0x18) && ((bit(type) & 0xFF301FFEUL) == 0))
  3511. #endif
  3512.  
  3513. #endif # STANDARD_TYPECODES
  3514.  
  3515. #ifdef PACKED_TYPECODES
  3516.  
  3517. #ifdef SUN4_29
  3518. # Zugriffe sind nur auf Pointer >=0, <2^29 erlaubt.
  3519. # Daher eine etwas gedrängte Typcode-Verteilung.
  3520. #endif
  3521.  
  3522. #if defined(DECALPHA) && defined(UNIX_OSF) && !(defined(NO_SINGLEMAP) || defined(NO_TRIVIALMAP))
  3523. # mmap() geht nur mit Adressen >=0, <2^38, aber da gewöhnliche Pointer im
  3524. # Bereich 1*2^32..2*2^32 liegen, bleiben uns nur die Bits 37..33 als Typbits.
  3525. #endif
  3526.  
  3527. # Typbits:
  3528. # in Typcodes (tint):
  3529.   #define garcol_bit_t     TB7  # gesetzt nur während der Garbage Collection!
  3530.   #define number_bit_t     TB4  # gesetzt nur bei Zahlen
  3531.   #define notsimple_bit_t  TB2  # bei Arrays: gelöscht bei Simple-Arrays
  3532.   #define sign_bit_t       TB0  # Vorzeichen bei reellen Zahlen (gesetzt <==> Zahl <0)
  3533.   #define float_bit_t      TB1
  3534.   #define float1_bit_t     TB3
  3535.   #define float2_bit_t     TB2
  3536.   #define ratio_bit_t      TB3
  3537.   #define bignum_bit_t     TB2
  3538. # in Objekten (oint):
  3539.   #define garcol_bit_o     (garcol_bit_t+oint_type_shift)    # gesetzt nur während der Garbage Collection!
  3540.   #define number_bit_o     (number_bit_t+oint_type_shift)    # gesetzt nur bei Zahlen
  3541.   #define notsimple_bit_o  (notsimple_bit_t+oint_type_shift) # bei Arrays: gelöscht bei Simple-Arrays
  3542.   #define sign_bit_o       (sign_bit_t+oint_type_shift)      # Vorzeichen bei reellen Zahlen
  3543.   #define float_bit_o      (float_bit_t+oint_type_shift)
  3544.   #define float1_bit_o     (float1_bit_t+oint_type_shift)
  3545.   #define float2_bit_o     (float2_bit_t+oint_type_shift)
  3546.   #define ratio_bit_o      (ratio_bit_t+oint_type_shift)
  3547.   #define bignum_bit_o     (bignum_bit_t+oint_type_shift)
  3548. #ifdef IMMUTABLE
  3549.   # define immutable_bit_t  TB6                                # s.o.
  3550.   # define immutable_bit_o  (immutable_bit_t+oint_type_shift)  # s.o.
  3551. #endif
  3552.  
  3553. # konstante Typcodes:
  3554.   #define machine_type   (0)                                            # 0x00  # %00000000  ; Maschinenpointer
  3555.   #define sbvector_type  (                                    bit(TB0)) # 0x01  # %00000001  ; Simple-Bit-Vector
  3556.   #define sstring_type   (                           bit(TB1)         ) # 0x02  # %00000010  ; Simple-String
  3557.   #define svector_type   (                           bit(TB1)|bit(TB0)) # 0x03  # %00000011  ; Simple-Vector
  3558.   #define array_type     (                  bit(TB2)                  ) # 0x04  # %00000100  ; sonstiger Array (Rang /=1 oder
  3559.                                                                                 #            ; - später vielleicht - anderer Elementtyp)
  3560.   #define bvector_type   (                  bit(TB2)         |bit(TB0)) # 0x05  # %00000101  ; sonstiger Bit-Vector oder Byte-Vector
  3561.   #define string_type    (                  bit(TB2)|bit(TB1)         ) # 0x06  # %00000110  ; sonstiger String
  3562.   #define vector_type    (                  bit(TB2)|bit(TB1)|bit(TB0)) # 0x07  # %00000111  ; sonstiger (VECTOR T)
  3563.   #define closure_type   (         bit(TB3)                           ) # 0x08  # %00001000  ; Closure
  3564.   #define structure_type (         bit(TB3)                  |bit(TB0)) # 0x09  # %00001001  ; Structure
  3565.   #define stream_type    (         bit(TB3)         |bit(TB1)         ) # 0x0A  # %00001010  ; Stream
  3566.   #define orecord_type   (         bit(TB3)         |bit(TB1)|bit(TB0)) # 0x0B  # %00001011  ; OtherRecord (Package, Byte, ...)
  3567.   #define instance_type  (         bit(TB3)|bit(TB2)                  ) # 0x0C  # %00001100  ; CLOS-Instanz
  3568.   #define subr_type      (         bit(TB3)|bit(TB2)         |bit(TB0)) # 0x0D  # %00001101  ; SUBR
  3569.   #define symbol_type    (         bit(TB3)|bit(TB2)|bit(TB1)         ) # 0x0E  # %00001110  ; Symbol
  3570.           # Bits für Symbole in VAR/FUN-Frames (im LISP-Stack):
  3571.           # sitzen nicht im oint_type-Teil, sondern im oint_addr-Teil.
  3572.           #define active_bit  0  # gesetzt: Bindung ist aktiv
  3573.           #define dynam_bit   1  # gesetzt: Bindung ist dynamisch
  3574.           #define svar_bit    2  # gesetzt: nächster Parameter ist supplied-p-Parameter für diesen
  3575.           #if (varobject_alignment >= bit(3))
  3576.             #define oint_symbolflags_shift  oint_addr_shift
  3577.           #else
  3578.             #define NO_symbolflags # active_bit, dynam_bit, svar_bit haben im Symbol keinen Platz
  3579.           #endif
  3580.           # Bits für Symbole im Selbstpointer:
  3581.           #if !((TB3+3==TB7) || (TB3+2==TB7) || (TB3+1==TB7))
  3582.             #define constant_bit_t  (TB3+3)  # zeigt an, ob das Symbol eine Konstante ist
  3583.             #define special_bit_t   (TB3+2)  # zeigt an, ob das Symbol SPECIAL-proklamiert ist
  3584.             #define keyword_bit_t   (TB3+1)  # zeigt an, ob das Symbol ein Keyword ist
  3585.           #else
  3586.             #define constant_bit_t  (TB7+3)  # zeigt an, ob das Symbol eine Konstante ist
  3587.             #define special_bit_t   (TB7+2)  # zeigt an, ob das Symbol SPECIAL-proklamiert ist
  3588.             #define keyword_bit_t   (TB7+1)  # zeigt an, ob das Symbol ein Keyword ist
  3589.           #endif
  3590.   #define cons_type      (         bit(TB3)|bit(TB2)|bit(TB1)|bit(TB0)) # 0x0F  # %00001111  ; Cons
  3591.   #define fixnum_type    (bit(TB4)                                    ) # 0x10  # %00010000  ; Fixnum
  3592.   #define sfloat_type    (bit(TB4)                  |bit(TB1)         ) # 0x12  # %00010010  ; Short-Float
  3593.   #define bignum_type    (bit(TB4)         |bit(TB2)                  ) # 0x14  # %00010100  ; Bignum
  3594.   #define ffloat_type    (bit(TB4)         |bit(TB2)|bit(TB1)         ) # 0x16  # %00010110  ; Single-Float
  3595.   #define ratio_type     (bit(TB4)|bit(TB3)                           ) # 0x18  # %00011000  ; Ratio
  3596.   #define dfloat_type    (bit(TB4)|bit(TB3)         |bit(TB1)         ) # 0x1A  # %00011010  ; Double-float
  3597.   #define complex_type   (bit(TB4)|bit(TB3)|bit(TB2)                  ) # 0x1C  # %00011100  ; Complex
  3598.   #define lfloat_type    (bit(TB4)|bit(TB3)|bit(TB2)|bit(TB1)         ) # 0x1E  # %00011110  ; Long-Float
  3599.   #define system_type    (bit(TB5)                                    ) # 0x20  # %00100000  ; Frame-Pointer, Read-Label, SYSTEM
  3600.   #define char_type      (bit(TB5)|bit(TB0)                           ) # 0x21  # %00100001  ; Character
  3601. #ifdef IMMUTABLE
  3602.   #define imm_type  bit(immutable_bit_t)
  3603.  #ifdef IMMUTABLE_ARRAY
  3604.   #define imm_array_mask     imm_type  # Maske, die immutable von normalen Arrays unterscheidet
  3605.   #define imm_sbvector_type  (imm_array_mask|sbvector_type)  # immutabler Simple-Bit-Vector
  3606.   #define imm_sstring_type   (imm_array_mask|sstring_type)   # immutabler Simple-String
  3607.   #define imm_svector_type   (imm_array_mask|svector_type)   # immutabler Simple-Vector
  3608.   #define imm_array_type     (imm_array_mask|array_type)     # immutabler sonstiger Array (Rang /=1 oder
  3609.                                                              # - später vielleicht - anderer Elementtyp)
  3610.   #define imm_bvector_type   (imm_array_mask|bvector_type)   # immutabler sonstiger Bit-Vector oder Byte-Vector
  3611.   #define imm_string_type    (imm_array_mask|string_type)    # immutabler sonstiger String
  3612.   #define imm_vector_type    (imm_array_mask|vector_type)    # immutabler sonstiger (VECTOR T)
  3613.  #endif
  3614.  #ifdef IMMUTABLE_CONS
  3615.   #define imm_cons_mask  imm_type
  3616.   #define imm_cons_type  (imm_cons_mask|cons_type)  # immutable Cons
  3617.  #endif
  3618. #else
  3619.   #define imm_type  0
  3620. #endif
  3621.  
  3622. # Typ ist GC-invariant, wenn
  3623.   #if (TB5==5)&&(TB4==4)&&(TB3==3)&&(TB2==2)&&(TB1==1)&&(TB0==0) && !defined(WIDE)
  3624.     # Typinfobyte eines von 0x00,0x0D,0x10,0x11,0x12,0x13,0x20,0x21 ist.
  3625.     #define immediate_type_p(type)  \
  3626.       ((((type)&~imm_type)>=32) || ((bit(type) & 0xFFF0DFFEUL) == 0))
  3627.   #elif (TB5==6)&&(TB4==5)&&(TB3==4)&&(TB2==3)&&(TB1==2)&&(TB0==1) && defined(WIDE)
  3628.     # Typinfobyte/2 eines von 0x00,0x0D,0x10,0x11,0x12,0x13,0x16,0x17,0x20,0x21 ist.
  3629.     #define immediate_type_p(type)  \
  3630.       (((type)>=64) || ((bit((type)>>1) & 0xFF30DFFEUL) == 0))
  3631.   #endif
  3632.  
  3633. #endif # PACKED_TYPECODES
  3634.  
  3635. #ifdef SEVENBIT_TYPECODES
  3636.  
  3637. #if defined(UNIX_SYSV_UHC_1) || (defined(UNIX_LINUX) && (CODE_ADDRESS_RANGE != 0))
  3638. # Mallozierter Speicher belegt den Bereich ab 0x08000000.
  3639. # Für die Typinformation stehen nur 7 Bit zur Verfügung, und die für den
  3640. # Typcode zur Verfügung stehenden Bits liegen nicht am Stück.
  3641. # Wir müssen Bit 3 aus dem Weg gehen.
  3642. #if defined(UNIX_LINUX) && (CODE_ADDRESS_RANGE != 0)
  3643. # Shared Libraries belegen den Bereich ab 0x40000000 oder 0x50000000.
  3644. # Nehme daher Bit 6 als GC-Bit.
  3645. #endif
  3646. #endif
  3647.  
  3648. #if defined(UNIX_IRIX) || defined(UNIX_DEC_ULTRIX)
  3649. # Mallozierter Speicher belegt den Bereich ab 0x10000000.
  3650. # Für die Typinformation stehen nur 7 Bit zur Verfügung, und die für den
  3651. # Typcode zur Verfügung stehenden Bits liegen nicht am Stück.
  3652. # Wir müssen Bit 4 aus dem Weg gehen.
  3653. #endif
  3654.  
  3655. #ifdef UNIX_AIX
  3656. # Mallozierter Speicher belegt den Bereich ab 0x20000000.
  3657. # Für die Typinformation stehen nur 7 Bit zur Verfügung, und die für den
  3658. # Typcode zur Verfügung stehenden Bits liegen nicht am Stück.
  3659. # Wir müssen Bit 5 aus dem Weg gehen.
  3660. #endif
  3661.  
  3662. #if defined(UNIX_NEXTSTEP) && defined(MAP_MEMORY)
  3663. # UNIX_NEXTSTEP verbietet uns die Benutzung von Adressen im Bereich von
  3664. # unterhalb 0x04000000 bis oberhalb 0x05000000. Wir vermeiden daher als
  3665. # Typbits Bit 0 und Bit 2 (ausgenommen GC-Bit, das ja vor jedem Speicherzugriff
  3666. # wegmaskiert wird).
  3667. #endif
  3668.  
  3669. #if defined(UNIX_CONVEX) && defined(MAP_MEMORY)
  3670. # Bei UNIX_CONVEX liegt der Adreßraum der Prozesse ab 0x80000000.
  3671. # mmap() funktioniert allerdings nur unterhalb von 0xC000000. Daher
  3672. # gehört Bit 31 zur Adresse, und Bit 30 müssen wir aus dem Weg gehen.
  3673. #endif
  3674.  
  3675. # Typbits:
  3676. # in Typcodes (tint):
  3677.   #define garcol_bit_t     TB7  # gesetzt nur während der Garbage Collection!
  3678.   #define number_bit_t     TB4  # gesetzt nur bei Zahlen
  3679.   #define notsimple_bit_t  TB2  # bei Arrays: gelöscht bei Simple-Arrays
  3680.   #define sign_bit_t       TB0  # Vorzeichen bei reellen Zahlen (gesetzt <==> Zahl <0)
  3681.   #define float_bit_t      TB1
  3682.   #define float1_bit_t     TB3
  3683.   #define float2_bit_t     TB2
  3684.   #define ratio_bit_t      TB3
  3685.   #define bignum_bit_t     TB2
  3686. # in Objekten (oint):
  3687.   #define garcol_bit_o     (garcol_bit_t+oint_type_shift)    # gesetzt nur während der Garbage Collection!
  3688.   #define number_bit_o     (number_bit_t+oint_type_shift)    # gesetzt nur bei Zahlen
  3689.   #define notsimple_bit_o  (notsimple_bit_t+oint_type_shift) # bei Arrays: gelöscht bei Simple-Arrays
  3690.   #define sign_bit_o       (sign_bit_t+oint_type_shift)      # Vorzeichen bei reellen Zahlen
  3691.   #define float_bit_o      (float_bit_t+oint_type_shift)
  3692.   #define float1_bit_o     (float1_bit_t+oint_type_shift)
  3693.   #define float2_bit_o     (float2_bit_t+oint_type_shift)
  3694.   #define ratio_bit_o      (ratio_bit_t+oint_type_shift)
  3695.   #define bignum_bit_o     (bignum_bit_t+oint_type_shift)
  3696.  
  3697. # konstante Typcodes:
  3698.   #define machine_type   (0)                                             # %000000  ; Maschinenpointer
  3699.   #define sbvector_type  (                                    bit(TB0))  # %000001  ; Simple-Bit-Vector
  3700.   #define sstring_type   (                           bit(TB1)         )  # %000010  ; Simple-String
  3701.   #define svector_type   (                           bit(TB1)|bit(TB0))  # %000011  ; Simple-Vector
  3702.   #define array_type     (                  bit(TB2)                  )  # %000100  ; sonstiger Array (Rang /=1 oder
  3703.                                                                          #          ; - später vielleicht - anderer Elementtyp)
  3704.   #define bvector_type   (                  bit(TB2)         |bit(TB0))  # %000101  ; sonstiger Bit-Vector oder Byte-Vector
  3705.   #define string_type    (                  bit(TB2)|bit(TB1)         )  # %000110  ; sonstiger String
  3706.   #define vector_type    (                  bit(TB2)|bit(TB1)|bit(TB0))  # %000111  ; sonstiger (VECTOR T)
  3707.   #define closure_type   (         bit(TB3)                           )  # %001000  ; Closure
  3708.   #define structure_type (         bit(TB3)                  |bit(TB0))  # %001001  ; Structure
  3709.   #define stream_type    (         bit(TB3)         |bit(TB1)         )  # %001010  ; Stream
  3710.   #define orecord_type   (         bit(TB3)         |bit(TB1)|bit(TB0))  # %001011  ; OtherRecord (Package, Byte, ...)
  3711.   #define instance_type  (         bit(TB3)|bit(TB2)                  )  # %001100  ; CLOS-Instanz
  3712.   #define char_type      (         bit(TB3)|bit(TB2)         |bit(TB0))  # %001101  ; Character
  3713.   #define subr_type      (         bit(TB3)|bit(TB2)|bit(TB1)         )  # %001110  ; SUBR
  3714.   #define system_type    (         bit(TB3)|bit(TB2)|bit(TB1)|bit(TB0))  # %001111  ; Frame-Pointer, Read-Label, SYSTEM
  3715.   #define fixnum_type    (bit(TB4)                                    )  # %010000  ; Fixnum
  3716.   #define sfloat_type    (bit(TB4)                  |bit(TB1)         )  # %010010  ; Short-Float
  3717.   #define bignum_type    (bit(TB4)         |bit(TB2)                  )  # %010100  ; Bignum
  3718.   #define ffloat_type    (bit(TB4)         |bit(TB2)|bit(TB1)         )  # %010110  ; Single-Float
  3719.   #define ratio_type     (bit(TB4)|bit(TB3)                           )  # %011000  ; Ratio
  3720.   #define dfloat_type    (bit(TB4)|bit(TB3)         |bit(TB1)         )  # %011010  ; Double-float
  3721.   #define complex_type   (bit(TB4)|bit(TB3)|bit(TB2)                  )  # %011100  ; Complex
  3722.   #define lfloat_type    (bit(TB4)|bit(TB3)|bit(TB2)|bit(TB1)         )  # %011110  ; Long-Float
  3723.   #define symbol_type    (bit(TB5)                                    )  # %100000  ; Symbol
  3724.           # Bits für Symbole in VAR/FUN-Frames (im LISP-Stack):
  3725.           #define active_bit  TB0  # gesetzt: Bindung ist aktiv
  3726.           #define dynam_bit   TB1  # gesetzt: Bindung ist dynamisch
  3727.           #define svar_bit    TB2  # gesetzt: nächster Parameter ist supplied-p-Parameter für diesen
  3728.           #define oint_symbolflags_shift  oint_type_shift
  3729.           # Bits für Symbole im Selbstpointer:
  3730.           #define constant_bit_t  TB0  # zeigt an, ob das Symbol eine Konstante ist
  3731.           #define special_bit_t   TB1  # zeigt an, ob das Symbol SPECIAL-proklamiert ist
  3732.           #define keyword_bit_t   TB2  # zeigt an, ob das Symbol ein Keyword ist
  3733.   #define cons_type      (bit(TB5)|bit(TB3))                             # %101000  ; Cons
  3734.  
  3735. #ifndef WIDE
  3736.   # Typ ist GC-invariant, wenn
  3737.   # Typinfobyte=0 oder char_type <= Typinfobyte < bignum_type.
  3738.     #define immediate_type_p(type)  \
  3739.       ((type==0) || ((char_type<=type) && (type<bignum_type)))
  3740. #else
  3741.   #error "immediate_type_p() implementieren!"
  3742. #endif
  3743.  
  3744. #endif # SEVENBIT_TYPECODES
  3745.  
  3746. #ifdef SIXBIT_TYPECODES
  3747.  
  3748. #if defined(ACORN_3) || defined(ACORN_4)
  3749. # Speicher kann den Bereich von 0x00000000 bis 0x03FFFFFF umfassen.
  3750. # Für die Typinformation stehen nur 6 Bit zur Verfügung.
  3751. #endif
  3752.  
  3753. #ifdef AMIGA3000
  3754. # Speicher kann den Bereich von 0x07000000 bis 0x0FFFFFFF umfassen.
  3755. # Für die Typinformation stehen nur 6 Bit zur Verfügung, und dies auch nur,
  3756. # wenn wir Alignment = 4 voraussetzen.
  3757. # Das können wir aber nicht, da der C-Compiler bzw. der Linker im Text-Segment
  3758. # nur Alignment = 2 hat. Somit können wir nur den Bereich von 0x07000000 bis
  3759. # 0x07FFFFFF nutzen.
  3760. #endif
  3761.  
  3762. #if defined(HPPA) && defined(UNIX_HPUX)
  3763. # Mallozierter Speicher belegt den Bereich ab 0x40000000.
  3764. # Für die Typinformation stehen die Bits 29..24 zur Verfügung.
  3765. #endif
  3766.  
  3767. #ifdef UNIX_AMIX
  3768. # Bits 31..30 werden vom Betriebssystem belegt.
  3769. # Für die Typinformation stehen die Bits 29..24 zur Verfügung.
  3770. #endif
  3771.  
  3772. #ifdef UNIX_SYSV_UHC_2
  3773. # Mallozierter Speicher belegt den Bereich ab 0x08000000.
  3774. # Für die Typinformation stehen nur 6 Bit zur Verfügung, und dies auch nur,
  3775. # wenn wir Alignment = 4 voraussetzen.
  3776. #endif
  3777.  
  3778. #ifdef WATCOM_BLAKE
  3779. # When run with virtual memory or in the DOS box, the DOS4GW extender returns
  3780. # malloc'ed memory in the range beginning at 0x80000000.
  3781. # The type information can use the bits 30..25.
  3782. #endif
  3783.  
  3784. # Für die Typinformation stehen nur 6 Bit zur Verfügung.
  3785. # Daher eine etwas gedrängte Typcode-Verteilung.
  3786.  
  3787. # Typbits:
  3788. # in Typcodes (tint):
  3789.   #define garcol_bit_t     5  # gesetzt nur während der Garbage Collection!
  3790.   #define number_bit_t     4  # gesetzt nur bei Zahlen
  3791.   #define notsimple_bit_t  2  # bei Arrays: gelöscht bei Simple-Arrays
  3792.   #define sign_bit_t       0  # Vorzeichen bei reellen Zahlen (gesetzt <==> Zahl <0)
  3793.   #define float_bit_t      1
  3794.   #define float1_bit_t     3
  3795.   #define float2_bit_t     2
  3796.   #define ratio_bit_t      3
  3797.   #define bignum_bit_t     2
  3798. # in Objekten (oint):
  3799.   #define garcol_bit_o     (garcol_bit_t+oint_type_shift)    # gesetzt nur während der Garbage Collection!
  3800.   #define number_bit_o     (number_bit_t+oint_type_shift)    # gesetzt nur bei Zahlen
  3801.   #define notsimple_bit_o  (notsimple_bit_t+oint_type_shift) # bei Arrays: gelöscht bei Simple-Arrays
  3802.   #define sign_bit_o       (sign_bit_t+oint_type_shift)      # Vorzeichen bei reellen Zahlen
  3803.   #define float_bit_o      (float_bit_t+oint_type_shift)
  3804.   #define float1_bit_o     (float1_bit_t+oint_type_shift)
  3805.   #define float2_bit_o     (float2_bit_t+oint_type_shift)
  3806.   #define ratio_bit_o      (ratio_bit_t+oint_type_shift)
  3807.   #define bignum_bit_o     (bignum_bit_t+oint_type_shift)
  3808.  
  3809. # konstante Typcodes:
  3810.   #define machine_type   0x00  # %000000  ; Maschinenpointer
  3811.   #define sbvector_type  0x01  # %000001  ; Simple-Bit-Vector
  3812.   #define sstring_type   0x02  # %000010  ; Simple-String
  3813.   #define svector_type   0x03  # %000011  ; Simple-Vector
  3814.   #define array_type     0x04  # %000100  ; sonstiger Array (Rang /=1 oder
  3815.                                #          ; - später vielleicht - anderer Elementtyp)
  3816.   #define bvector_type   0x05  # %000101  ; sonstiger Bit-Vector oder Byte-Vector
  3817.   #define string_type    0x06  # %000110  ; sonstiger String
  3818.   #define vector_type    0x07  # %000111  ; sonstiger (VECTOR T)
  3819.   #define symbol_type    0x08  # %001000  ; Symbol
  3820.           # Bits für Symbole in VAR/FUN-Frames (im LISP-Stack):
  3821.           #define active_bit  0  # gesetzt: Bindung ist aktiv
  3822.           #define dynam_bit   1  # gesetzt: Bindung ist dynamisch
  3823.           #define svar_bit    2  # gesetzt: nächster Parameter ist supplied-p-Parameter für diesen
  3824.           #if defined(ACORN_3) || defined(ACORN_4) || defined(AMIGA3000) || defined(UNIX_AMIX) || defined(WATCOM_BLAKE)
  3825.             #define NO_symbolflags # active_bit, dynam_bit, svar_bit haben im Symbol keinen Platz
  3826.           #endif
  3827.           #if defined(HPPA) && defined(UNIX_HPUX)
  3828.             # sitzen nicht im oint_type-Teil, sondern im oint_addr-Teil.
  3829.             #define oint_symbolflags_shift  oint_addr_shift
  3830.           #endif
  3831.           #if defined(UNIX_SYSV_UHC_2)
  3832.             # sitzen im oberen oint_addr-Teil.
  3833.             #define oint_symbolflags_shift  (24-addr_shift + oint_addr_shift)
  3834.           #endif
  3835.           # Bits für Symbole im Selbstpointer:
  3836.           #define constant_bit_t  4  # zeigt an, ob das Symbol eine Konstante ist
  3837.           #define special_bit_t   0  # zeigt an, ob das Symbol SPECIAL-proklamiert ist
  3838.           #define keyword_bit_t   2  # zeigt an, ob das Symbol ein Keyword ist
  3839.   #define cons_type      0x09  # %001001  ; Cons
  3840.   #define subr_type      0x0A  # %001010  ; SUBR
  3841.   #define instance_type  0x0B  # %001011  ; CLOS-Instanz
  3842.   #define closure_type   0x0C  # %001100  ; Closure
  3843.   #define orecord_type   0x0D  # %001101  ; OtherRecord (Structure, Stream, Package, Byte, ...)
  3844.   #define system_type    0x0E  # %001110  ; Frame-Pointer, Read-Label, SYSTEM
  3845.   #define char_type      0x0F  # %001111  ; Character
  3846.   #define fixnum_type    0x10  # %010000  ; Fixnum
  3847.   #define sfloat_type    0x12  # %010010  ; Short-Float
  3848.   #define bignum_type    0x14  # %010100  ; Bignum
  3849.   #define ffloat_type    0x16  # %010110  ; Single-Float
  3850.   #define ratio_type     0x18  # %011000  ; Ratio
  3851.   #define dfloat_type    0x1A  # %011010  ; Double-float
  3852.   #define complex_type   0x1C  # %011100  ; Complex
  3853.   #define lfloat_type    0x1E  # %011110  ; Long-Float
  3854.  
  3855. # Typ ist GC-invariant, wenn
  3856. # Typinfobyte eines von 0x00,0x0A,0x0E,0x0F,0x10,0x11,0x12,0x13 ist.
  3857.   #define immediate_type_p(type)  \
  3858.     ((bit(type) & 0xFFF03BFEUL) == 0)
  3859.  
  3860. #endif # SIXBIT_TYPECODES
  3861.  
  3862. #ifdef SUN3_TYPECODES
  3863.  
  3864. # Typbits:
  3865. # in Typcodes (tint):
  3866.   #define garcol_bit_t     1  # gesetzt nur während der Garbage Collection!
  3867.   #define cons_bit_t       7  # gesetzt nur bei CONS
  3868.   #define symbol_bit_t     6  # gesetzt nur bei SYMBOL
  3869.   #define number_bit_t     2  # gesetzt nur bei Zahlen
  3870.   #define notsimple_bit_t  0  # bei Arrays: gelöscht bei Simple-Arrays
  3871.   #define sign_bit_t       0  # Vorzeichen bei reellen Zahlen (gesetzt <==> Zahl <0)
  3872.   #define float_bit_t      5
  3873.   #define float1_bit_t     3
  3874.   #define float2_bit_t     4
  3875.   #define ratio_bit_t      3
  3876.   #define bignum_bit_t     4
  3877. # in Objekten (oint):
  3878.   #define garcol_bit_o     (garcol_bit_t+oint_type_shift)    # gesetzt nur während der Garbage Collection!
  3879.   #define cons_bit_o       (cons_bit_t+oint_type_shift)      # gesetzt nur bei CONS
  3880.   #define symbol_bit_o     (symbol_bit_t+oint_type_shift)    # gesetzt nur bei SYMBOL
  3881.   #define number_bit_o     (number_bit_t+oint_type_shift)    # gesetzt nur bei Zahlen
  3882.   #define notsimple_bit_o  (notsimple_bit_t+oint_type_shift) # bei Arrays: gelöscht bei Simple-Arrays
  3883.   #define sign_bit_o       (sign_bit_t+oint_type_shift)      # Vorzeichen bei reellen Zahlen
  3884.   #define float_bit_o      (float_bit_t+oint_type_shift)
  3885.   #define float1_bit_o     (float1_bit_t+oint_type_shift)
  3886.   #define float2_bit_o     (float2_bit_t+oint_type_shift)
  3887.   #define ratio_bit_o      (ratio_bit_t+oint_type_shift)
  3888.   #define bignum_bit_o     (bignum_bit_t+oint_type_shift)
  3889.  
  3890. # konstante Typcodes:
  3891.   #define machine_type   0x00  # %00000000  ; Maschinenpointer
  3892.   #define sbvector_type  0x10  # %00010000  ; Simple-Bit-Vector
  3893.   #define sstring_type   0x08  # %00001000  ; Simple-String
  3894.   #define svector_type   0x18  # %00011000  ; Simple-Vector
  3895.   #define array_type     0x01  # %00000001  ; sonstiger Array (Rang /=1 oder
  3896.                                #            ; - später vielleicht - anderer Elementtyp)
  3897.   #define bvector_type   0x11  # %00010001  ; sonstiger Bit-Vector oder Byte-Vector
  3898.   #define string_type    0x09  # %00001001  ; sonstiger String
  3899.   #define vector_type    0x19  # %00011001  ; sonstiger (VECTOR T)
  3900.   #define closure_type   0x20  # %00100000  ; Closure
  3901.   #define structure_type 0x21  # %00100001  ; Structure
  3902.   #define stream_type    0x28  # %00101000  ; Stream
  3903.   #define orecord_type   0x29  # %00101001  ; OtherRecord (Package, Byte, ...)
  3904.   #define instance_type  0x39  # %00111001  ; CLOS-Instanz
  3905.   #define char_type      0x31  # %00110001  ; Character
  3906.   #define subr_type      0x30  # %00110000  ; SUBR
  3907.   #define system_type    0x38  # %00111000  ; Frame-Pointer, Read-Label, SYSTEM
  3908.   #define fixnum_type    0x04  # %00000100  ; Fixnum
  3909.   #define sfloat_type    0x24  # %00100100  ; Short-Float
  3910.   #define bignum_type    0x14  # %00010100  ; Bignum
  3911.   #define ffloat_type    0x34  # %00110100  ; Single-Float
  3912.   #define ratio_type     0x0C  # %00001100  ; Ratio
  3913.   #define dfloat_type    0x2C  # %00101100  ; Double-float
  3914.   #define complex_type   0x1C  # %00011100  ; Complex
  3915.   #define lfloat_type    0x3C  # %00111100  ; Long-Float
  3916.   #define symbol_type    0x40  # %01000000  ; Symbol
  3917.           # Bits für Symbole in VAR/FUN-Frames (im LISP-Stack):
  3918.           #define active_bit  3  # gesetzt: Bindung ist aktiv
  3919.           #define dynam_bit   4  # gesetzt: Bindung ist dynamisch
  3920.           #define svar_bit    5  # gesetzt: nächster Parameter ist supplied-p-Parameter für diesen
  3921.           #define oint_symbolflags_shift  oint_type_shift
  3922.           # Bits für Symbole im Selbstpointer:
  3923.           #define constant_bit_t  3  # zeigt an, ob das Symbol eine Konstante ist
  3924.           #define special_bit_t   4  # zeigt an, ob das Symbol SPECIAL-proklamiert ist
  3925.           #define keyword_bit_t   5  # zeigt an, ob das Symbol ein Keyword ist
  3926.   #define cons_type      0x80  # %10000000  ; Cons
  3927.  
  3928. # Typ ist GC-invariant, wenn
  3929. # Typinfobyte eines von 0x00,0x04,0x05,0x24,0x25,0x30,0x31,0x38 ist.
  3930.   #define immediate_type_p(type)  \
  3931.     ((type<0x39) && ((type==0) || !((bit(type>>1) & 0x11040004) == 0)))
  3932.  
  3933. #endif # SUN3_TYPECODES
  3934.  
  3935. #if !(immediate_type_p(ffloat_type) == defined(WIDE))
  3936.   #error "immediate_type_p() fehlerhaft implementiert!"
  3937. #endif
  3938.  
  3939. #if defined(SINGLEMAP_MEMORY) && (((system_type*1UL << oint_type_shift) & addressbus_mask) == 0)
  3940.   # Auch der STACK liegt in einem Singlemap-Bereich, Typinfo system_type.
  3941.   #define SINGLEMAP_MEMORY_STACK
  3942. #endif
  3943.  
  3944.  
  3945. #ifdef oint_symbolflags_shift
  3946.   #if defined(SINGLEMAP_MEMORY) && (oint_symbolflags_shift==oint_type_shift)
  3947.     # Da wir die symbol_tab nicht multimappen können, müssen wir auf extra Bits
  3948.     # im Typcode von Symbolen verzichten.
  3949.     #undef oint_symbolflags_shift
  3950.     #define NO_symbolflags
  3951.   #endif
  3952. #endif
  3953. #ifdef NO_symbolflags
  3954.   #define oint_symbolflags_shift  -1 # ungültiger Wert
  3955. #endif
  3956.  
  3957.  
  3958. # Fallunterscheidungen nach Typcodes:
  3959. # Einzuleiten durch switch (typecode(obj)), danach wie in einer
  3960. # switch-Anweisung beliebig viele case-Labels.
  3961. # Beispiel:  switch (typecode(arg)) { case_string: ...; break; ... }
  3962.   #define case_machine    case machine_type   # Maschinenpointer
  3963.   #ifdef IMMUTABLE_ARRAY
  3964.   #define case_sstring    case imm_sstring_type: case sstring_type    # Simple-String
  3965.   #define case_ostring    case imm_string_type: case string_type      # Other String
  3966.   #define case_string     case_sstring: case_ostring                  # String allgemein
  3967.   #define case_sbvector   case imm_sbvector_type: case sbvector_type  # Simple-Bit-Vector
  3968.   #define case_obvector   case imm_bvector_type: case bvector_type    # Other Bit/Byte-Vector
  3969.   #define case_bvector    case_sbvector: case_obvector                # Bit-Vector allgemein
  3970.   #define case_svector    case imm_svector_type: case svector_type    # Simple-(General-)Vector
  3971.   #define case_ovector    case imm_vector_type: case vector_type      # Other (General-)Vector
  3972.   #define case_vector     case_svector: case_ovector                  # (General-)Vector allgemein
  3973.   #define case_array1     case imm_array_type: case array_type        # sonstiger Array
  3974.   #define case_array      case_string: case_bvector: case_vector: case_array1 # Array allgemein
  3975.   #else
  3976.   #define case_sstring    case sstring_type   # Simple-String
  3977.   #define case_ostring    case string_type    # Other String
  3978.   #define case_string     case_sstring: case_ostring # String allgemein
  3979.   #define case_sbvector   case sbvector_type  # Simple-Bit-Vector
  3980.   #define case_obvector   case bvector_type   # Other Bit/Byte-Vector
  3981.   #define case_bvector    case_sbvector: case_obvector # Bit-Vector allgemein
  3982.   #define case_svector    case svector_type   # Simple-(General-)Vector
  3983.   #define case_ovector    case vector_type    # Other (General-)Vector
  3984.   #define case_vector     case_svector: case_ovector # (General-)Vector allgemein
  3985.   #define case_array1     case array_type     # sonstiger Array
  3986.   #define case_array      case_string: case_bvector: case_vector: case_array1 # Array allgemein
  3987.   #define imm_array_mask     0
  3988.   #define imm_sbvector_type  sbvector_type
  3989.   #define imm_sstring_type   sstring_type
  3990.   #define imm_svector_type   svector_type
  3991.   #define imm_array_type     array_type
  3992.   #define imm_bvector_type   bvector_type
  3993.   #define imm_string_type    string_type
  3994.   #define imm_vector_type    vector_type
  3995.   #endif
  3996.   #define case_closure    case closure_type   # Closure
  3997.   #ifdef structure_type
  3998.   #define case_structure  case structure_type # Structure
  3999.   #else
  4000.   #define structure_type  orecord_type        # Structures sind OtherRecords
  4001.   #endif
  4002.   #ifdef stream_type
  4003.   #define case_stream     case stream_type    # Stream
  4004.   #else
  4005.   #define stream_type     orecord_type        # Streams sind OtherRecords
  4006.   #endif
  4007.   #define case_orecord    case orecord_type   # Other Record
  4008.   #define case_instance   case instance_type  # CLOS-Instanz
  4009.   #if defined(case_structure) || defined(case_stream)
  4010.   #define case_record     case_closure: case_structure: case_stream: case_orecord: case_instance # Record allgemein
  4011.   #else
  4012.   #define case_record     case_closure: case_orecord: case_instance # Record allgemein
  4013.   #endif
  4014.   #define case_char       case char_type      # Character
  4015.   #define case_subr       case subr_type      # SUBR
  4016.   #define case_system     case system_type    # Frame-Pointer, Read-Label, System
  4017.   #define case_posfixnum  case fixnum_type    # Fixnum >=0
  4018.   #define case_negfixnum  case fixnum_type|bit(sign_bit_t) # Fixnum <0
  4019.   #define case_fixnum     case_posfixnum: case_negfixnum # Fixnum
  4020.   #define case_posbignum  case bignum_type    # Bignum >0
  4021.   #define case_negbignum  case bignum_type|bit(sign_bit_t) # Bignum <0
  4022.   #define case_bignum     case_posbignum: case_negbignum # Bignum
  4023.   #define case_integer    case_fixnum: case_bignum # Integer
  4024.   #define case_ratio      case ratio_type: case ratio_type|bit(sign_bit_t) # Ratio
  4025.   #define case_rational   case_integer: case_ratio # Rational
  4026.   #define case_sfloat     case sfloat_type: case sfloat_type|bit(sign_bit_t) # Short-Float
  4027.   #define case_ffloat     case ffloat_type: case ffloat_type|bit(sign_bit_t) # Single-Float
  4028.   #define case_dfloat     case dfloat_type: case dfloat_type|bit(sign_bit_t) # Double-Float
  4029.   #define case_lfloat     case lfloat_type: case lfloat_type|bit(sign_bit_t) # Long-Float
  4030.   #define case_float      case_sfloat: case_ffloat: case_dfloat: case_lfloat # Float
  4031.   #define case_real       case_rational: case_float # Real
  4032.   #define case_complex    case complex_type # Complex
  4033.   #define case_number     case_real: case_complex # Number
  4034.   #define case_symbol     case symbol_type # Symbol
  4035.   #if /* !defined(NO_symbolflags) && */ (oint_symbolflags_shift==oint_type_shift)
  4036.   #define case_symbolflagged  # Symbol mit Flags \
  4037.                           case symbol_type: \
  4038.                           case symbol_type|bit(active_bit): \
  4039.                           case symbol_type|bit(dynam_bit): \
  4040.                           case symbol_type|bit(dynam_bit)|bit(active_bit): \
  4041.                           case symbol_type|bit(svar_bit): \
  4042.                           case symbol_type|bit(svar_bit)|bit(active_bit): \
  4043.                           case symbol_type|bit(svar_bit)|bit(dynam_bit): \
  4044.                           case symbol_type|bit(svar_bit)|bit(dynam_bit)|bit(active_bit)
  4045.   #else
  4046.   #define case_symbolflagged  case_symbol # Symbol mit Flags
  4047.   #endif
  4048.   #ifdef IMMUTABLE_CONS
  4049.   #define case_cons       case imm_cons_type: case cons_type # Cons
  4050.   #else
  4051.   #define imm_cons_mask   0
  4052.   #define case_cons       case cons_type # Cons
  4053.   #define imm_cons_type   cons_type
  4054.   #endif
  4055.  
  4056.  
  4057. # ################## Speicheraufbau von LISP-Objekten ##################### #
  4058.  
  4059. # Objekte mit genau zwei Pointern:
  4060.  
  4061. # Cons
  4062. typedef struct { object cdr;   # CDR
  4063.                  object car; } # CAR
  4064.         cons_;
  4065. typedef cons_ *  Cons;
  4066.  
  4067. # liefert das immutable Pendant zu einem Cons
  4068. #define make_imm_cons(obj)  \
  4069.   objectplus(obj,type_zero_oint(imm_cons_type)-type_zero_oint(cons_type))
  4070.  
  4071. # Ratio
  4072. typedef struct { object rt_num;   # Zähler, Integer
  4073.                  object rt_den; } # Nenner, Integer >0
  4074.         ratio_;
  4075. typedef ratio_ *  Ratio;
  4076.  
  4077. # Complex
  4078. typedef struct { object c_real;   # Realteil, reelle Zahl
  4079.                  object c_imag; } # Imaginärteil, reelle Zahl
  4080.         complex_;
  4081. typedef complex_ *  Complex;
  4082.  
  4083. # Objekte variabler Länge:
  4084. # Die erste Komponente (die ersten vier Bytes) sind für die Garbage
  4085. # Collection reserviert. Das erste Byte davon muß die Typinfo des
  4086. # Objektes enthalten (bei Symbolen zusätzlich noch max. 3 Flag-Bits); bis
  4087. # auf das GC-Bit 7 wird es von der GC unverändert gelassen. Die drei weiteren
  4088. # Bytes der ersten Komponente werden von der GC als Zwischenpointer genutzt;
  4089. # nach Beendigung der GC steht dort ein Selbstpointer.
  4090.  
  4091. # Typ der Header-Flags:
  4092.   #if (oint_type_len<=8) && !defined(ARM) && !defined(DECALPHA)
  4093.     # Zugriff auf ein einzelnes Byte möglich
  4094.     #define hfintsize  intBsize
  4095.     typedef uintB  hfint;
  4096.   #else
  4097.     # Zugriff auf ein ganzes Wort
  4098.     #define hfintsize  intLsize
  4099.     typedef uintL  hfint;
  4100.   #endif
  4101.  
  4102. # Objekt variabler Länge
  4103. #define VAROBJECT_HEADER  \
  4104.                union { object _GCself;  # Selbstpointer für GC            \
  4105.                        hfint flags[sizeof(object)/sizeof(hfint)]; # Flags \
  4106.                      } header;
  4107. typedef struct { VAROBJECT_HEADER }
  4108.         varobject_;
  4109. typedef varobject_ *  Varobject;
  4110. #define GCself  header._GCself
  4111. # Der Typcode ist im Byte ((Varobject)p)->header_flags enthalten.
  4112.   #if !(oint_type_len>=hfintsize ? oint_type_shift%hfintsize==0 : floor(oint_type_shift,hfintsize)==floor(oint_type_shift+oint_type_len-1,hfintsize))
  4113.     #error "Bogus header_flags -- header_flags neu definieren!"
  4114.   #endif
  4115.   #if BIG_ENDIAN_P
  4116.     #define header_flags  header.flags[sizeof(object)/sizeof(hfint)-1-floor(oint_type_shift,hfintsize)]
  4117.   #else
  4118.     #define header_flags  header.flags[floor(oint_type_shift,hfintsize)]
  4119.   #endif
  4120.   # Es gilt  mtypecode(((Varobject)p)->GCself) =
  4121.   # (((Varobject)p)->header_flags >> (oint_type_shift%hfintsize)) & tint_type_mask
  4122.   # Bits für Symbole im Selbstpointer (siehe oben):
  4123.   # define constant_bit_t  ...  # zeigt an, ob das Symbol eine Konstante ist
  4124.   # define special_bit_t   ...  # zeigt an, ob das Symbol SPECIAL-proklamiert ist
  4125.   # define keyword_bit_t   ...  # zeigt an, ob das Symbol ein Keyword ist
  4126.   #define constant_bit_hf  (constant_bit_t+(oint_type_shift%hfintsize))
  4127.   #define special_bit_hf  (special_bit_t+(oint_type_shift%hfintsize))
  4128.   #define keyword_bit_hf  (keyword_bit_t+(oint_type_shift%hfintsize))
  4129.  
  4130. # Symbol
  4131. typedef struct { VAROBJECT_HEADER
  4132.                  object symvalue;    # Wertzelle
  4133.                  object symfunction; # Funktiondefinitionszelle
  4134.                  object proplist;    # Property-Liste
  4135.                  object pname;       # Printname
  4136.                  object homepackage; # Home-Package oder NIL
  4137.                }
  4138.         symbol_;
  4139. typedef symbol_ *  Symbol;
  4140. #define symbol_objects_offset  offsetof(symbol_,symvalue)
  4141.  
  4142. # Jedes Keyword ist eine Konstante.
  4143. # Bei Konstanten ist das Special-Bit bedeutungslos (denn Konstanten
  4144. # können bei uns weder lexikalisch noch dynamisch gebunden werden).
  4145.  
  4146. # Test, ob ein Symbol eine Konstante ist:
  4147.   #define constantp(sym)  \
  4148.     (((sym)->header_flags) & bit(constant_bit_hf))
  4149.  
  4150. # Test, ob ein Symbol eine SPECIAL-proklamierte Variable ist:
  4151.   #define special_var_p(sym)  \
  4152.     (((sym)->header_flags) & bit(special_bit_hf))
  4153.  
  4154. # Test, ob ein Symbol ein Keyword ist:
  4155.   #define keywordp(sym)  \
  4156.     ((TheSymbol(sym)->header_flags) & bit(keyword_bit_hf))
  4157.  
  4158. # Constant-Flag eines Symbols setzen:
  4159.   #define set_const_flag(sym)  \
  4160.     (((sym)->header_flags) |= bit(constant_bit_hf))
  4161.  
  4162. # Constant-Flag eines Symbols löschen:
  4163. # (Symbol darf kein Keyword sein, vgl. spvw.d:case_symbolwithflags)
  4164.   #define clear_const_flag(sym)  \
  4165.     (((sym)->header_flags) &= ~bit(constant_bit_hf))
  4166.  
  4167. # Special-Flag eines Symbols setzen:
  4168.   #define set_special_flag(sym)  \
  4169.     (((sym)->header_flags) |= bit(special_bit_hf))
  4170.  
  4171. # Special-Flag eines Symbols löschen:
  4172.   #define clear_special_flag(sym)  \
  4173.     (((sym)->header_flags) &= ~bit(special_bit_hf))
  4174.  
  4175. # Symbol als Konstante mit gegebenem Wert val definieren.
  4176. # val darf keine GC auslösen!
  4177.   #define define_constant(sym,val)                              \
  4178.     {var reg1 Symbol sym_from_define_constant = TheSymbol(sym); \
  4179.      set_const_flag(sym_from_define_constant);                  \
  4180.      sym_from_define_constant->symvalue = (val);                \
  4181.     }
  4182.  
  4183. # Symbol als Variable mit gegebenem Initialisierungswert val definieren.
  4184. # val darf keine GC auslösen!
  4185.   #define define_variable(sym,val)                              \
  4186.     {var reg1 Symbol sym_from_define_variable = TheSymbol(sym); \
  4187.      set_special_flag(sym_from_define_variable);                \
  4188.      sym_from_define_variable->symvalue = (val);                \
  4189.     }
  4190.  
  4191. # Flagbits in einem Symbol entfernen:
  4192.   #if defined(NO_symbolflags)
  4193.     #define symbol_without_flags(symbol)  symbol
  4194.   #elif (oint_symbolflags_shift==oint_type_shift)
  4195.     #define symbol_without_flags(symbol)  \
  4196.       as_object(as_oint(symbol) & (type_zero_oint(symbol_type) | oint_addr_mask))
  4197.   #else
  4198.     #define symbol_without_flags(symbol)  \
  4199.       as_object(as_oint(symbol) & ~((wbit(active_bit)|wbit(dynam_bit)|wbit(svar_bit))<<oint_symbolflags_shift))
  4200.   #endif
  4201.  
  4202. # Characters
  4203. # Implementiert sind 4 Bits und 16 Fonts.
  4204. # Aufteilung in code, bits, font:
  4205. #   Fontnummer  in den Bits 15..12,
  4206. #   Bits        in den Bits 11..8,
  4207. #   Ascii-Code  in den Bits 7..0.
  4208. # Bits: 8=Control, 9=Meta, 10=Super, 11=Hyper.
  4209. # Fonts: 0=Default, restliche ungenutzt und non-graphic.
  4210.  
  4211. # Integer, der die Daten eines Character ganz faßt:
  4212.   #define char_int_len 16
  4213.   #define char_int_limit  (1UL<<char_int_len)
  4214.   #ifdef ANSI
  4215.     typedef unsigned_int_with_n_bits(char_int_len)  cint;
  4216.   #else
  4217.     typedef uint/**/char_int_len  cint;
  4218.   #endif
  4219. # Aus einem Integer-Code ein Character machen:
  4220.   #define int_char(int_from_int_char)  \
  4221.     type_data_object(char_type,(aint)(cint)(int_from_int_char))
  4222. # Aus einem Character seinen Integer-Code herausziehen:
  4223.   #if !((oint_data_shift==0) && (char_int_len<=oint_data_len) && (exact_uint_size_p(char_int_len)))
  4224.     #define char_int(char_from_char_int)  \
  4225.       ((cint)(untype(char_from_char_int)))
  4226.   #else
  4227.     # Falls oint_data_shift=0, braucht untype nicht zu shiften;
  4228.     # falls auch char_int_len<=oint_data_len und ein cint genau char_int_len
  4229.     # Bits hat, braucht untype nicht zu ANDen.
  4230.     #define char_int(char_from_char_int)  \
  4231.       ((cint)as_oint(char_from_char_int))
  4232.   #endif
  4233. # Characters können somit mit EQ auf Gleichheit verglichen werden,
  4234. # das ist ein oint-Vergleich bzw. (unter Characters) sogar ein
  4235. # cint-Vergleich ihrer Integer-Codes.
  4236.  
  4237. # Aufteilung eines Integer-Codes in Bits:
  4238.   #define char_code_shift_c   0      # (sollte =0 sein, siehe CLTL S. 242)
  4239.   #define char_code_len_c     8      # Ascii-Zeichensatz mit 8 Bits, paßt in uintB
  4240.   #define char_code_limit     (1UL<<char_code_len_c)
  4241.   #define char_code_mask_c    ((char_code_limit-1)<<char_code_shift_c)
  4242.   #define char_bits_shift_c   8
  4243.   #define char_bits_len_c     4
  4244.   #define char_bits_limit     (1UL<<char_bits_len_c)
  4245.   #define char_bits_mask_c    ((char_bits_limit-1)<<char_bits_shift_c)
  4246.   #define char_font_shift_c  12
  4247.   #define char_font_len_c     4
  4248.   #define char_font_limit     (1UL<<char_font_len_c)
  4249.   #define char_font_mask_c    ((char_font_limit-1)<<char_font_shift_c)
  4250. # Aus dem Code eines String-Char ein Character machen:
  4251.   #if !(char_code_shift_c==0)
  4252.     #define code_char(code_from_code_char)  \
  4253.       int_char((cint)(code_from_code_char)<<char_code_shift_c)
  4254.   #else
  4255.     # falls nicht geschoben werden muß:
  4256.     #define code_char(code_from_code_char)  \
  4257.       int_char((cint)(code_from_code_char))
  4258.   #endif
  4259. # Aus einem Character den Code extrahieren:
  4260.   #if !((char_code_shift_c==0)&&(char_code_len_c==8))
  4261.     #define char_code(char_from_char_code)  \
  4262.       ((uintB)((char_int(char_from_char_code)&char_code_mask_c)>>char_code_shift_c))
  4263.   #else
  4264.     # falls der char-code genau das untere Byte belegt:
  4265.     #define char_code(char_from_char_code)  ((uintB)(char_int(char_from_char_code)))
  4266.   #endif
  4267. # Bits im cint:
  4268.   #define char_control_bit_c  8
  4269.   #define char_meta_bit_c     9
  4270.   #define char_super_bit_c   10
  4271.   #define char_hyper_bit_c   11
  4272. # Bitmasken im cint:
  4273.   #define char_control_c  bit(char_control_bit_c)
  4274.   #define char_meta_c     bit(char_meta_bit_c)
  4275.   #define char_super_c    bit(char_super_bit_c)
  4276.   #define char_hyper_c    bit(char_hyper_bit_c)
  4277. # wird verwendet von STREAM, DEBUG, EVAL
  4278.  
  4279. # Fixnums
  4280.  
  4281. # fixnum(x) ist ein Fixnum mit Wert x>=0.
  4282. # x eine Expression mit 0 <= x < 2^oint_data_len.
  4283. # (Sollte eigentlich posfixnum(x) heißen.)
  4284.   #define fixnum(x)  type_data_object(fixnum_type,x)
  4285.  
  4286. # Fixnum_0 ist die Zahl 0, Fixnum_1 ist die Zahl 1,
  4287. # Fixnum_minus1 ist die Zahl -1
  4288.   #define Fixnum_0  fixnum(0)
  4289.   #define Fixnum_1  fixnum(1)
  4290.   #define Fixnum_minus1  type_data_object( fixnum_type | bit(sign_bit_t), bitm(oint_data_len)-1 )
  4291.  
  4292. # Wert eines nichtnegativen Fixnum:
  4293. # posfixnum_to_L(obj)
  4294. # Ergebnis ist >= 0, < 2^oint_data_len.
  4295.   #if !(defined(SPARC) && (oint_data_len+oint_data_shift<32))
  4296.     #define posfixnum_to_L(obj)  \
  4297.       ((uintL)((as_oint(obj)&(wbitm(oint_data_len+oint_data_shift)-1))>>oint_data_shift))
  4298.   #else
  4299.     # Auf einem SPARC-Prozessor sind lange Konstanten langsamer als Shifts:
  4300.     #define posfixnum_to_L(obj)  \
  4301.       ((uintL)((as_oint(obj) << (32-oint_data_len-oint_data_shift)) >> (32-oint_data_len)))
  4302.   #endif
  4303.  
  4304. # Wert eines negativen Fixnum:
  4305. # negfixnum_to_L(obj)
  4306. # Ergebnis ist >= - 2^oint_data_len, < 0.
  4307.   #define negfixnum_to_L(obj)  (posfixnum_to_L(obj) | (-bitm(oint_data_len)))
  4308.  
  4309. # Betrag eines negativen Fixnum:
  4310. # negfixnum_abs_L(obj)
  4311. # Ergebnis ist > 0, <= 2^oint_data_len.
  4312. # Vorsicht: Wraparound bei oint_data_len=intLsize möglich!
  4313.   #define negfixnum_abs_L(obj)  \
  4314.     ((uintL)((as_oint(fixnum_inc(Fixnum_minus1,1))-as_oint(obj))>>oint_data_shift))
  4315.  
  4316. # Wert eines Fixnum, obj sollte eine Variable sein:
  4317. # fixnum_to_L(obj)
  4318. # Ergebnis ist >= - 2^oint_data_len, < 2^oint_data_len und vom Typ sintL.
  4319. # Die Verwendung dieses Macros ist nur bei oint_data_len+1 <= intLsize sinnvoll!
  4320.   #if (oint_data_len>=intLsize)
  4321.     # Kein Platz mehr fürs Vorzeichenbit, daher fixnum_to_L = posfixnum_to_L = negfixnum_to_L !
  4322.     #define fixnum_to_L(obj)  (sintL)posfixnum_to_L(obj)
  4323.   #elif (sign_bit_o == oint_data_len+oint_data_shift)
  4324.     #define fixnum_to_L(obj)  \
  4325.       (((sintL)as_oint(obj) << (intLsize-1-sign_bit_o)) >> (intLsize-1-sign_bit_o+oint_data_shift))
  4326.   #else
  4327.     #if !defined(SPARC)
  4328.       #define fixnum_to_L(obj)  \
  4329.         (sintL)( ((((sintL)as_oint(obj) >> sign_bit_o) << (intLsize-1)) >> (intLsize-1-oint_data_len)) \
  4330.                 |((uintL)((as_oint(obj) & (wbitm(oint_data_len+oint_data_shift)-1)) >> oint_data_shift)) \
  4331.                )
  4332.     #else
  4333.       # Auf einem SPARC-Prozessor sind lange Konstanten langsamer als Shifts:
  4334.       #define fixnum_to_L(obj)  \
  4335.         (sintL)( ((((sintL)as_oint(obj) >> sign_bit_o) << (intLsize-1)) >> (intLsize-1-oint_data_len)) \
  4336.                 |(((uintL)as_oint(obj) << (intLsize-oint_data_len-oint_data_shift)) >> (intLsize-oint_data_len)) \
  4337.                )
  4338.     #endif
  4339.   #endif
  4340.  
  4341. #ifdef intQsize
  4342. # Wert eines Fixnum, obj sollte eine Variable sein:
  4343. # fixnum_to_Q(obj)
  4344. # Ergebnis ist >= - 2^oint_data_len, < 2^oint_data_len.
  4345.   #if (sign_bit_o == oint_data_len+oint_data_shift)
  4346.     #define fixnum_to_Q(obj)  \
  4347.       (((sintQ)as_oint(obj) << (intQsize-1-sign_bit_o)) >> (intQsize-1-sign_bit_o+oint_data_shift))
  4348.   #else
  4349.     #define fixnum_to_Q(obj)  \
  4350.       ( ((((sintQ)as_oint(obj) >> sign_bit_o) << (intQsize-1)) >> (intQsize-1-oint_data_len)) \
  4351.        |((uintQ)((as_oint(obj) & (wbitm(oint_data_len+oint_data_shift)-1)) >> oint_data_shift)) \
  4352.       )
  4353.   #endif
  4354. #endif
  4355.  
  4356. # Zu einem nichtnegativen Fixnum eine Konstante addieren, vorausgesetzt,
  4357. # das Ergebnis ist wieder ein nichtnegatives Fixnum:
  4358. # fixnum_inc(obj,delta)
  4359. # > obj: ein Fixnum
  4360. # > delta: eine Konstante
  4361. # < ergebnis: erhöhtes Fixnum
  4362.   #define fixnum_inc(obj,delta)  \
  4363.     objectplus(obj, (soint)(delta) << oint_data_shift)
  4364.  
  4365. # posfixnum(x) ist ein Fixnum mit Wert x>=0.
  4366.   #define posfixnum(x)  fixnum_inc(Fixnum_0,x)
  4367.  
  4368. # negfixnum(x) ist ein Fixnum mit Wert x<0.
  4369. # (Vorsicht, wenn x unsigned ist!)
  4370.   #define negfixnum(x)  fixnum_inc(fixnum_inc(Fixnum_minus1,1),x)
  4371.  
  4372. # sfixnum(x) ist ein Fixnum mit Wert x,
  4373. # x eine Constant-Expression mit -2^oint_data_len <= x < 2^oint_data_len.
  4374.   #define sfixnum(x) ((x)>=0 ? posfixnum(x) : negfixnum(x))
  4375.  
  4376. # Aus einem Character ein Fixnum >=0 machen (wie bei char-int):
  4377.   #ifdef WIDE_STRUCT
  4378.     #define char_to_fixnum(obj)  \
  4379.       type_data_object(fixnum_type,untype(obj))
  4380.   #else
  4381.     #define char_to_fixnum(obj)  \
  4382.       objectplus(obj,type_zero_oint(fixnum_type)-type_zero_oint(char_type))
  4383.   #endif
  4384.  
  4385. # Aus einem passenden Fixnum >=0 ein Character machen (wie bei int-char):
  4386.   #ifdef WIDE_STRUCT
  4387.     #define fixnum_to_char(obj)  \
  4388.       type_data_object(char_type,untype(obj))
  4389.   #else
  4390.     #define fixnum_to_char(obj)  \
  4391.       objectplus(obj,type_zero_oint(char_type)-type_zero_oint(fixnum_type))
  4392.   #endif
  4393.  
  4394. # Bignums
  4395. typedef struct { VAROBJECT_HEADER  # Selbstpointer für GC
  4396.                  uintC length;     # Länge in Digits
  4397.                  uintD data[unspecified]; # Zahl in Zweierkomplementdarstellung
  4398.                }
  4399.         bignum_;
  4400. typedef bignum_ *  Bignum;
  4401.  
  4402. # Single-Floats
  4403. typedef uint32 ffloat; # 32-Bit-Float im IEEE-Format
  4404. typedef union { ffloat explicit_;     # Wert, explizit
  4405.                 #ifdef FAST_FLOAT
  4406.                 float machine_float; # Wert, als C-'float'
  4407.                 #endif
  4408.               }
  4409.         ffloatjanus;
  4410. #ifndef WIDE
  4411. typedef struct { VAROBJECT_HEADER            # Selbstpointer für GC
  4412.                  ffloatjanus representation; # Wert
  4413.                }
  4414.         ffloat_;
  4415. typedef ffloat_ *  Ffloat;
  4416. #define ffloat_value(obj)  (TheFfloat(obj)->float_value)
  4417. #else
  4418. # Der Float-Wert wird im Pointer selbst untergebracht, wie bei Short-Floats.
  4419. #define ffloat_value(obj)  ((ffloat)untype(obj))
  4420. #endif
  4421.  
  4422. # Double-Floats
  4423. typedef # 64-Bit-Float im IEEE-Format:
  4424.         #ifdef intQsize
  4425.           # Sign/Exponent/Mantisse
  4426.           uint64
  4427.         #else
  4428.           # Sign/Exponent/MantisseHigh und MantisseLow
  4429.           #if BIG_ENDIAN_P
  4430.             struct {uint32 semhi,mlo;}
  4431.           #else
  4432.             struct {uint32 mlo,semhi;}
  4433.           #endif
  4434.         #endif
  4435.         dfloat;
  4436. typedef union { dfloat explicit_;       # Wert, explizit
  4437.                 #ifdef FAST_DOUBLE
  4438.                 double machine_double; # Wert, als C-'double'
  4439.                 #endif
  4440.               }
  4441.         dfloatjanus;
  4442. typedef struct { VAROBJECT_HEADER            # Selbstpointer für GC
  4443.                  dfloatjanus representation; # Wert
  4444.                }
  4445.         dfloat_;
  4446. typedef dfloat_ *  Dfloat;
  4447.  
  4448. # Single- und Double-Floats
  4449.   #define float_value  representation.explicit_
  4450.  
  4451. # Long-Floats
  4452. typedef struct { VAROBJECT_HEADER   # Selbstpointer für GC
  4453.                  uintC  len;        # Länge der Mantisse in Digits
  4454.                  uint32 expo;       # Exponent
  4455.                  uintD  data[unspecified]; # Mantisse
  4456.                }
  4457.         lfloat_;
  4458. typedef lfloat_ *  Lfloat;
  4459.  
  4460. # Simple-Array (umfaßt einfache eindimensionale Arrays:
  4461. # Simple-Bit-Vector, Simple-String, Simple-Vector)
  4462. typedef struct { VAROBJECT_HEADER # Selbstpointer für GC
  4463.                  uintL  length;   # Länge in Elementen
  4464.                }
  4465.         sarray_;
  4466. typedef sarray_ *  Sarray;
  4467.  
  4468. # Simple-Bit-Vektor
  4469. typedef struct { VAROBJECT_HEADER # Selbstpointer für GC
  4470.                  uintL  length;   # Länge in Bits
  4471.                  uint8  data[unspecified]; # Bits, in Bytes unterteilt
  4472.                }
  4473.         sbvector_;
  4474. typedef sbvector_ *  Sbvector;
  4475.  
  4476. # Simple-String
  4477. typedef struct { VAROBJECT_HEADER # Selbstpointer für GC
  4478.                  uintL  length;   # Länge in Bytes
  4479.                  uintB  data[unspecified]; # Characters
  4480.                }
  4481.         sstring_;
  4482. typedef sstring_ *  Sstring;
  4483.  
  4484. # Simple-Vector
  4485. typedef struct { VAROBJECT_HEADER # Selbstpointer für GC
  4486.                  uintL  length;   # Länge in Objekten
  4487.                  object data[unspecified]; # Elemente
  4488.                }
  4489.         svector_;
  4490. typedef svector_ *  Svector;
  4491.  
  4492. # nicht-simpler Array
  4493. typedef struct { VAROBJECT_HEADER  # Selbstpointer für GC
  4494.                  uintB flags;      # Flags
  4495.                                    # dann ein Byte unbenutzt
  4496.                  uintC rank;       # Rang n
  4497.                  object data;      # Datenvektor
  4498.                  uintL totalsize;  # Totalsize = Produkt der n Dimensionen
  4499.                  uintL dims[unspecified]; # evtl. displaced-offset,
  4500.                                    # n Dimensionen,
  4501.                                    # evtl. Fill-Pointer
  4502.                }
  4503.         array_;
  4504. typedef array_ *  Array;
  4505. #define array_data_offset  offsetof(array_,data)
  4506. # Bits in den Flags:
  4507.   #define arrayflags_adjustable_bit  7 # gesetzt, wenn Array adjustable
  4508.   #define arrayflags_fillp_bit       6 # gesetzt, wenn Fill-Pointer vorhanden (nur bei n=1 möglich)
  4509.   #define arrayflags_displaced_bit   5 # gesetzt, wenn Array displaced
  4510.   #define arrayflags_dispoffset_bit  4 # gesetzt, wenn Platz für den
  4511.                                        # Displaced-Offset vorhanden ist
  4512.                                        # (<==> Array adjustable oder displaced)
  4513.   #define arrayflags_notbytep_bit    3 # gelöscht bei Byte-Vektoren
  4514.   #define arrayflags_atype_mask  0x07  # Maske für Elementtyp
  4515. # Elementtypen von Arrays in Bits 2..0 der flags:
  4516.   # Die ersten sind so gewählt, daß 2^Atype_nBit = n ist.
  4517.   #define Atype_Bit          0         # arrayflags_notbytep_bit gesetzt!
  4518.   #define Atype_2Bit         1
  4519.   #define Atype_4Bit         2
  4520.   #define Atype_8Bit         3
  4521.   #define Atype_16Bit        4
  4522.   #define Atype_32Bit        5
  4523.   #define Atype_T            6         # arrayflags_notbytep_bit gesetzt!
  4524.   #define Atype_String_Char  7         # arrayflags_notbytep_bit gesetzt!
  4525.  
  4526. # liefert das immutable Pendant zu einem Array
  4527. #define make_imm_array(obj)  \
  4528.   as_object(as_oint(obj) | type_zero_oint(imm_array_mask))
  4529.  
  4530. # Records
  4531. # Simple-Records können bis zu 65535 Elemente haben,
  4532. # Extended-Records haben dagegen Platz für extra (nicht-Lisp) Elemente.
  4533. typedef struct { VAROBJECT_HEADER # Selbstpointer für GC
  4534.                  uintB recflags;  # bei OtherRecord: Flags
  4535.                  sintB rectype;   # bei OtherRecord: Untertyp
  4536.                  uintW recfiller; # Länge u.a.
  4537.                  object recdata[unspecified]; # Elemente
  4538.                }
  4539.         record_;
  4540. typedef record_ *  Record;
  4541. #define SRECORD_HEADER  \
  4542.                  VAROBJECT_HEADER # Selbstpointer für GC          \
  4543.                  uintB recflags;  # bei OtherRecord: Flags        \
  4544.                  sintB rectype;   # bei OtherRecord: Untertyp, <0 \
  4545.                  uintW reclength; # Länge in Objekten
  4546. typedef struct { SRECORD_HEADER
  4547.                  object recdata[unspecified]; # Elemente, reclength Stück
  4548.                }
  4549.         srecord_;
  4550. typedef srecord_ *  Srecord;
  4551. #define XRECORD_HEADER  \
  4552.                  VAROBJECT_HEADER  # Selbstpointer für GC           \
  4553.                  uintB recflags;   # bei OtherRecord: Flags         \
  4554.                  sintB rectype;    # bei OtherRecord: Untertyp, >=0 \
  4555.                  uintB reclength;  # Länge in Objekten              \
  4556.                  uintB recxlength; # Länge der Extra-Elemente
  4557. typedef struct { XRECORD_HEADER
  4558.                  object recdata[unspecified];  # Elemente, reclength Stück
  4559.                # uintB  recxdata[unspecified]; # Extra-Elemente, recxlength Stück
  4560.                }
  4561.         xrecord_;
  4562. typedef xrecord_ *  Xrecord;
  4563. # Elementtypen von OtherRecords:
  4564.   #define Rectype_Closure      -3
  4565.   #define Rectype_Structure    -2
  4566.   #define Rectype_Instance     -1
  4567.   #define Rectype_Hashtable     0
  4568.   #define Rectype_Package       1
  4569.   #define Rectype_Readtable     2
  4570.   #define Rectype_Pathname      3
  4571.   #define Rectype_Logpathname   4 # nur gebraucht, falls defined(LOGICAL_PATHNAMES)
  4572.   #define Rectype_Random_State  5
  4573.   #define Rectype_Stream        6 # nur gebraucht, falls !defined(case_stream)
  4574.   #define Rectype_Byte          7
  4575.   #define Rectype_Fsubr         8
  4576.   #define Rectype_Loadtimeeval  9
  4577.   #define Rectype_Symbolmacro  10
  4578.   #define Rectype_Fpointer     11 # nur gebraucht, falls defined(FOREIGN)
  4579.   #define Rectype_Faddress     12 # nur gebraucht, falls defined(DYNAMIC_FFI)
  4580.   #define Rectype_Fvariable    13 # nur gebraucht, falls defined(DYNAMIC_FFI)
  4581.   #define Rectype_Ffunction    14 # nur gebraucht, falls defined(DYNAMIC_FFI)
  4582.   #define Rectype_Finalizer    15
  4583.   #define Rectype_Socket_Server 16 # for SOCKET_STREAMS
  4584.   #ifdef YET_ANOTHER_RECORD
  4585.   #define Rectype_Yetanother   17
  4586.   #endif
  4587.  
  4588. # Packages
  4589. typedef struct { XRECORD_HEADER
  4590.                  object pack_external_symbols;
  4591.                  object pack_internal_symbols;
  4592.                  object pack_shadowing_symbols;
  4593.                  object pack_use_list;
  4594.                  object pack_used_by_list;
  4595.                  object pack_name;
  4596.                  object pack_nicknames;
  4597.                }
  4598.         *  Package;
  4599. #define package_length  ((sizeof(*(Package)0)-offsetofa(record_,recdata))/sizeof(object))
  4600. # Mit gelöschten Packages darf man nichts anstellen.
  4601.   #define mark_pack_deleted(obj)  ThePackage(obj)->recflags |= bit(7)
  4602.   #define pack_deletedp(obj)  (!((ThePackage(obj)->recflags & bit(7)) == 0))
  4603.  
  4604. # Hash-Tables
  4605. typedef struct { XRECORD_HEADER
  4606.                  #ifdef GENERATIONAL_GC
  4607.                  object ht_lastrehash;
  4608.                  #endif
  4609.                  object ht_size;
  4610.                  object ht_maxcount;
  4611.                  object ht_itable;
  4612.                  object ht_ntable;
  4613.                  object ht_kvtable;
  4614.                  object ht_freelist;
  4615.                  object ht_count;
  4616.                  object ht_rehash_size;
  4617.                  object ht_mincount_threshold;
  4618.                  object ht_mincount;
  4619.                }
  4620.         *  Hashtable;
  4621. #define hashtable_length  ((sizeof(*(Hashtable)0)-offsetofa(record_,recdata))/sizeof(object))
  4622. # Markiere eine Hash-Table als neu zu reorganisieren:
  4623. # mark_ht_invalid(TheHashtable(ht));
  4624.   #ifdef GENERATIONAL_GC
  4625.     #define mark_ht_invalid(ptr)  (ptr)->ht_lastrehash = unbound
  4626.     #define mark_ht_valid(ptr)  (ptr)->ht_lastrehash = O(gc_count)
  4627.     #define ht_validp(ptr)  eq((ptr)->ht_lastrehash,O(gc_count))
  4628.   #else
  4629.     #define mark_ht_invalid(ptr)  (ptr)->recflags |= bit(7)
  4630.     #define mark_ht_valid(ptr)  (ptr)->recflags &= ~bit(7)
  4631.     #define ht_validp(ptr)  (((ptr)->recflags & bit(7)) == 0)
  4632.   #endif
  4633.  
  4634. # Readtables
  4635. typedef struct { XRECORD_HEADER
  4636.                  object readtable_syntax_table;
  4637.                  object readtable_macro_table;
  4638.                  object readtable_case;
  4639.                }
  4640.         *  Readtable;
  4641. #define readtable_length  ((sizeof(*(Readtable)0)-offsetofa(record_,recdata))/sizeof(object))
  4642.  
  4643. # Pathnames
  4644. typedef struct { XRECORD_HEADER
  4645.                  #if HAS_HOST
  4646.                    object pathname_host;
  4647.                  #endif
  4648.                  #if HAS_DEVICE
  4649.                    object pathname_device;
  4650.                  #endif
  4651.                  #if 1
  4652.                    object pathname_directory;
  4653.                    object pathname_name;
  4654.                    object pathname_type;
  4655.                  #endif
  4656.                  #if HAS_VERSION
  4657.                    object pathname_version;
  4658.                  #endif
  4659.                }
  4660.         *  Pathname;
  4661. #define pathname_length  ((sizeof(*(Pathname)0)-offsetofa(record_,recdata))/sizeof(object))
  4662.  
  4663. #ifdef LOGICAL_PATHNAMES
  4664. # Logical Pathnames
  4665. typedef struct { XRECORD_HEADER
  4666.                  object pathname_host;
  4667.                  object pathname_directory;
  4668.                  object pathname_name;
  4669.                  object pathname_type;
  4670.                  object pathname_version;
  4671.                }
  4672.         *  Logpathname;
  4673. #define logpathname_length  ((sizeof(*(Logpathname)0)-offsetofa(record_,recdata))/sizeof(object))
  4674. #endif
  4675.  
  4676. # Random-States
  4677. typedef struct { XRECORD_HEADER
  4678.                  object random_state_seed;
  4679.                }
  4680.         *  Random_state;
  4681. #define random_state_length  ((sizeof(*(Random_state)0)-offsetofa(record_,recdata))/sizeof(object))
  4682.  
  4683. # Bytes
  4684. typedef struct { XRECORD_HEADER
  4685.                  object byte_size;
  4686.                  object byte_position;
  4687.                }
  4688.         *  Byte;
  4689. #define byte_length  ((sizeof(*(Byte)0)-offsetofa(record_,recdata))/sizeof(object))
  4690.  
  4691. # Fsubrs
  4692. typedef struct { XRECORD_HEADER
  4693.                  object name;
  4694.                  object argtype;
  4695.                  object function;
  4696.                }
  4697.         *  Fsubr;
  4698. #define fsubr_length  ((sizeof(*(Fsubr)0)-offsetofa(record_,recdata))/sizeof(object))
  4699.  
  4700. # Load-time-evals
  4701. typedef struct { XRECORD_HEADER
  4702.                  object loadtimeeval_form;
  4703.                }
  4704.         *  Loadtimeeval;
  4705. #define loadtimeeval_length  ((sizeof(*(Loadtimeeval)0)-offsetofa(record_,recdata))/sizeof(object))
  4706.  
  4707. # Symbol-macros
  4708. typedef struct { XRECORD_HEADER
  4709.                  object symbolmacro_expansion;
  4710.                }
  4711.         *  Symbolmacro;
  4712. #define symbolmacro_length  ((sizeof(*(Symbolmacro)0)-offsetofa(record_,recdata))/sizeof(object))
  4713.  
  4714. #ifdef FOREIGN
  4715. # Foreign-Pointer-Verpackung
  4716. typedef struct { XRECORD_HEADER
  4717.                  void* fp_pointer;
  4718.                }
  4719.         *  Fpointer;
  4720. #define fpointer_length  0
  4721. #define fpointer_xlength  (sizeof(*(Fpointer)0)-offsetofa(record_,recdata)-fpointer_length*sizeof(object))
  4722. #define mark_fp_invalid(ptr)  (ptr)->recflags |= bit(7)
  4723. #define mark_fp_valid(ptr)  (ptr)->recflags &= ~bit(7)
  4724. #define fp_validp(ptr)  (((ptr)->recflags & bit(7)) == 0)
  4725. #else
  4726. #define mark_fp_invalid(ptr)
  4727. #endif
  4728.  
  4729. #ifdef DYNAMIC_FFI
  4730.  
  4731. # Foreign-Adressen
  4732. typedef struct { XRECORD_HEADER
  4733.                  object fa_base;
  4734.                  uintP fa_offset;
  4735.                }
  4736.         * Faddress;
  4737. #define faddress_length  1
  4738. #define faddress_xlength  (sizeof(*(Faddress)0)-offsetofa(record_,recdata)-faddress_length*sizeof(object))
  4739.  
  4740. # Foreign-Variables
  4741. typedef struct { XRECORD_HEADER
  4742.                  object fv_name;
  4743.                  object fv_address;
  4744.                  object fv_size;
  4745.                  object fv_type;
  4746.                }
  4747.         * Fvariable;
  4748. #define fvariable_length  ((sizeof(*(Fvariable)0)-offsetofa(record_,recdata))/sizeof(object))
  4749.  
  4750. # Foreign-Functions
  4751. typedef struct { XRECORD_HEADER
  4752.                  object ff_name;
  4753.                  object ff_address;
  4754.                  object ff_resulttype;
  4755.                  object ff_argtypes;
  4756.                  object ff_flags;
  4757.                }
  4758.         * Ffunction;
  4759. #define ffunction_length  ((sizeof(*(Ffunction)0)-offsetofa(record_,recdata))/sizeof(object))
  4760.  
  4761. #endif
  4762.  
  4763. # Finalisierer
  4764. typedef struct { XRECORD_HEADER
  4765.                  object fin_alive;    # nur solange dieses Objekt lebt
  4766.                  object fin_trigger;  # der Tod dieses Objekts wird abgewartet
  4767.                  object fin_function; # dann wird diese Funktion aufgerufen
  4768.                  object fin_cdr;
  4769.                }
  4770.         * Finalizer;
  4771. #define finalizer_length  ((sizeof(*(Finalizer)0)-offsetofa(record_,recdata))/sizeof(object))
  4772.  
  4773. #ifdef SOCKET_STREAMS
  4774. # Socket-Server
  4775. typedef struct { XRECORD_HEADER
  4776.                  object socket_handle; # socket handle
  4777.                  object port; # port number
  4778.                }
  4779.         * Socket_server;
  4780. #define socket_server_length  ((sizeof(*(Socket_server)0)-offsetofa(record_,recdata))/sizeof(object))
  4781. #endif
  4782.  
  4783. #ifdef YET_ANOTHER_RECORD
  4784.  
  4785. # Yet another record
  4786. typedef struct { XRECORD_HEADER
  4787.                  object yetanother_x;
  4788.                  object yetanother_y;
  4789.                  object yetanother_z;
  4790.                }
  4791.         * Yetanother;
  4792. #define yetanother_length  ((sizeof(*(Yetanother)0)-offsetofa(record_,recdata))/sizeof(object))
  4793.  
  4794. #endif
  4795.  
  4796. # Streams
  4797. typedef struct {
  4798.                  #ifdef case_stream
  4799.                  VAROBJECT_HEADER # Selbstpointer für GC
  4800.                  uintB strmflags; # Flags
  4801.                  uintB strmtype;  # Untertyp (als sintB >=0 !)
  4802.                  uintB reclength; # Länge in Objekten
  4803.                  uintB recxlength; # Länge der Extra-Elemente
  4804.                  #else
  4805.                  # Muß strmflags und strmtype aus Platzgründen in einem Fixnum
  4806.                  # in recdata[0] unterbringen.
  4807.                  #if !((oint_addr_len+oint_addr_shift>=24) && (8>=oint_addr_shift))
  4808.                  #error "No room for stream flags -- Stream-Flags neu unterbringen!!"
  4809.                  #endif
  4810.                  XRECORD_HEADER
  4811.                  uintB strmfiller1;
  4812.                  uintB strmflags; # Flags
  4813.                  uintB strmtype;  # Untertyp
  4814.                  uintB strmfiller2;
  4815.                  #endif
  4816.                  object strm_rd_by;
  4817.                  object strm_wr_by;
  4818.                  object strm_rd_ch;
  4819.                  object strm_rd_ch_last;
  4820.                  object strm_wr_ch;
  4821.                  object strm_wr_ch_lpos;
  4822.                  #ifdef STRM_WR_SS
  4823.                  object strm_wr_ss;
  4824.                  #endif
  4825.                  object strm_other[unspecified]; # typspezifische Komponenten
  4826.                }
  4827.         *  Stream;
  4828. #define strm_len  ((sizeof(*(Stream)0)-offsetofa(record_,recdata))/sizeof(object))
  4829. # Bitmaske in den Flags:
  4830.   #define strmflags_open_B   0xF0  # gibt an, ob der Stream offen ist
  4831.   #define strmflags_rd_ch_bit_B  6  # gesetzt, falls READ-CHAR möglich ist
  4832.   #define strmflags_wr_ch_bit_B  7  # gesetzt, falls WRITE-CHAR möglich ist
  4833.   #define strmflags_rd_ch_B  bit(strmflags_rd_ch_bit_B)
  4834.   #define strmflags_wr_ch_B  bit(strmflags_wr_ch_bit_B)
  4835.   #ifdef IMMUTABLE
  4836.   #define strmflags_immut_B  0x08  # gibt an, ob gelesene Objekte immutabel sind
  4837.   #endif
  4838. # Nähere Typinfo:
  4839.   enum { # Die Werte dieser Aufzählung sind der Reihe nach 0,1,2,...
  4840.                               enum_strmtype_sch_file,
  4841.   #define strmtype_sch_file   (uintB)enum_strmtype_sch_file
  4842.                               enum_strmtype_ch_file,
  4843.   #define strmtype_ch_file    (uintB)enum_strmtype_ch_file
  4844.                               enum_strmtype_iu_file,
  4845.   #define strmtype_iu_file    (uintB)enum_strmtype_iu_file
  4846.                               enum_strmtype_is_file,
  4847.   #define strmtype_is_file    (uintB)enum_strmtype_is_file
  4848.   #ifdef HANDLES
  4849.                               enum_strmtype_handle,
  4850.   #define strmtype_handle     (uintB)enum_strmtype_handle
  4851.   #endif
  4852.   #ifdef KEYBOARD
  4853.                               enum_strmtype_keyboard,
  4854.   #define strmtype_keyboard   (uintB)enum_strmtype_keyboard
  4855.   #endif
  4856.                               enum_strmtype_terminal,
  4857.   #define strmtype_terminal   (uintB)enum_strmtype_terminal
  4858.                               enum_strmtype_synonym,
  4859.   #define strmtype_synonym    (uintB)enum_strmtype_synonym
  4860.                               enum_strmtype_broad,
  4861.   #define strmtype_broad      (uintB)enum_strmtype_broad
  4862.                               enum_strmtype_concat,
  4863.   #define strmtype_concat     (uintB)enum_strmtype_concat
  4864.                               enum_strmtype_twoway,
  4865.   #define strmtype_twoway     (uintB)enum_strmtype_twoway
  4866.                               enum_strmtype_echo,
  4867.   #define strmtype_echo       (uintB)enum_strmtype_echo
  4868.                               enum_strmtype_str_in,
  4869.   #define strmtype_str_in     (uintB)enum_strmtype_str_in
  4870.                               enum_strmtype_str_out,
  4871.   #define strmtype_str_out    (uintB)enum_strmtype_str_out
  4872.                               enum_strmtype_str_push,
  4873.   #define strmtype_str_push   (uintB)enum_strmtype_str_push
  4874.                               enum_strmtype_pphelp,
  4875.   #define strmtype_pphelp     (uintB)enum_strmtype_pphelp
  4876.                               enum_strmtype_buff_in,
  4877.   #define strmtype_buff_in    (uintB)enum_strmtype_buff_in
  4878.                               enum_strmtype_buff_out,
  4879.   #define strmtype_buff_out   (uintB)enum_strmtype_buff_out
  4880.   #ifdef SCREEN
  4881.                               enum_strmtype_window,
  4882.   #define strmtype_window     (uintB)enum_strmtype_window
  4883.   #endif
  4884.   #ifdef PRINTER
  4885.                               enum_strmtype_printer,
  4886.   #define strmtype_printer    (uintB)enum_strmtype_printer
  4887.   #endif
  4888.   #ifdef PIPES
  4889.                               enum_strmtype_pipe_in,
  4890.   #define strmtype_pipe_in    (uintB)enum_strmtype_pipe_in
  4891.                               enum_strmtype_pipe_out,
  4892.   #define strmtype_pipe_out   (uintB)enum_strmtype_pipe_out
  4893.   #endif
  4894.   #ifdef XSOCKETS
  4895.                               enum_strmtype_xsocket,
  4896.   #define strmtype_xsocket     (uintB)enum_strmtype_xsocket
  4897.   #endif
  4898.   #ifdef GENERIC_STREAMS
  4899.                               enum_strmtype_generic,
  4900.   #define strmtype_generic    (uintB)enum_strmtype_generic
  4901.   #endif
  4902.   #ifdef SOCKET_STREAMS
  4903.                               enum_strmtype_socket,
  4904.   #define strmtype_socket     (uintB)enum_strmtype_socket
  4905.   #endif
  4906.                               enum_strmtype_dummy
  4907.   };
  4908.   # Bei Änderung dieser Tabelle auch
  4909.   # - die acht Sprungtabellen bei STREAM-ELEMENT-TYPE, INTERACTIVE-STREAM-P,
  4910.   #   CLOSE, LISTEN, CLEAR_INPUT, FINISH_OUTPUT, FORCE_OUTPUT, CLEAR_OUTPUT
  4911.   #   in STREAM.D und
  4912.   # - die Namenstabelle in CONSTOBJ.D und
  4913.   # - die Sprungtabelle bei PR_STREAM in IO.D und
  4914.   # - die Pseudofunktionentabelle in PSEUDOFUN.D
  4915.   # anpassen!
  4916. # weitere typspezifische Komponenten:
  4917.   #define strm_file_name       strm_other[3] # Filename, ein Pathname
  4918.   #define strm_file_truename   strm_other[4] # Truename, ein nicht-Logical Pathname
  4919.   #define strm_file_handle     strm_other[2] # Handle, ein Fixnum >=0, <2^16
  4920.   #define strm_sch_file_lineno strm_other[8] # Zeilennummer beim Lesen, ein Fixnum >0
  4921.   #define strm_synonym_symbol  strm_other[0]
  4922.   #define strm_broad_list      strm_other[0] # Liste von Streams
  4923.   #define strm_concat_list     strm_other[0] # Liste von Streams
  4924.   #define strm_pphelp_lpos     strm_wr_ch_lpos # Line Position (Fixnum>=0)
  4925.   #define strm_pphelp_strings  strm_other[0]   # Semi-Simple-Strings für Output
  4926.   #define strm_pphelp_modus    strm_other[1]   # Modus (NIL=Einzeiler, T=Mehrzeiler)
  4927.   #define strm_buff_in_fun     strm_other[0] # Lesefunktion
  4928.   #define strm_buff_out_fun    strm_other[0] # Ausgabefunktion
  4929.   #ifdef PIPES
  4930.   #define strm_pipe_pid        strm_other[3] # Prozeß-Id, ein Fixnum >=0
  4931.   #endif
  4932.   #ifdef XSOCKETS
  4933.   #define strm_xsocket_connect strm_other[3] # Liste (host display)
  4934.   #endif
  4935.   #ifdef GENERIC_STREAMS
  4936.   #define strm_controller_object strm_other[0] # Controller (meist CLOS-Instanz)
  4937.   #endif
  4938.   #ifdef SOCKET_STREAMS
  4939.   #define strm_socket_port strm_other[3]
  4940.   #define strm_socket_host strm_other[4]
  4941.   #endif
  4942. # wird verwendet von STREAM, PATHNAME, IO
  4943.  
  4944. # Structures
  4945. typedef Srecord  Structure;
  4946.   #define structure_types   recdata[0]
  4947.  
  4948. # CLOS-Klassen (= Instanzen von <class>), siehe clos.lsp
  4949. typedef struct { SRECORD_HEADER
  4950.                  object structure_types_2;   # Liste (metaclass <class>)
  4951.                  object metaclass;           # eine Subklasse von <class>
  4952.                  object classname;           # ein Symbol
  4953.                  object direct_superclasses; # direkte Oberklassen
  4954.                  object all_superclasses;    # alle Oberklassen inkl. sich selbst
  4955.                  object precedence_list;     # angeordnete Liste aller Oberklassen
  4956.                  object slot_location_table; # Hashtabelle Slotname -> wo der Slot sitzt
  4957.                  # ab hier nur bei metaclass = <standard-class>
  4958.                  object direct_slots;
  4959.                  object slots;
  4960.                  object instance_slot_count;
  4961.                  object shared_slots;
  4962.                  object direct_default_initargs;
  4963.                  object default_initargs;
  4964.                  object valid_initargs;
  4965.                  object other[unspecified];
  4966.                }
  4967.         *  Class;
  4968.  
  4969. # CLOS-Instanzen
  4970. typedef struct { SRECORD_HEADER
  4971.                  object class; # eine CLOS-Klasse
  4972.                  object other[unspecified];
  4973.                }
  4974.         *  Instance;
  4975.  
  4976. # Closures
  4977. typedef struct { SRECORD_HEADER
  4978.                  object clos_name;
  4979.                  object clos_codevec;
  4980.                  object other[unspecified];
  4981.                }
  4982.         *  Closure;
  4983. # interpretierte Closure:
  4984. typedef struct { SRECORD_HEADER
  4985.                  object clos_name;
  4986.                  object clos_form;
  4987.                  object clos_docstring;
  4988.                  object clos_body;
  4989.                  object clos_var_env;
  4990.                  object clos_fun_env;
  4991.                  object clos_block_env;
  4992.                  object clos_go_env;
  4993.                  object clos_decl_env;
  4994.                  object clos_vars;
  4995.                  object clos_varflags;
  4996.                  object clos_spec_anz;
  4997.                  object clos_req_anz;
  4998.                  object clos_opt_anz;
  4999.                  object clos_opt_inits;
  5000.                  object clos_key_anz;
  5001.                  object clos_keywords;
  5002.                  object clos_key_inits;
  5003.                  object clos_allow_flag;
  5004.                  object clos_rest_flag;
  5005.                  object clos_aux_anz;
  5006.                  object clos_aux_inits;
  5007.                }
  5008.         *  Iclosure;
  5009. #define iclos_length  ((sizeof(*(Iclosure)0)-offsetofa(record_,recdata))/sizeof(object))
  5010. # compilierte Closure:
  5011. typedef struct { SRECORD_HEADER
  5012.                  object clos_name;
  5013.                  object clos_codevec;
  5014.                  object clos_consts[unspecified]; # Closure-Konstanten
  5015.                }
  5016.         *  Cclosure;
  5017. #define clos_venv  clos_consts[0]
  5018. # Compilierte Closures, bei denen Bit 4 in den Flags von clos_codevec
  5019. # gesetzt ist, sind generische Funktionen.
  5020.  
  5021. # Eine compilierte LISP-Funktion bekommt ihre Argumente auf dem STACK
  5022. # und liefert ihre Werte im MULTIPLE_VALUE_SPACE. Als C-Funktion liefert
  5023. # sie keinen Wert.
  5024.   # Rückgabe von Multiple Values geschieht vollständig über den
  5025.   # MULTIPLE_VALUE_SPACE. Als C-Funktion: Ergebnistyp Values.
  5026.     #ifndef Values
  5027.     typedef void Values;
  5028.     #endif
  5029.   # Um einen Typ vom Wert Values weiterzureichen: return_Values(...);
  5030.     #define return_Values  return_void
  5031.   # Eine Lisp-Funktion ist ein Pointer auf eine C-Funktion ohne Rückgabewert
  5032.     typedef Values (*lisp_function)();
  5033. # Sollte dies geändert werden, so ist jeder Aufruf einer C-Funktion vom
  5034. # Ergebnistyp 'Values' (insbesondere 'funcall', 'apply', 'eval') zu überprüfen.
  5035.  
  5036. # FSUBRs
  5037. # Als C-Funktionen: vom Typ fsubr_function (keine Argumente, kein Wert):
  5038.   typedef Values fsubr_function (void);
  5039. # Die Adressen dieser C-Funktionen werden direkt angesprungen.
  5040. # Für SAVEMEM/LOADMEM gibt es eine Tabelle aller FSUBRs.
  5041.   typedef fsubr_function * fsubr_;
  5042. # Signatur von FSUBRs im Lisp-Sinne:
  5043. #         argtype          Kürzel für den Argumente-Typ     fsubr_argtype_
  5044. #         req_anz          Anzahl required Parameter        uintW
  5045. #         opt_anz          Anzahl optionaler Parameter      uintW
  5046. #         body_flag        Body-Flag                        fsubr_body_
  5047. # Die Komponente body_flag enthält ein uintW, gemeint ist aber:
  5048.   typedef enum { fsubr_nobody, fsubr_body } fsubr_body_;
  5049. # Die Komponente argtype enthält ein Fixnum, gemeint ist aber:
  5050.   typedef enum {
  5051.                 fsubr_argtype_1_0_nobody,
  5052.                 fsubr_argtype_2_0_nobody,
  5053.                 fsubr_argtype_1_1_nobody,
  5054.                 fsubr_argtype_2_1_nobody,
  5055.                 fsubr_argtype_0_body,
  5056.                 fsubr_argtype_1_body,
  5057.                 fsubr_argtype_2_body
  5058.                }
  5059.           fsubr_argtype_;
  5060. # Umwandlung siehe SPVW:
  5061. # extern fsubr_argtype_ fsubr_argtype (uintW req_anz, uintW opt_anz, fsubr_body_ body_flag);
  5062.  
  5063. # SUBRs
  5064. # SUBR-Tabellen-Eintrag:
  5065.   typedef struct { lisp_function function; # Funktion
  5066.                    object name;            # Name
  5067.                    object keywords;        # NIL oder Vektor mit den Keywords
  5068.                    uintW argtype;          # Kürzel für den Argumente-Typ
  5069.                    uintW req_anz;          # Anzahl required Parameter
  5070.                    uintW opt_anz;          # Anzahl optionaler Parameter
  5071.                    uintB rest_flag;        # Flag für beliebig viele Argumente
  5072.                    uintB key_flag;         # Flag für Keywords
  5073.                    uintW key_anz;          # Anzahl Keywordparameter
  5074.                  }
  5075.           subr_;
  5076.   typedef subr_ *  Subr;
  5077. # GC benötigt Information, wo hierin Objekte stehen:
  5078.   #define subr_const_offset  offsetof(subr_,name)
  5079.   #define subr_const_anz     2
  5080. # Die Komponente rest_flag enthält ein uintB, gemeint ist aber:
  5081.   typedef enum { subr_norest, subr_rest } subr_rest_;
  5082. # Die Komponente key_flag enthält ein uintB, gemeint ist aber:
  5083.   typedef enum { subr_nokey, subr_key, subr_key_allow } subr_key_;
  5084. # Die Komponente argtype enthält ein uintW, gemeint ist aber:
  5085.   typedef enum {
  5086.                 subr_argtype_0_0,
  5087.                 subr_argtype_1_0,
  5088.                 subr_argtype_2_0,
  5089.                 subr_argtype_3_0,
  5090.                 subr_argtype_4_0,
  5091.                 subr_argtype_5_0,
  5092.                 subr_argtype_6_0,
  5093.                 subr_argtype_0_1,
  5094.                 subr_argtype_1_1,
  5095.                 subr_argtype_2_1,
  5096.                 subr_argtype_3_1,
  5097.                 subr_argtype_4_1,
  5098.                 subr_argtype_0_2,
  5099.                 subr_argtype_1_2,
  5100.                 subr_argtype_2_2,
  5101.                 subr_argtype_0_3,
  5102.                 subr_argtype_0_4,
  5103.                 subr_argtype_0_5,
  5104.                 subr_argtype_0_0_rest,
  5105.                 subr_argtype_1_0_rest,
  5106.                 subr_argtype_2_0_rest,
  5107.                 subr_argtype_3_0_rest,
  5108.                 subr_argtype_0_0_key,
  5109.                 subr_argtype_1_0_key,
  5110.                 subr_argtype_2_0_key,
  5111.                 subr_argtype_3_0_key,
  5112.                 subr_argtype_4_0_key,
  5113.                 subr_argtype_0_1_key,
  5114.                 subr_argtype_1_1_key,
  5115.                 subr_argtype_1_2_key
  5116.                }
  5117.           subr_argtype_;
  5118. # Umwandlung siehe SPVW:
  5119. # extern subr_argtype_ subr_argtype (uintW req_anz, uintW opt_anz, subr_rest_ rest_flag, subr_key_ key_flag);
  5120.  
  5121. # System-Pointer
  5122.   #define make_system(data)  \
  5123.     type_data_object(system_type, bit(oint_data_len-1) | bit(0) | ((bitm(oint_data_len)-1) & (data)))
  5124. # Alle solchen müssen in io.d:pr_system() eine spezielle print-Routine bekommen.
  5125.  
  5126. # Indikator für nicht vorhandenen Wert:
  5127.   #define unbound  make_system(0xFFFFFFUL)
  5128.  
  5129. # Indikator für nicht vorhandenes Objekt (nur intern verwendet):
  5130.   #define nullobj  type_pointer_object(machine_type,NULL) # = as_object((oint)0)
  5131.  
  5132. # Um auf die Komponenten eines Objekts zugreifen zu können, muß man erst
  5133. # die Typbits entfernen:
  5134.   #if !((oint_addr_shift==0) && (addr_shift==0))
  5135.     #define pointable(obj)  ((void*)upointer(obj))
  5136.   #else
  5137.     # Ist oint_addr_shift=0 und addr_shift=0, so braucht man nicht zu shiften.
  5138.     #if !(((tint_type_mask<<oint_type_shift) & addressbus_mask) == 0)
  5139.       #define pointable(obj)  \
  5140.         ((void*)((aint)as_oint(obj) & ((aint)oint_addr_mask | ~addressbus_mask)))
  5141.     #else
  5142.       # Ist ferner oint_type_mask von addressbus_mask disjunkt, so werden
  5143.       # sowieso keine Typbits auf den Adreßbus geschickt.
  5144.       # Also ist gar nichts zu tun:
  5145.       #define pointable(obj)  ((void*)as_oint(obj))
  5146.     #endif
  5147.   #endif
  5148.  
  5149. # Wenn man auf ein Objekt zugreifen will, das eine bekannte Typinfo hat,
  5150. # dessen gesetzte Typbits vom Adreßbus verschluckt werden (auf die
  5151. # Typbits, die =0 sind, kommt es nicht an), so kann man auf das 'untype'
  5152. # verzichten:
  5153.   #if defined(WIDE_STRUCT)
  5154.     #define type_pointable(type,obj)  ((void*)((obj).both.addr))
  5155.   #elif !((oint_addr_shift==0) && (addr_shift==0) && (((tint_type_mask<<oint_type_shift) & addressbus_mask) == 0))
  5156.     #if (addr_shift==0)
  5157.       #define type_pointable(type,obj)  \
  5158.         ((oint_addr_shift==0) && ((type_zero_oint(type) & addressbus_mask) == 0) \
  5159.          ? (void*)(aint)as_oint(obj)                                             \
  5160.          : (void*)(aint)pointable(obj)                                           \
  5161.         )
  5162.     #elif !(addr_shift==0)
  5163.       # Analog, nur dass der Macro 'optimized_upointer' die Rolle des Adreßbus übernimmt:
  5164.       #define type_pointable(type,obj)  \
  5165.         ((optimized_upointer(type_data_object(type,0)) == 0) \
  5166.          ? (void*)(aint)optimized_upointer(obj)              \
  5167.          : (void*)(aint)pointable(obj)                       \
  5168.         )
  5169.     #endif
  5170.   #else
  5171.     # Wenn pointable(obj) = obj, braucht auch type_pointable() nichts zu tun:
  5172.     #define type_pointable(type,obj)  ((void*)(aint)as_oint(obj))
  5173.   #endif
  5174.  
  5175. # Wenn man auf ein Objekt zugreifen will, das eine von mehreren bekannten
  5176. # Typinfos hat, kann man evtl. auf das 'untype' verzichten. Maßgeblich
  5177. # ist das OR der Typinfos.
  5178.   #define types_pointable(ORed_types,obj)  type_pointable(ORed_types,obj)
  5179.  
  5180. # TheCons(object) liefert das zu object äquivalente Cons.
  5181. # Die Information, daß es Cons darstellt, muß hineingesteckt werden.
  5182. # Analog die anderen Typumwandlungen.
  5183.   #define TheCons(obj)  ((Cons)(types_pointable(cons_type|imm_cons_type,obj)))
  5184.   #define TheRatio(obj)  ((Ratio)(types_pointable(ratio_type|bit(sign_bit_t),obj)))
  5185.   #define TheComplex(obj)  ((Complex)(type_pointable(complex_type,obj)))
  5186.   #define TheSymbol(obj)  ((Symbol)(type_pointable(symbol_type,obj)))
  5187.   #if (oint_symbolflags_shift==oint_type_shift)
  5188.   #define TheSymbolflagged(obj)  ((Symbol)(types_pointable(symbol_type|bit(active_bit)|bit(dynam_bit)|bit(svar_bit),obj)))
  5189.   #else
  5190.   #define TheSymbolflagged(obj)  TheSymbol(symbol_without_flags(obj))
  5191.   #endif
  5192.   #define TheBignum(obj)  ((Bignum)(types_pointable(bignum_type|bit(sign_bit_t),obj)))
  5193.   #ifndef WIDE
  5194.   #define TheFfloat(obj)  ((Ffloat)(types_pointable(ffloat_type|bit(sign_bit_t),obj)))
  5195.   #endif
  5196.   #define TheDfloat(obj)  ((Dfloat)(types_pointable(dfloat_type|bit(sign_bit_t),obj)))
  5197.   #define TheLfloat(obj)  ((Lfloat)(types_pointable(lfloat_type|bit(sign_bit_t),obj)))
  5198.   #define TheSarray(obj)  ((Sarray)(types_pointable(sbvector_type|imm_sbvector_type|sstring_type|imm_sstring_type|svector_type|imm_svector_type,obj)))
  5199.   #define TheSbvector(obj)  ((Sbvector)(types_pointable(sbvector_type|imm_sbvector_type,obj)))
  5200.   #define TheSstring(obj)  ((Sstring)(types_pointable(sstring_type|imm_sstring_type,obj)))
  5201.   #define TheSvector(obj)  ((Svector)(types_pointable(svector_type|imm_svector_type,obj)))
  5202.   #define TheArray(obj)  ((Array)(types_pointable(array_type|imm_array_type|bvector_type|imm_bvector_type|string_type|imm_string_type|vector_type|imm_vector_type,obj)))
  5203.   #define TheRecord(obj)  ((Record)(types_pointable(closure_type|structure_type|stream_type|orecord_type|instance_type,obj)))
  5204.   #define TheSrecord(obj)  ((Srecord)(types_pointable(closure_type|structure_type|orecord_type|instance_type,obj)))
  5205.   #define TheXrecord(obj)  ((Xrecord)(types_pointable(stream_type|orecord_type,obj)))
  5206.   #define ThePackage(obj)  ((Package)(type_pointable(orecord_type,obj)))
  5207.   #define TheHashtable(obj)  ((Hashtable)(type_pointable(orecord_type,obj)))
  5208.   #define TheReadtable(obj)  ((Readtable)(type_pointable(orecord_type,obj)))
  5209.   #define ThePathname(obj)  ((Pathname)(type_pointable(orecord_type,obj)))
  5210.   #ifdef LOGICAL_PATHNAMES
  5211.   #define TheLogpathname(obj)  ((Logpathname)(type_pointable(orecord_type,obj)))
  5212.   #endif
  5213.   #define The_Random_state(obj)  ((Random_state)(type_pointable(orecord_type,obj)))
  5214.   #define TheByte(obj)  ((Byte)(type_pointable(orecord_type,obj)))
  5215.   #define TheFsubr(obj)  ((Fsubr)(type_pointable(orecord_type,obj)))
  5216.   #define TheLoadtimeeval(obj)  ((Loadtimeeval)(type_pointable(orecord_type,obj)))
  5217.   #define TheSymbolmacro(obj)  ((Symbolmacro)(type_pointable(orecord_type,obj)))
  5218.   #ifdef FOREIGN
  5219.   #define TheFpointer(obj)  ((Fpointer)(type_pointable(orecord_type,obj)))
  5220.   #endif
  5221.   #ifdef DYNAMIC_FFI
  5222.   #define TheFaddress(obj)  ((Faddress)(type_pointable(orecord_type,obj)))
  5223.   #define TheFvariable(obj)  ((Fvariable)(type_pointable(orecord_type,obj)))
  5224.   #define TheFfunction(obj)  ((Ffunction)(type_pointable(orecord_type,obj)))
  5225.   #endif
  5226.   #define TheFinalizer(obj)  ((Finalizer)(type_pointable(orecord_type,obj)))
  5227.   #ifdef SOCKET_STREAMS
  5228.   #define TheSocketServer(obj) ((Socket_server)(type_pointable(orecord_type,obj)))
  5229.   #endif
  5230.   #ifdef YET_ANOTHER_RECORD
  5231.   #define TheYetanother(obj)  ((Yetanother)(type_pointable(orecord_type,obj)))
  5232.   #endif
  5233.   #define TheStream(obj)  ((Stream)(type_pointable(stream_type,obj)))
  5234.   #define TheStructure(obj)  ((Structure)(type_pointable(structure_type,obj)))
  5235.   #define TheClass(obj)  ((Class)(type_pointable(structure_type,obj)))
  5236.   #define TheClosure(obj)  ((Closure)(type_pointable(closure_type,obj)))
  5237.   #define TheIclosure(obj)  ((Iclosure)(type_pointable(closure_type,obj)))
  5238.   #define TheCclosure(obj)  ((Cclosure)(type_pointable(closure_type,obj)))
  5239.   #define TheInstance(obj)  ((Instance)(type_pointable(instance_type,obj)))
  5240.   #define TheSubr(obj)  ((Subr)(type_pointable(subr_type,obj)))
  5241.   #define TheFramepointer(obj)  ((object*)(type_pointable(system_type,obj)))
  5242.   #define TheMachine(obj)  ((void*)(type_pointable(machine_type,obj)))
  5243.   #define ThePseudofun(obj)  ((Pseudofun)TheMachine(obj))
  5244.   #ifdef FOREIGN_HANDLE
  5245.   # Handle in Sbvector verpackt
  5246.   #define TheHandle(obj)  (*(Handle*)(&TheSbvector(obj)->data[0]))
  5247.   #else
  5248.   # Handle in Fixnum>=0 verpackt
  5249.   #define TheHandle(obj)  ((Handle)posfixnum_to_L(obj))
  5250.   #endif
  5251.   #ifdef IMMUTABLE
  5252.   # Read-Write-Zugriff auf immutable Objekte:
  5253.   #ifdef IMMUTABLE_ARRAY
  5254.   #define TheImmSvector(obj)  \
  5255.     ((Svector)(type_pointable(imm_svector_type, \
  5256.                objectplus(obj,-type_zero_oint(imm_array_mask)))))
  5257.   #define TheImmArray(obj)  \
  5258.     ((Array)(types_pointable(imm_sbvector_type|imm_sstring_type|imm_array_type|imm_bvector_type|imm_string_type|imm_vector_type, \
  5259.              objectplus(obj,-type_zero_oint(imm_array_mask)))))
  5260.   #endif
  5261.   #ifdef IMMUTABLE_CONS
  5262.   #define TheImmCons(obj)  \
  5263.     ((Cons)type_pointable(cons_type,objectplus(obj,type_zero_oint(cons_type)-type_zero_oint(imm_cons_type))))
  5264.   #endif
  5265.   #endif
  5266.   # Objekt variabler Länge:
  5267.   #define TheVarobject(obj)  \
  5268.     ((Varobject)                                                                               \
  5269.      (types_pointable                                                                          \
  5270.       (sbvector_type|sstring_type|svector_type|array_type|bvector_type|string_type|vector_type \
  5271.        |imm_sbvector_type|imm_sstring_type|imm_svector_type|imm_array_type|imm_bvector_type|imm_string_type|imm_vector_type \
  5272.        |closure_type|structure_type|stream_type|orecord_type|symbol_type                       \
  5273.        |bignum_type|ffloat_type|dfloat_type|lfloat_type|bit(sign_bit_t),                       \
  5274.        obj                                                                                     \
  5275.     )))
  5276.   # Objekt, das einen Pointer in den Speicher darstellt:
  5277.   #define ThePointer(obj)  \
  5278.     (types_pointable                                                                            \
  5279.      (sbvector_type|sstring_type|svector_type|array_type|bvector_type|string_type|vector_type   \
  5280.       |imm_sbvector_type|imm_sstring_type|imm_svector_type|imm_array_type|imm_bvector_type|imm_string_type|imm_vector_type \
  5281.       |closure_type|structure_type|stream_type|orecord_type|symbol_type|cons_type|imm_cons_type \
  5282.       |bignum_type|ffloat_type|dfloat_type|lfloat_type|ratio_type|complex_type|bit(sign_bit_t), \
  5283.       obj                                                                                       \
  5284.     ))
  5285.  
  5286. # Ein paar Abkürzungen:
  5287.   # Zugriff auf Objekte, die Conses sind:
  5288.     #define Car(obj)  (TheCons(obj)->car)
  5289.     #define Cdr(obj)  (TheCons(obj)->cdr)
  5290.   # Zugriff auf Objekte, die Symbole sind:
  5291.  
  5292.     # Macros concerning the current shallow binding:
  5293.     #define Symbol_symvalue(obj) (TheSymbol(obj)->symvalue)
  5294.     #define Symbolflagged_symvalue(obj) (TheSymbolflagged(obj)->symvalue)
  5295.     #define set_Symbol_symvalue(obj,val) ((TheSymbol(obj)->symvalue)=(val))
  5296.     #define set_Symbolflagged_symvalue(obj,val) ((TheSymbolflagged(obj)->symvalue)=(val))
  5297.  
  5298.     # Macros that serve as the normal interface for accessing symbol values:
  5299.     #define Symbol_value Symbol_symvalue
  5300.     #define set_Symbol_value(obj,val) ((TheSymbol(obj)->symvalue)=(val))
  5301.     #define Symbolflagged_value Symbolflagged_symvalue
  5302.     #ifndef DYNBIND_LIST
  5303.     #define set_Symbolflagged_value_on(obj,val,frameptr) ((TheSymbolflagged(obj)->symvalue)=(val))
  5304.     #define set_Symbolflagged_value_off(obj,val) ((TheSymbolflagged(obj)->symvalue)=(val))
  5305.     #else
  5306.     extern void set_Symbolflagged_value_on(object sym,object val,object *frameptr);
  5307.     extern void set_Symbolflagged_value_off(object sym,object val);
  5308.     extern void add_frame_to_binding_list(object *stackptr);
  5309.     extern void delete_frame_from_binding_list(object *stackptr);
  5310.     #endif
  5311.  
  5312.     #define Symbol_function(obj)  (TheSymbol(obj)->symfunction)
  5313.     #define Symbol_plist(obj)  (TheSymbol(obj)->proplist)
  5314.     #define Symbol_name(obj)  (TheSymbol(obj)->pname)
  5315.     #define Symbol_package(obj)  (TheSymbol(obj)->homepackage)
  5316.   # Länge (Anzahl Objekte) eines Record:
  5317.     #define Record_length(obj)  \
  5318.       (TheRecord(obj)->rectype < 0 ? TheSrecord(obj)->reclength : TheXrecord(obj)->reclength)
  5319.  
  5320.  
  5321. # ####################### Typtestprädikate ################################ #
  5322. # Die gibt es in zwei Formen:
  5323. # 1.  ???p, mit 'if' abzufragen:  if ???p(object)
  5324. # 2.  if_???p, aufzurufen als
  5325. #         if_???p(object, statement1, statement2)
  5326. #       statt
  5327. #         if ???p(object) statement1 else statement2
  5328.  
  5329. # UP: testet auf Pointergleichheit EQ
  5330. # eq(obj1,obj2)
  5331. # > obj1,obj2: Lisp-Objekte
  5332. # < ergebnis: TRUE, falls Objekte gleich
  5333.   #if defined(WIDE_STRUCT) || defined(OBJECT_STRUCT)
  5334.     #define eq(obj1,obj2)  (as_oint(obj1) == as_oint(obj2))
  5335.   #else
  5336.     #define eq(obj1,obj2)  ((obj1) == (obj2))
  5337.   #endif
  5338.  
  5339. # Test auf NIL
  5340.   #define nullp(obj)  (eq(obj,NIL))
  5341.   #define sym_nullp(sym) nullp(Symbol_symvalue(sym))
  5342.  
  5343. # Test auf Cons
  5344.   #if defined(cons_bit_o) /* || defined(IMMUTABLE_CONS) */
  5345.     # define consp(obj)  (as_oint(obj) & wbit(cons_bit_o))
  5346.     #define consp(obj)  (wbit_test(as_oint(obj),cons_bit_o))
  5347.     #ifdef fast_mtypecode
  5348.       #ifdef WIDE_STRUCT
  5349.         #undef consp
  5350.         #define consp(obj)  (typecode(obj) & bit(cons_bit_t))
  5351.       #endif
  5352.       #define mconsp(obj)  (mtypecode(obj) & bit(cons_bit_t))
  5353.     #else
  5354.       #define mconsp(obj)  consp(obj)
  5355.     #endif
  5356.   #else
  5357.     #define consp(obj)  ((typecode(obj) & ~imm_cons_mask) == cons_type)
  5358.     #define mconsp(obj)  ((mtypecode(obj) & ~imm_cons_mask) == cons_type)
  5359.   #endif
  5360.  
  5361. # Test auf Atom
  5362.   #if defined(cons_bit_o) /* || defined(IMMUTABLE_CONS) */
  5363.     # define atomp(obj)  ((as_oint(obj) & wbit(cons_bit_o))==0)
  5364.     #define atomp(obj)  (!wbit_test(as_oint(obj),cons_bit_o))
  5365.     #ifdef fast_mtypecode
  5366.       #ifdef WIDE_STRUCT
  5367.         #undef atomp
  5368.         #define atomp(obj)  ((typecode(obj) & bit(cons_bit_t))==0)
  5369.       #endif
  5370.       #define matomp(obj)  ((mtypecode(obj) & bit(cons_bit_t))==0)
  5371.     #else
  5372.       #define matomp(obj)  atomp(obj)
  5373.     #endif
  5374.   #else
  5375.     #define atomp(obj)  (!((typecode(obj) & ~imm_cons_mask) == cons_type))
  5376.     #define matomp(obj)  (!((mtypecode(obj) & ~imm_cons_mask) == cons_type))
  5377.   #endif
  5378.  
  5379. # Test auf Liste, obj sollte eine Variable sein
  5380.   #define listp(obj)  (nullp(obj) || consp(obj))
  5381.  
  5382. # Test auf Symbol
  5383.   #if defined(symbol_bit_o)
  5384.     # define symbolp(obj)  (as_oint(obj) & wbit(symbol_bit_o))
  5385.     #define symbolp(obj)  (wbit_test(as_oint(obj),symbol_bit_o))
  5386.     #ifdef fast_mtypecode
  5387.       #ifdef WIDE_STRUCT
  5388.         #undef symbolp
  5389.         #define symbolp(obj)  (typecode(obj) & bit(symbol_bit_t))
  5390.       #endif
  5391.       #define msymbolp(obj)  (mtypecode(obj) & bit(symbol_bit_t))
  5392.     #else
  5393.       #define msymbolp(obj)  symbolp(obj)
  5394.     #endif
  5395.   #else
  5396.     #define symbolp(obj)  (typecode(obj) == symbol_type)
  5397.     #define msymbolp(obj)  (mtypecode(obj) == symbol_type)
  5398.   #endif
  5399.  
  5400. # Test auf Zahl
  5401.   # define numberp(obj)  (as_oint(obj) & wbit(number_bit_o))
  5402.   #define numberp(obj)  (wbit_test(as_oint(obj),number_bit_o))
  5403.   #ifdef fast_mtypecode
  5404.     #ifdef WIDE_STRUCT
  5405.       #undef numberp
  5406.       #define numberp(obj)  (typecode(obj) & bit(number_bit_t))
  5407.     #endif
  5408.     #define mnumberp(obj)  (mtypecode(obj) & bit(number_bit_t))
  5409.   #else
  5410.     #define mnumberp(obj)  numberp(obj)
  5411.   #endif
  5412.  
  5413. # Test auf Vector (Typbytes %001,%010,%011,%101,%110,%111)
  5414.   #if 0
  5415.     #define if_vectorp(obj,statement1,statement2)  \
  5416.       {var reg2 object obj_from_if_vectorp = (obj);                          \
  5417.        var reg1 tint type_from_if_vectorp = typecode(obj_from_if_vectorp) & !imm_array_mask; \
  5418.        type_from_if_vectorp = type_from_if_vectorp & ~bit(notsimple_bit_t);  \
  5419.        if (!(type_from_if_vectorp==0)&&(type_from_if_vectorp<=svector_type)) \
  5420.          { statement1 } else { statement2 }                                  \
  5421.       }
  5422.   #else # effizienter
  5423.     #define if_vectorp(obj,statement1,statement2)  \
  5424.       if (vectorp(obj)) { statement1 } else { statement2 }
  5425.   #endif
  5426.   #define vectorp(obj)  \
  5427.     ((tint)((typecode(obj) & ~imm_array_mask & ~bit(notsimple_bit_t))-1) <= (tint)(svector_type-1))
  5428.   #define mvectorp(obj)  \
  5429.     ((tint)((mtypecode(obj) & ~imm_array_mask & ~bit(notsimple_bit_t))-1) <= (tint)(svector_type-1))
  5430.  
  5431. # Test auf simple-vector oder simple-bit-vector oder simple-string
  5432.   #if 0
  5433.     #define if_simplep(obj,statement1,statement2)  \
  5434.       {var reg2 object obj_from_if_simplep = (obj);                          \
  5435.        var reg1 tint type_from_if_simplep = typecode(obj_from_if_simplep) & ~imm_array_mask; \
  5436.        if (!(type_from_if_simplep==0)&&(type_from_if_simplep<=svector_type)) \
  5437.          { statement1 } else { statement2 }                                  \
  5438.       }
  5439.   #else # effizienter
  5440.     #define if_simplep(obj,statement1,statement2)  \
  5441.       if (simplep(obj)) { statement1 } else { statement2 }
  5442.   #endif
  5443.   #define simplep(obj)  \
  5444.     ((tint)((typecode(obj) & ~imm_array_mask) - 1) <= (tint)(svector_type-1))
  5445.  
  5446. # Test eines Array auf simple-vector oder simple-bit-vector oder simple-string
  5447.   #define array_simplep(obj)  \
  5448.     ((typecode(obj) & ~imm_array_mask) <= svector_type)
  5449.  
  5450. # Test auf simple-vector
  5451.   #define simple_vector_p(obj)  \
  5452.     ((typecode(obj) & ~imm_array_mask) == svector_type)
  5453.   #define m_simple_vector_p(obj)  \
  5454.     ((mtypecode(obj) & ~imm_array_mask) == svector_type)
  5455.  
  5456. # Test auf general-vector=(vector t)
  5457.   #define general_vector_p(obj)  \
  5458.     ((typecode(obj) & ~imm_array_mask & ~bit(notsimple_bit_t)) == svector_type)
  5459.   #define m_general_vector_p(obj)  \
  5460.     ((mtypecode(obj) & ~imm_array_mask & ~bit(notsimple_bit_t)) == svector_type)
  5461.  
  5462. # Test auf simple-string
  5463.   #define simple_string_p(obj)  \
  5464.     ((typecode(obj) & ~imm_array_mask) == sstring_type)
  5465.   #define m_simple_string_p(obj)  \
  5466.     ((mtypecode(obj) & ~imm_array_mask) == sstring_type)
  5467.  
  5468. # Test auf string
  5469.   #define stringp(obj)  \
  5470.     ((typecode(obj) & ~imm_array_mask & ~bit(notsimple_bit_t)) == sstring_type)
  5471.   #define mstringp(obj)  \
  5472.     ((mtypecode(obj) & ~imm_array_mask & ~bit(notsimple_bit_t)) == sstring_type)
  5473.  
  5474. # Test auf simple-bit-vector
  5475.   #define simple_bit_vector_p(obj)  \
  5476.     ((typecode(obj) & ~imm_array_mask) == sbvector_type)
  5477.   #define m_simple_bit_vector_p(obj)  \
  5478.     ((mtypecode(obj) & ~imm_array_mask) == sbvector_type)
  5479.  
  5480. # Test auf bit-vector
  5481.   #define bit_vector_p(obj)  \
  5482.     (((typecode(obj) & ~imm_array_mask) == sbvector_type)                 \
  5483.      || (((typecode(obj) & ~imm_array_mask) == bvector_type)              \
  5484.          && ((TheArray(obj)->flags & arrayflags_atype_mask) == Atype_Bit) \
  5485.     )   )
  5486.   #define m_bit_vector_p(obj)  \
  5487.     (((mtypecode(obj) & ~imm_array_mask) == sbvector_type)                \
  5488.      || (((mtypecode(obj) & ~imm_array_mask) == bvector_type)             \
  5489.          && ((TheArray(obj)->flags & arrayflags_atype_mask) == Atype_Bit) \
  5490.     )   )
  5491.  
  5492. # Test auf Array allgemein
  5493.   #if 0
  5494.     #define if_arrayp(obj,statement1,statement2)  \
  5495.       {var reg2 object obj_from_if_arrayp = (obj);                        \
  5496.        var reg1 tint type_from_if_arrayp = typecode(obj_from_if_arrayp) & ~imm_array_mask; \
  5497.        if (!(type_from_if_arrayp==0)&&(type_from_if_arrayp<=vector_type)) \
  5498.          { statement1 } else { statement2 }                               \
  5499.       }
  5500.   #else # effizienter
  5501.     #define if_arrayp(obj,statement1,statement2)  \
  5502.       if (arrayp(obj)) { statement1 } else { statement2 }
  5503.   #endif
  5504.   #define arrayp(obj)  \
  5505.     ((tint)((typecode(obj) & ~imm_array_mask) - 1) <= (tint)(vector_type-1))
  5506.  
  5507. # Test auf Array, der kein Vector ist (Typbyte %100)
  5508.   #define array1p(obj)  \
  5509.     ((typecode(obj) & ~imm_array_mask) == array_type)
  5510.   #define marray1p(obj)  \
  5511.     ((mtypecode(obj) & ~imm_array_mask) == array_type)
  5512.  
  5513. # Test auf Closure/Structure/Stream/Instanz/OtherRecord
  5514.   #define if_recordp(obj,statement1,statement2)  \
  5515.     { switch (typecode(obj))              \
  5516.         { case_record: statement1; break; \
  5517.           default: statement2; break;     \
  5518.     }   }
  5519.   #define if_mrecordp(obj,statement1,statement2)  \
  5520.     { switch (mtypecode(obj))             \
  5521.         { case_record: statement1; break; \
  5522.           default: statement2; break;     \
  5523.     }   }
  5524.  
  5525. # Test auf Closure
  5526.   #define closurep(obj)  (typecode(obj)==closure_type)
  5527.   #define mclosurep(obj)  (mtypecode(obj)==closure_type)
  5528.  
  5529. # Test auf compilierte Closure
  5530.   # In einer Closure ist die zweite Komponente
  5531.   # entweder eine Liste (der Lambdabody bei interpretierten Closures)
  5532.   # oder ein Simple-Bit-Vector (der Codevektor bei compilierten Closures).
  5533.   #define cclosurep(obj)  \
  5534.     (closurep(obj) && m_simple_bit_vector_p(TheClosure(obj)->clos_codevec))
  5535.  
  5536. # Test auf generische Funktion, obj sollte eine Variable sein
  5537.   #define genericfunctionp(obj)  \
  5538.     (cclosurep(obj)                                                         \
  5539.      && (TheSbvector(TheClosure(obj)->clos_codevec)->data[CCHD+4] & bit(4)) \
  5540.     )
  5541.  
  5542. # Test auf CLOS-Instanz
  5543.   #define instancep(obj)  (typecode(obj)==instance_type)
  5544.   #define minstancep(obj)  (mtypecode(obj)==instance_type)
  5545.  
  5546. # Test auf CLOS-Klasse, obj sollte eine Variable sein.
  5547. # Unser CLOS implementiert alle Klassen als Instanzen einer direkten
  5548. # Unterklasse von <class>.
  5549.   #define classp(obj)  \
  5550.     (structurep(obj)                                                         \
  5551.      && eq(Cdr(TheStructure(obj)->structure_types),O(class_structure_types)) \
  5552.     )
  5553.  
  5554. # Test auf Structure, obj sollte eine Variable sein??
  5555.   #ifdef case_structure
  5556.     #define structurep(obj)  (typecode(obj)==structure_type)
  5557.     #define mstructurep(obj)  (mtypecode(obj)==structure_type)
  5558.   #else
  5559.     #define structurep(obj)  \
  5560.       (orecordp(obj) && (TheRecord(obj)->rectype == Rectype_Structure))
  5561.     #define mstructurep(obj)  \
  5562.       (morecordp(obj) && (TheRecord(obj)->rectype == Rectype_Structure))
  5563.   #endif
  5564.  
  5565. # Test auf Stream, obj sollte eine Variable sein??
  5566.   #ifdef case_stream
  5567.     #define streamp(obj)  (typecode(obj)==stream_type)
  5568.     #define mstreamp(obj)  (mtypecode(obj)==stream_type)
  5569.   #else
  5570.     #define streamp(obj)  \
  5571.       (orecordp(obj) && (TheRecord(obj)->rectype == Rectype_Stream))
  5572.     #define mstreamp(obj)  \
  5573.       (morecordp(obj) && (TheRecord(obj)->rectype == Rectype_Stream))
  5574.   #endif
  5575.   #define sym_streamp(sym) mtypecode(Symbol_symvalue(sym))
  5576.  
  5577. # Test, ob ein Stream vom Typ gebufferter File-Stream ist:
  5578.   #define if_strm_bfile_p(strm,statement1,statement2)  \
  5579.     switchu (TheStream(strm)->strmtype) \
  5580.       { case strmtype_sch_file:        \
  5581.         case strmtype_ch_file:         \
  5582.         case strmtype_iu_file:         \
  5583.         case strmtype_is_file:         \
  5584.           statement1; break;           \
  5585.         default:                       \
  5586.           statement2; break;           \
  5587.       }
  5588. # wird verwendet von STREAM
  5589.  
  5590. # Test, ob ein Stream vom Typ File-Stream ist:
  5591.   #ifdef HANDLES
  5592.     #define case_strmtype_file  \
  5593.       case strmtype_sch_file:   \
  5594.       case strmtype_ch_file:    \
  5595.       case strmtype_iu_file:    \
  5596.       case strmtype_is_file:    \
  5597.       case strmtype_handle
  5598.   #else
  5599.     #define case_strmtype_file  \
  5600.       case strmtype_sch_file:   \
  5601.       case strmtype_ch_file:    \
  5602.       case strmtype_iu_file:    \
  5603.       case strmtype_is_file
  5604.   #endif
  5605.   #define if_strm_file_p(strm,statement1,statement2)  \
  5606.     switchu (TheStream(strm)->strmtype) \
  5607.       { case_strmtype_file:             \
  5608.           statement1; break;            \
  5609.         default:                        \
  5610.           statement2; break;            \
  5611.       }
  5612. # wird verwendet von PATHNAME
  5613.  
  5614. # Test auf Other-Record
  5615.   #define orecordp(obj)  (typecode(obj)==orecord_type)
  5616.   #define morecordp(obj)  (mtypecode(obj)==orecord_type)
  5617.   #define sym_orecordp(sym) (morecordp(Symbol_symvalue(sym)))
  5618.  
  5619. # Test auf Package, obj sollte eine Variable sein
  5620.   #define packagep(obj)  \
  5621.     (orecordp(obj) && (TheRecord(obj)->rectype == Rectype_Package))
  5622.  
  5623. # Test auf Hash-Table, obj sollte eine Variable sein
  5624.   #define hash_table_p(obj)  \
  5625.     (orecordp(obj) && (TheRecord(obj)->rectype == Rectype_Hashtable))
  5626.  
  5627. # Test auf Readtable, obj sollte eine Variable sein
  5628.   #define readtablep(obj)  \
  5629.     (orecordp(obj) && (TheRecord(obj)->rectype == Rectype_Readtable))
  5630.   #define mreadtablep(obj) \
  5631.     (morecordp(obj) && (TheRecord(obj)->rectype == Rectype_Readtable))
  5632.   #define sym_readtablep(sym) mreadtablep(Symbol_symvalue(sym))
  5633.  
  5634. # Test auf Pathname, obj sollte eine Variable sein
  5635.   #define pathnamep(obj)  \
  5636.     (orecordp(obj) && (TheRecord(obj)->rectype == Rectype_Pathname))
  5637.  
  5638. # Test auf Logical Pathname, obj sollte eine Variable sein
  5639. #ifdef LOGICAL_PATHNAMES
  5640.   #define logpathnamep(obj)  \
  5641.     (orecordp(obj) && (TheRecord(obj)->rectype == Rectype_Logpathname))
  5642. #else
  5643.   #define logpathnamep(obj)  FALSE
  5644. #endif
  5645.  
  5646. # Test auf Extended Pathname (d.h. Pathname oder Logical Pathname),
  5647. # obj sollte eine Variable sein
  5648. # define xpathnamep(obj)  (pathnamep(obj) || logpathnamep(obj))
  5649. #ifdef LOGICAL_PATHNAMES
  5650.   #define xpathnamep(obj)  \
  5651.     (orecordp(obj)                                           \
  5652.      && ((TheRecord(obj)->rectype == Rectype_Pathname)       \
  5653.          || (TheRecord(obj)->rectype == Rectype_Logpathname) \
  5654.     )   )
  5655. #else
  5656.   #define xpathnamep(obj)  pathnamep(obj)
  5657. #endif
  5658.  
  5659. # Test auf Random-State, obj sollte eine Variable sein
  5660.   #define random_state_p(obj)  \
  5661.     (orecordp(obj) && (TheRecord(obj)->rectype == Rectype_Random_State))
  5662.  
  5663. # Test auf Byte, obj sollte eine Variable sein
  5664.   #define bytep(obj)  \
  5665.     (orecordp(obj) && (TheRecord(obj)->rectype == Rectype_Byte))
  5666.  
  5667. # Test auf Fsubr, obj sollte eine Variable sein
  5668.   #define fsubrp(obj)  \
  5669.     (orecordp(obj) && (TheRecord(obj)->rectype == Rectype_Fsubr))
  5670.  
  5671. # Test auf Loadtimeeval, obj sollte eine Variable sein
  5672.   #define loadtimeevalp(obj)  \
  5673.     (orecordp(obj) && (TheRecord(obj)->rectype == Rectype_Loadtimeeval))
  5674.  
  5675. # Test auf Symbolmacro, obj sollte eine Variable sein
  5676.   #define symbolmacrop(obj)  \
  5677.     (orecordp(obj) && (TheRecord(obj)->rectype == Rectype_Symbolmacro))
  5678.   #define msymbolmacrop(obj) \
  5679.     (morecordp(obj) && (TheRecord(obj)->rectype == Rectype_Symbolmacro))
  5680.   #define sym_symbolmacrop(sym) msymbolmacrop(Symbol_symvalue(sym))
  5681.     
  5682. # Test auf Fpointer, obj sollte eine Variable sein
  5683.   #define fpointerp(obj)  \
  5684.     (orecordp(obj) && (TheRecord(obj)->rectype == Rectype_Fpointer))
  5685.  
  5686. # Test auf Faddress, obj sollte eine Variable sein
  5687.   #define faddressp(obj)  \
  5688.     (orecordp(obj) && (TheRecord(obj)->rectype == Rectype_Faddress))
  5689.  
  5690. # Test auf Fvariable, obj sollte eine Variable sein
  5691.   #define fvariablep(obj)  \
  5692.     (orecordp(obj) && (TheRecord(obj)->rectype == Rectype_Fvariable))
  5693.  
  5694. # Test auf Ffunction, obj sollte eine Variable sein
  5695. #ifdef DYNAMIC_FFI
  5696.   #define ffunctionp(obj)  \
  5697.     (orecordp(obj) && (TheRecord(obj)->rectype == Rectype_Ffunction))
  5698. #else
  5699.   #define ffunctionp(obj)  ((obj), 0)
  5700. #endif
  5701.  
  5702. #ifdef SOCKET_STREAMS
  5703.   #define socket_server_p(obj)  \
  5704.       (orecordp(obj) && (TheRecord(obj)->rectype == Rectype_Socket_Server))
  5705. #endif
  5706.  
  5707. #ifdef YET_ANOTHER_RECORD
  5708. # Test auf Yetanother, obj sollte eine Variable sein
  5709.   #define yetanotherp(obj)  \
  5710.     (orecordp(obj) && (TheRecord(obj)->rectype == Rectype_Yetanother))
  5711. #endif
  5712.  
  5713. # Test auf Character
  5714.   #define charp(obj)  (typecode(obj)==char_type)
  5715.   #define mcharp(obj)  (mtypecode(obj)==char_type)
  5716.  
  5717. # Test auf String-Char
  5718.   #define string_char_p(obj)  \
  5719.     ((as_oint(obj) & ~(((oint)char_code_mask_c)<<oint_data_shift)) == type_zero_oint(char_type))
  5720.  
  5721. # Test auf SUBR (compiliertes funktionales Objekt)
  5722.   #define subrp(obj)  (typecode(obj)==subr_type)
  5723.   #define msubrp(obj)  (mtypecode(obj)==subr_type)
  5724.  
  5725. # Test auf STACK-Environment-Pointer
  5726.   #define stack_env_p(obj)  (typecode(obj)==system_type) # andere Fälle??
  5727.  
  5728. # Test auf Systeminterne Konstante
  5729.   #define systemp(obj)  (typecode(obj)==system_type) # andere Fälle??
  5730.  
  5731. # Test auf reelle Zahl
  5732.   #define if_realp(obj,statement1,statement2)  \
  5733.     {var reg1 object obj_from_if_realp = (obj);                      \
  5734.      var reg1 tint type_from_if_realp = typecode(obj_from_if_realp); \
  5735.      if ( (type_from_if_realp & bit(number_bit_t))                   \
  5736.           && !(type_from_if_realp==complex_type) )                   \
  5737.        { statement1 } else { statement2 }                            \
  5738.     }
  5739.  
  5740. # Test auf rationale Zahl
  5741.   #define if_rationalp(obj,statement1,statement2)  \
  5742.     {var reg1 object obj_from_if_rationalp = (obj);                          \
  5743.      var reg1 tint type_from_if_rationalp = typecode(obj_from_if_rationalp); \
  5744.      if ( (!(type_from_if_rationalp==complex_type))                          \
  5745.           &&                                                                 \
  5746.           ((type_from_if_rationalp &                                         \
  5747.             ~((fixnum_type|bignum_type|ratio_type|bit(sign_bit_t)) & ~fixnum_type) \
  5748.            ) == fixnum_type                                                  \
  5749.         ) )                                                                  \
  5750.        { statement1 } else { statement2 }                                    \
  5751.     }
  5752.  
  5753. # Test auf ganze Zahl
  5754.   #define integerp(obj)  \
  5755.     ((typecode(obj) &                                             \
  5756.       ~((fixnum_type|bignum_type|bit(sign_bit_t)) & ~fixnum_type) \
  5757.      ) == fixnum_type                                             \
  5758.     )
  5759.   #define mintegerp(obj)  \
  5760.     ((mtypecode(obj) &                                            \
  5761.       ~((fixnum_type|bignum_type|bit(sign_bit_t)) & ~fixnum_type) \
  5762.      ) == fixnum_type                                             \
  5763.     )
  5764.  
  5765. # Test auf Fixnum
  5766.   #define fixnump(obj)  ((typecode(obj) & ~bit(sign_bit_t)) == fixnum_type)
  5767.   #define mfixnump(obj)  ((mtypecode(obj) & ~bit(sign_bit_t)) == fixnum_type)
  5768.  
  5769. # Test auf Fixnum >=0
  5770.   #define posfixnump(obj)  (typecode(obj) == fixnum_type)
  5771.   #define mposfixnump(obj)  (mtypecode(obj) == fixnum_type)
  5772.   #define sym_posfixnump(sym) mposfixnump(Symbol_symvalue(sym))
  5773.  
  5774. # Test auf Bignum
  5775.   #define bignump(obj)  ((typecode(obj) & ~bit(sign_bit_t)) == bignum_type)
  5776.   #define mbignump(obj)  ((mtypecode(obj) & ~bit(sign_bit_t)) == bignum_type)
  5777.  
  5778. # Test auf Ratio
  5779.   #define ratiop(obj)  ((typecode(obj) & ~bit(sign_bit_t)) == ratio_type)
  5780.   #define mratiop(obj)  ((mtypecode(obj) & ~bit(sign_bit_t)) == ratio_type)
  5781.  
  5782. # Test auf Float
  5783.   #define floatp(obj)  \
  5784.     ((typecode(obj) &  \
  5785.      ~((sfloat_type|ffloat_type|dfloat_type|lfloat_type|bit(sign_bit_t)) & ~sfloat_type) \
  5786.      ) == sfloat_type)
  5787.   #define mfloatp(obj)  \
  5788.     ((mtypecode(obj) &  \
  5789.      ~((sfloat_type|ffloat_type|dfloat_type|lfloat_type|bit(sign_bit_t)) & ~sfloat_type) \
  5790.      ) == sfloat_type)
  5791.  
  5792. # Test auf Short-Float
  5793.   #define short_float_p(obj)  ((typecode(obj) & ~bit(sign_bit_t)) == sfloat_type)
  5794.   #define m_short_float_p(obj)  ((mtypecode(obj) & ~bit(sign_bit_t)) == sfloat_type)
  5795.  
  5796. # Test auf Single-Float
  5797.   #define single_float_p(obj)  ((typecode(obj) & ~bit(sign_bit_t)) == ffloat_type)
  5798.   #define m_single_float_p(obj)  ((mtypecode(obj) & ~bit(sign_bit_t)) == ffloat_type)
  5799.  
  5800. # Test auf Double-Float
  5801.   #define double_float_p(obj)  ((typecode(obj) & ~bit(sign_bit_t)) == dfloat_type)
  5802.   #define m_double_float_p(obj)  ((mtypecode(obj) & ~bit(sign_bit_t)) == dfloat_type)
  5803.  
  5804. # Test auf Long-Float
  5805.   #define long_float_p(obj)  ((typecode(obj) & ~bit(sign_bit_t)) == lfloat_type)
  5806.   #define m_long_float_p(obj)  ((mtypecode(obj) & ~bit(sign_bit_t)) == lfloat_type)
  5807.  
  5808. # Test auf Complex
  5809.   #define complexp(obj)  (typecode(obj) == complex_type)
  5810.   #define mcomplexp(obj)  (mtypecode(obj) == complex_type)
  5811.  
  5812. # Test einer reellen Zahl, ob sie >=0 ist:
  5813.   # define positivep(obj)  ((as_oint(obj) & wbit(sign_bit_o)) == 0)
  5814.   #define positivep(obj)  (!wbit_test(as_oint(obj),sign_bit_o))
  5815.   #ifdef fast_mtypecode
  5816.     #ifdef WIDE_STRUCT
  5817.       #undef positivep
  5818.       #define positivep(obj)  ((typecode(obj) & bit(sign_bit_t)) == 0)
  5819.     #endif
  5820.     #define mpositivep(obj)  ((mtypecode(obj) & bit(sign_bit_t)) == 0)
  5821.   #else
  5822.     #define mpositivep(obj)  positivep(obj)
  5823.   #endif
  5824.  
  5825. # ################# Deklarationen zur Arithmetik ########################## #
  5826.  
  5827.  
  5828. # Typenhierarchie:
  5829. # Number (N) =
  5830. #    Real (R) =
  5831. #       Float (F) =
  5832. #          Short float (SF)
  5833. #          Single float (FF)
  5834. #          Double float (DF)
  5835. #          Long float (LF)
  5836. #       Rational (RA) =
  5837. #          Integer (I) =
  5838. #             Fixnum (FN)
  5839. #             Bignum (BN)
  5840. #          Ratio (RT)
  5841. #    Complex (C)
  5842.  
  5843.  
  5844. # Typfeld:
  5845. # Bits zum Testen, ob dieser Typ vorliegt (Bit gesetzt, wenn ja).
  5846. # _bit_t zum Test im Typbyte (tint)
  5847. # _bit_o zum Test im Objekt (oint)
  5848.  
  5849. # siehe oben:
  5850. # #define number_bit_t     4  # gesetzt nur bei Zahlen
  5851. # #define number_bit_o     (number_bit_t+oint_type_shift)    # gesetzt nur bei Zahlen
  5852.  
  5853. # float_bit:
  5854. # in einer Zahl: Bit gesetzt, falls es sich um ein Float handelt.
  5855. #                Bit gelöscht, falls es sich um eine rationale oder komplexe Zahl handelt.
  5856. # #define float_bit_t      1
  5857. # #define float_bit_o      (float_bit_t+oint_type_shift)
  5858.  
  5859. # float1_bit:
  5860. # In einem Floating-point: entscheidet genauer:
  5861. # Float-Bit   1 2
  5862. #             0 0    Short Float (SF)
  5863. #             0 1    Single Float (FF)
  5864. #             1 0    Double Float (DF)
  5865. #             1 1    Long Float (LF)
  5866. # #define float1_bit_t     3
  5867. # #define float1_bit_o     (float1_bit_t+oint_type_shift)
  5868. # #define float2_bit_t     2
  5869. # #define float2_bit_o     (float2_bit_t+oint_type_shift)
  5870.  
  5871. # ratio_bit:
  5872. # In rationalen Zahlen: Bit gesetzt, falls es sich um einen echten Bruch hand.
  5873. #                       Bit gelöscht, falls es sich um ein Integer handelt.
  5874. # #define ratio_bit_t      3
  5875. # #define ratio_bit_o      (ratio_bit_t+oint_type_shift)
  5876.  
  5877. # bignum_bit:
  5878. # In ganzen Zahlen: Bit gesetzt, falls es sich um ein Bignum handelt.
  5879. #                   Bit gelöscht, falls es sich um ein Fixnum handelt.
  5880. # #define bignum_bit_t     2
  5881. # #define bignum_bit_o     (bignum_bit_t+oint_type_shift)
  5882.  
  5883. # vorz_bit:
  5884. # Bei Reals:
  5885. # gibt das Vorzeichen der Zahl an.
  5886. # Bit gesetzt, falls Zahl < 0,
  5887. # Bit gelöscht, falls Zahl >=0.
  5888.   #define vorz_bit_t       sign_bit_t
  5889.                            # sollte = 0 sein, damit das Vorzeichen-Extend
  5890.                            # bei Fixnums einfacher geht.
  5891.   #define vorz_bit_o       (vorz_bit_t+oint_type_shift)
  5892.  
  5893. # Liefert das Vorzeichen einer reellen Zahl (0 falls >=0, -1 falls <0)
  5894.   #if (vorz_bit_o<32) && !defined(WIDE_STRUCT)
  5895.     #define R_sign(obj)  ((signean)sign_of_sint32( (sint32)((uint32)as_oint(obj) << (31-vorz_bit_o)) ))
  5896.   #else
  5897.     # define R_sign(obj)  ((signean)sign_of_sint32( (sint32)(uint32)(as_oint(obj) >> (vorz_bit_o-31)) ))
  5898.     #define R_sign(obj)  ((signean)sign_of_sint32( (sint32)((uint32)typecode(obj) << (31-vorz_bit_t)) ))
  5899.   #endif
  5900.  
  5901. # Stellt fest, ob zwei reelle Zahlen dasselbe Vorzeichen haben:
  5902.   #define same_sign_p(obj1,obj2)  \
  5903.     (wbit_test(as_oint(obj1)^as_oint(obj2),vorz_bit_o)==0)
  5904.  
  5905.  
  5906. # Typtestmacros:
  5907. # (Liefern /=0, falls erfüllt. Präfix 'm', wenn Argument im Speicher sitzt.)
  5908.  
  5909. # Testet ein Objekt, ob es eine Zahl ist: (siehe oben)
  5910.   # define numberp(obj)  (as_oint(obj) & wbit(number_bit_o))
  5911.   # define mnumberp(obj)  (mtypecode(obj) & bit(number_bit_t))
  5912.  
  5913. # Testet eine Zahl, ob es ein Float ist.
  5914.   # define N_floatp(obj)  (as_oint(obj) & wbit(float_bit_o))
  5915.   #define N_floatp(obj)  (wbit_test(as_oint(obj),float_bit_o))
  5916.   #define N_mfloatp(obj)  (mtypecode(obj) & bit(float_bit_t))
  5917.  
  5918. # Testet eine Zahl, ob es ein Integer ist.
  5919.   #define N_integerp(obj)  (!( as_oint(obj) & (wbit(float_bit_o)|wbit(ratio_bit_o)) ))
  5920.   #define N_mintegerp(obj)  (!( mtypecode(obj) & (bit(float_bit_t)|bit(ratio_bit_t)) ))
  5921.  
  5922. # Testet eine reelle Zahl, ob sie rational ist.
  5923.   # define R_rationalp(obj)  (!( as_oint(obj) & wbit(float_bit_o) ))
  5924.   #define R_rationalp(obj)  (!wbit_test(as_oint(obj),float_bit_o))
  5925.   #define R_mrationalp(obj)  (!( mtypecode(obj) & bit(float_bit_t) ))
  5926.  
  5927. # Testet eine reelle Zahl, ob sie ein Float ist.
  5928.   # define R_floatp(obj)  ( as_oint(obj) & wbit(float_bit_o) )
  5929.   #define R_floatp(obj)  (wbit_test(as_oint(obj),float_bit_o))
  5930.   #define R_mfloatp(obj)  ( mtypecode(obj) & bit(float_bit_t) )
  5931.  
  5932. # Testet eine reelle Zahl, ob sie <0 ist.
  5933.   # define R_minusp(obj)  ( as_oint(obj) & wbit(vorz_bit_o) )
  5934.   #define R_minusp(obj)  (wbit_test(as_oint(obj),vorz_bit_o))
  5935.   #define R_mminusp(obj)  ( mtypecode(obj) & bit(vorz_bit_t) )
  5936.  
  5937. # Testet eine rationale Zahl, ob sie ganz ist.
  5938.   # define RA_integerp(obj)  (!( as_oint(obj) & wbit(ratio_bit_o) ))
  5939.   #define RA_integerp(obj)  (!wbit_test(as_oint(obj),ratio_bit_o))
  5940.   #define RA_mintegerp(obj)  (!( mtypecode(obj) & bit(ratio_bit_t) ))
  5941.  
  5942. # Testet eine rationale Zahl, ob sie gebrochen ist.
  5943.   # define RA_ratiop(obj)  ( as_oint(obj) & wbit(ratio_bit_o) )
  5944.   #define RA_ratiop(obj)  (wbit_test(as_oint(obj),ratio_bit_o))
  5945.   #define RA_mratiop(obj)  ( mtypecode(obj) & bit(ratio_bit_t) )
  5946.  
  5947. # Testet eine ganze Zahl, ob sie ein Bignum ist.
  5948.   # define I_bignump(obj)  ( as_oint(obj) & wbit(bignum_bit_o) )
  5949.   #define I_bignump(obj)  (wbit_test(as_oint(obj),bignum_bit_o))
  5950.   #define I_mbignump(obj)  ( mtypecode(obj) & bit(bignum_bit_t) )
  5951.  
  5952. # Testet eine ganze Zahl, ob sie ein Fixnum ist.
  5953.   # define I_fixnump(obj)  (!( as_oint(obj) & wbit(bignum_bit_o) ))
  5954.   #define I_fixnump(obj)  (!wbit_test(as_oint(obj),bignum_bit_o))
  5955.   #define I_mfixnump(obj)  (!( mtypecode(obj) & bit(bignum_bit_t) ))
  5956.  
  5957. # Testet eine Zahl, ob sie eine reelle Zahl ist.
  5958.   #define N_realp(obj)  (!( typecode(obj) == complex_type ))
  5959.   #define N_mrealp(obj)  (!( mtypecode(obj) == complex_type ))
  5960.  
  5961. # Testet eine Zahl, ob sie eine komplexe Zahl ist.
  5962.   #define N_complexp(obj)  ( typecode(obj) == complex_type )
  5963.   #define N_mcomplexp(obj)  ( mtypecode(obj) == complex_type )
  5964.  
  5965. # Test auf ein Integer eines vorgegebenen Bereiches.
  5966. # obj sollte eine Variable sein
  5967.   #define uint8_p(obj)  \
  5968.     ((as_oint(obj) & ~((oint)0xFF << oint_data_shift)) == as_oint(Fixnum_0))
  5969.   #define sint8_p(obj)  \
  5970.     (((as_oint(obj) ^ (positivep(obj) ? 0 : as_oint(Fixnum_minus1)^as_oint(Fixnum_0))) & ~((oint)0x7F << oint_data_shift)) == as_oint(Fixnum_0))
  5971.   #define uint16_p(obj)  \
  5972.     ((as_oint(obj) & ~((oint)0xFFFF << oint_data_shift)) == as_oint(Fixnum_0))
  5973.   #define sint16_p(obj)  \
  5974.     (((as_oint(obj) ^ (positivep(obj) ? 0 : as_oint(Fixnum_minus1)^as_oint(Fixnum_0))) & ~((oint)0x7FFF << oint_data_shift)) == as_oint(Fixnum_0))
  5975.   #if (oint_data_len>=32)
  5976.     #define uint32_p(obj)  \
  5977.       ((as_oint(obj) & ~((oint)0xFFFFFFFFUL << oint_data_shift)) == as_oint(Fixnum_0))
  5978.   #else
  5979.     #define uint32_p(obj)  \
  5980.       ((typecode(obj)==fixnum_type) \
  5981.        || ((typecode(obj)==bignum_type) \
  5982.            && (TheBignum(obj)->length <= ceiling(33,intDsize)) \
  5983.            && ((TheBignum(obj)->length < ceiling(33,intDsize)) \
  5984.                || (TheBignum(obj)->data[0] < (uintD)bit(32%intDsize)) \
  5985.       )   )   )
  5986.   #endif
  5987.   #if (oint_data_len>=31)
  5988.     #define sint32_p(obj)  \
  5989.       (((as_oint(obj) ^ (positivep(obj) ? 0 : as_oint(Fixnum_minus1)^as_oint(Fixnum_0))) & ~((oint)0x7FFFFFFFUL << oint_data_shift)) == as_oint(Fixnum_0))
  5990.   #else
  5991.     #define sint32_p(obj)  \
  5992.       (((typecode(obj) & ~bit(sign_bit_t)) == fixnum_type) \
  5993.        || (((typecode(obj) & ~bit(sign_bit_t)) == bignum_type) \
  5994.            && (TheBignum(obj)->length <= ceiling(32,intDsize)) \
  5995.            && ((TheBignum(obj)->length < ceiling(32,intDsize)) \
  5996.                || ((TheBignum(obj)->data[0] ^ (positivep(obj) ? (uintD)0 : ~(uintD)0)) < (uintD)bit(31%intDsize)) \
  5997.       )   )   )
  5998.   #endif
  5999.   #define uint64_p(obj)  \
  6000.     ((typecode(obj)==fixnum_type) \
  6001.      || ((typecode(obj)==bignum_type) \
  6002.          && (TheBignum(obj)->length <= ceiling(65,intDsize)) \
  6003.          && ((TheBignum(obj)->length < ceiling(65,intDsize)) \
  6004.              || (TheBignum(obj)->data[0] < (uintD)bit(64%intDsize)) \
  6005.     )   )   )
  6006.   #define sint64_p(obj)  \
  6007.     (((typecode(obj) & ~bit(sign_bit_t)) == fixnum_type) \
  6008.      || (((typecode(obj) & ~bit(sign_bit_t)) == bignum_type) \
  6009.          && (TheBignum(obj)->length <= ceiling(64,intDsize)) \
  6010.          && ((TheBignum(obj)->length < ceiling(64,intDsize)) \
  6011.              || ((TheBignum(obj)->data[0] ^ (positivep(obj) ? (uintD)0 : ~(uintD)0)) < (uintD)bit(63%intDsize)) \
  6012.     )   )   )
  6013.   #if (int_bitsize==16)
  6014.     #define uint_p  uint16_p
  6015.     #define sint_p  sint16_p
  6016.   #else # (int_bitsize==32)
  6017.     #define uint_p  uint32_p
  6018.     #define sint_p  sint32_p
  6019.   #endif
  6020.   #if (long_bitsize==32)
  6021.     #define ulong_p  uint32_p
  6022.     #define slong_p  sint32_p
  6023.   #else # (long_bitsize==64)
  6024.     #define ulong_p  uint64_p
  6025.     #define slong_p  sint64_p
  6026.   #endif
  6027.  
  6028.  
  6029. # ####################### TIMEBIBL zu TIME.D ############################## #
  6030.  
  6031. # Typ, der für 'Internal Time' verwendet wird:
  6032. #ifdef TIME_1
  6033.   typedef uintL internal_time;      # abgegriffener Wert des Tick-Zählers
  6034.   #ifdef TIME_AMIGAOS
  6035.     #define ticks_per_second  50UL    # 1 Tick = 1/50 sec, 50Hz-Zähler
  6036.   #endif
  6037.   #ifdef TIME_MSDOS
  6038.     #define ticks_per_second  100UL   # 1 Tick = 1/100 sec, 100Hz-Zähler
  6039.   #endif
  6040.   #if defined(TIME_UNIX_TIMES) || defined(TIME_RISCOS)
  6041.     #define ticks_per_second  CLK_TCK
  6042.   #endif
  6043.   #define sub_internal_time(x,y, z)  z = (x) - (y)
  6044.   #define add_internal_time(x,y, z)  z = (x) + (y)
  6045. #endif
  6046. #ifdef TIME_2
  6047.   #if defined(TIME_UNIX) || defined(TIME_WIN32)
  6048.     typedef struct { uintL tv_sec;    # ganze Sekunden seit 1.1.1970 00:00 GMT,
  6049.                                       # Ein 'uintL' für tv_sec reicht für 136 Jahre.
  6050.                      uintL tv_usec;   # zusätzliche Mikrosekunden
  6051.                    }
  6052.             internal_time;
  6053.     #define ticks_per_second  1000000UL  # 1 Tick = 1 µsec
  6054.   #endif
  6055.   #define sub_internal_time(x,y, z)  # z:=x-y  \
  6056.     { (z).tv_sec = (x).tv_sec - (y).tv_sec;                   \
  6057.       if ((x).tv_usec < (y).tv_usec)                          \
  6058.         { (x).tv_usec += ticks_per_second; (z).tv_sec -= 1; } \
  6059.       (z).tv_usec = (x).tv_usec - (y).tv_usec;                \
  6060.     }
  6061.   #define add_internal_time(x,y, z)  # z:=x+y  \
  6062.     { (z).tv_sec = (x).tv_sec + (y).tv_sec;                   \
  6063.       (z).tv_usec = (x).tv_usec + (y).tv_usec;                \
  6064.       if ((z).tv_usec >= ticks_per_second)                    \
  6065.         { (z).tv_usec -= ticks_per_second; (z).tv_sec += 1; } \
  6066.     }
  6067. #endif
  6068.  
  6069. #ifndef HAVE_RUN_TIME
  6070.  
  6071. # UP: Hält die Run-Time-Stoppuhr an
  6072. # run_time_stop();
  6073.   extern void run_time_stop (void);
  6074. # wird verwendet von STREAM
  6075.  
  6076. # UP: Läßt die Run-Time-Stoppuhr weiterlaufen
  6077. # run_time_restart();
  6078.   extern void run_time_restart (void);
  6079. # wird verwendet von STREAM
  6080.  
  6081. #else
  6082.  
  6083. # Man braucht keine Run-Time-Stoppuhr
  6084.   #define run_time_stop()
  6085.   #define run_time_restart()
  6086.  
  6087. #endif
  6088.  
  6089. #ifdef TIME_1
  6090.  
  6091. # UP: Liefert die Real-Time
  6092. # get_real_time()
  6093. # < uintL ergebnis: Zeit seit LISP-System-Start (in 1/200 sec bzw. in 1/50 sec bzw. in 1/100 sec bzw. in 1/CLK_TCK sec)
  6094.   extern uintL get_real_time (void);
  6095. # wird verwendet von STREAM, LISPARIT
  6096.  
  6097. #endif
  6098.  
  6099. #ifdef TIME_2
  6100.  
  6101. # UP: Liefert die Real-Time
  6102. # get_real_time()
  6103. # < internal_time* ergebnis: absolute Zeit
  6104.   extern internal_time* get_real_time (void);
  6105. # wird verwendet von LISPARIT
  6106.  
  6107. #endif
  6108.  
  6109. # UP: Liefert die Run-Time
  6110. # get_running_times(×core);
  6111. # < timescore.runtime:  Run-Time seit LISP-System-Start (in Ticks)
  6112. # < timescore.realtime: Real-Time seit LISP-System-Start (in Ticks)
  6113. # < timescore.gctime:   GC-Time seit LISP-System-Start (in Ticks)
  6114. # < timescore.gccount:  Anzahl der GC's seit LISP-System-Start
  6115. # < timescore.gcfreed:  Größe des von den GC's bisher wiederbeschafften Platzes
  6116.   typedef struct { internal_time runtime;
  6117.                    internal_time realtime;
  6118.                    internal_time gctime;
  6119.                    uintL gccount;
  6120.                    uintL2 gcfreed; }
  6121.           timescore;
  6122.   extern void get_running_times (timescore*);
  6123. # wird verwendet von
  6124.  
  6125. # UP: Liefert die Run-Time
  6126. # get_running_time(runtime);
  6127. # < runtime: Run-Time (in Ticks)
  6128.   #ifndef HAVE_RUN_TIME
  6129.     #define get_running_time(runtime)  runtime = get_time()
  6130.     extern uintL get_time (void);
  6131.   #endif
  6132.   #if defined(TIME_UNIX) || defined(TIME_UNIX_TIMES) || defined(TIME_WIN32)
  6133.     #define get_running_time(runtime)  get_run_time(&runtime)
  6134.     #ifdef TIME_UNIX
  6135.       extern void get_run_time (internal_time* runtime);
  6136.     #endif
  6137.     #ifdef TIME_UNIX_TIMES
  6138.       extern uintL get_run_time (internal_time* runtime);
  6139.     #endif
  6140.     #ifdef TIME_WIN32
  6141.       extern void get_run_time (internal_time* runtime);
  6142.     #endif
  6143.   #endif
  6144. # wird verwendet von SPVW
  6145.  
  6146. # Zeitangabe in Decoded-Time:
  6147.   typedef struct { object Sekunden, Minuten, Stunden, Tag, Monat, Jahr; }
  6148.           decoded_time;
  6149.  
  6150. #if defined(MSDOS)
  6151. # UP: Wandelt das Zeitformat in Decoded-Time um.
  6152. # convert_time(time,date,&timepoint);
  6153. # > uintW time: Uhrzeit
  6154. #         Als Word: Bits 15..11: Stunde in {0,...,23},
  6155. #                   Bits 10..5:  Minute in {0,...,59},
  6156. #                   Bits 4..0:   Sekunde/2 in {0,...,29}.
  6157. # > uintW date: Datum
  6158. #         Als Word: Bits 15..9: Jahr-1980 in {0,...,119},
  6159. #                   Bits 8..5:  Monat in {1,...,12},
  6160. #                   Bits 4..0:  Tag in {1,...,31}.
  6161. # < timepoint.Sekunden, timepoint.Minuten, timepoint.Stunden,
  6162. #   timepoint.Tag, timepoint.Monat, timepoint.Jahr, jeweils als Fixnums
  6163.   extern void convert_timedate (uintW time, uintW date, decoded_time* timepoint);
  6164. # wird verwendet von PATHNAME
  6165. #endif
  6166. #ifdef AMIGAOS
  6167. # UP: Wandelt das Amiga-Zeitformat in Decoded-Time um.
  6168. # convert_time(&datestamp,&timepoint);
  6169. # > struct DateStamp datestamp: Uhrzeit
  6170. #          datestamp.ds_Days   : Anzahl Tage seit 1.1.1978
  6171. #          datestamp.ds_Minute : Anzahl Minuten seit 00:00 des Tages
  6172. #          datestamp.ds_Tick   : Anzahl Ticks seit Beginn der Minute
  6173. # < timepoint.Sekunden, timepoint.Minuten, timepoint.Stunden,
  6174. #   timepoint.Tag, timepoint.Monat, timepoint.Jahr, jeweils als Fixnums
  6175.   extern void convert_time (struct DateStamp * datestamp, decoded_time* timepoint);
  6176. # wird verwendet von PATHNAME
  6177. #endif
  6178. #if defined(UNIX) || defined(MSDOS) || defined(WIN32_UNIX)
  6179. # UP: Wandelt das System-Zeitformat in Decoded-Time um.
  6180. # convert_time(&time,&timepoint);
  6181. # > time_t time: Zeit im System-Zeitformat
  6182. # < timepoint.Sekunden, timepoint.Minuten, timepoint.Stunden,
  6183. #   timepoint.Tag, timepoint.Monat, timepoint.Jahr, jeweils als Fixnums
  6184.   extern void convert_time (time_t* time, decoded_time* timepoint);
  6185. # wird verwendet von PATHNAME
  6186. #endif
  6187.  
  6188. #ifdef TIME_RELATIVE
  6189.  
  6190. # UP: Merkt sich die Uhrzeit beim LISP-System-Start.
  6191. # set_start_time(&timepoint);
  6192. # > timepoint: Zeit beim LISP-System-Start
  6193. # >   timepoint.Sekunden in {0,...,59},
  6194. # >   timepoint.Minuten in {0,...,59},
  6195. # >   timepoint.Stunden in {0,...,23},
  6196. # >   timepoint.Tag in {1,...,31},
  6197. # >   timepoint.Monat in {1,...,12},
  6198. # >   timepoint.Jahr in {1980,...,2999},
  6199. # >   jeweils als Fixnums.
  6200. # kann GC auslösen
  6201.   extern void set_start_time (decoded_time* timepoint);
  6202. # wird verwendet von SPVW
  6203.  
  6204. #endif
  6205.  
  6206. # UP: Initialisiert die Zeitvariablen beim LISP-System-Start.
  6207. # init_time();
  6208.   extern void init_time (void);
  6209. # wird verwendet von SPVW
  6210.  
  6211.  
  6212. # ####################### SPVWBIBL zu SPVW.D ############################## #
  6213.  
  6214. /*
  6215.                           Die Stacks
  6216.                           ==========
  6217.  
  6218. Es werden zwei Stacks verwendet:
  6219.   - der C-Programmstack (Stackpointer SP = Register A7),
  6220.   - der LISP-Stack (Stackpointer STACK).
  6221. Alle Unterprogrammaufrufe geschehen mittels BSR/JSR über den Programmstack,
  6222. er dient außerdem zur Zwischenspeicherung von Daten, die keine LISP-Objekte
  6223. sind. Der LISP-Stack wird verwendet zur Ablage der Frames und zur Zwischen-
  6224. speicherung von LISP-Objekten.
  6225. Für beide Stacks werden die Wachstumsgrenzen von der Speicherverwaltung
  6226. kontrolliert über folgende Macros:
  6227.   check_SP();             testet den Programmstack gegen Überlauf
  6228.   check_STACK();          testet den LISP-Stack gegen Überlauf
  6229.   get_space_on_STACK(n);  testet, ob noch D0.L Bytes auf dem LISP-Stack frei sind
  6230. Auf dem LISP-Stack dürfen grundsätzlich nur Langwörter abgelegt werden.
  6231. Ist dabei FRAME_BIT gesetzt, so handelt es sich um das untere Ende eines
  6232. Frames; dieses Langwort ist ein Pointer über den Frame, zusammen mit
  6233. einem Frame-Typ-Byte; falls darin SKIP2_BIT gelöscht ist, ist das
  6234. darüberliegende Langwort kein LISP-Objekt.
  6235. Alle anderen Langwörter auf dem LISP-Stack stellen LISP-Objekte dar.
  6236. */
  6237.  
  6238. # Maschinenstack: SP
  6239. # SP() liefert den aktuellen Wert des SP.
  6240. # setSP(adresse); setzt den SP auf einen gegebenen Wert. Extrem gefährlich!
  6241. # FAST_SP definiert, falls SP-Zugriffe schnell sind.
  6242.   #if defined(GNU) && defined(MC680X0) && !defined(NO_ASM)
  6243.     # Zugriff auf eine globale Register"variable" SP
  6244.     #ifdef __REGISTER_PREFIX__ # GNU C Version >= 2.4 hat %/ und __REGISTER_PREFIX__
  6245.       # Aber der Wert von __REGISTER_PREFIX__ ist unbrauchbar, weil wir evtl.
  6246.       # cross-compilieren.
  6247.       #define REGISTER_PREFIX  "%/"
  6248.     #else
  6249.       #define REGISTER_PREFIX  "" # oder "%%", je nach verwendetem Assembler
  6250.     #endif
  6251.     #define SP()  \
  6252.       ({var aint __SP;                                                          \
  6253.         __asm__ __volatile__ ("movel "REGISTER_PREFIX"sp,%0" : "=g" (__SP) : ); \
  6254.         __SP;                                                                   \
  6255.        })
  6256.     #define setSP(adresse)  \
  6257.       ({ __asm__ __volatile__ ("movel %0,"REGISTER_PREFIX"sp" : : "g" ((aint)(adresse)) : "sp" ); })
  6258.     #define FAST_SP
  6259.   #elif defined(GNU) && defined(SPARC)
  6260.     # Zugriff auf eine Register"variable" %sp = %o6
  6261.     register __volatile__ aint __SP __asm__("%sp");
  6262.     #define SP()  __SP
  6263.     # Wir dürfen hier kein setSP() durchführen, ohne zu beachten, daß
  6264.     # 1. %sp ein Alignment von 8 Byte beachten muß,
  6265.     # 2. oberhalb von %sp immer 92 Byte frei bleiben müssen (dorthin kommen
  6266.     #    die Registerinhalte, wenn durch ein 'save' in einem Unterprogramm
  6267.     #    ein 'register window overflow trap' ausgelöst wird).
  6268.   #elif defined(GNU) && defined(HPPA)
  6269.     # Zugriff auf eine Register"variable" %sp = %r30
  6270.     register __volatile__ aint __SP __asm__("%r30");
  6271.     #define SP()  __SP
  6272.   #elif defined(GNU) && defined(MIPS)
  6273.     # Zugriff auf eine Register"variable" $sp = $29
  6274.     #if (__GNUC__ >= 2) # ab GNU-C 2.0
  6275.       #define SP_register "$sp"
  6276.     #else
  6277.       #define SP_register "sp"
  6278.     #endif
  6279.     register __volatile__ aint __SP __asm__(SP_register);
  6280.     #define SP()  __SP
  6281.   #elif defined(GNU) && defined(M88000)
  6282.     # Zugriff auf eine Register"variable" %sp = %r31
  6283.     register __volatile__ aint __SP __asm__("%r31");
  6284.     #define SP()  __SP
  6285.   #elif defined(GNU) && defined(CONVEX)
  6286.     # Zugriff auf eine Register"variable" $sp = $a0
  6287.     register __volatile__ aint __SP __asm__("sp");
  6288.     #define SP()  __SP
  6289.   #elif defined(GNU) && defined(DECALPHA)
  6290.     # Zugriff auf eine Register"variable" $sp = $30
  6291.     register __volatile__ aint __SP __asm__("$30");
  6292.     #define SP()  __SP
  6293.   #elif defined(GNU) && defined(I80Z86) && !defined(NO_ASM)
  6294.     # Zugriff auf eine Register"variable" %esp
  6295.     #define SP()  \
  6296.       ({var aint __SP;                                           \
  6297.         __asm__ __volatile__ ("movl %%esp,%0" : "=g" (__SP) : ); \
  6298.         __SP;                                                    \
  6299.        })
  6300.     #define setSP(adresse)  \
  6301.       ({ __asm__ __volatile__ ("movl %0,%%esp" : : "g" ((aint)(adresse)) : "sp" ); })
  6302.     #define FAST_SP
  6303.   #elif defined(WATCOM) && defined(I80Z86) && !defined(NO_ASM)
  6304.     # Zugriff auf ein Register %esp
  6305.     #define SP  getSP
  6306.     extern void* getSP (void);
  6307.     extern void setSP (void* adresse);
  6308.     #pragma aux  getSP =  0x89 0xe0 /* mov %esp,%eax */  parm value [eax] modify nomemory;
  6309.     #pragma aux  setSP =  0x89 0xc4 /* mov %eax,%esp */  parm caller [eax] modify nomemory [esp];
  6310.     #define FAST_SP
  6311.   #elif defined(MICROSOFT) && defined(I80Z86) && !defined(NO_ASM)
  6312.     #define SP getSP
  6313.     __inline aint getSP() { __asm mov eax,esp }
  6314.     __inline aint setSP(aint address) { __asm mov esp, address }
  6315.   #elif defined(MC680X0) || defined(SPARC) || defined(MIPS) || defined(I80Z86)
  6316.     # Zugriffsfunktionen extern, in Assembler
  6317.     #define SP  getSP
  6318.     extern void* SP (void);
  6319.     extern void setSP (void* adresse);
  6320.   #else
  6321.     # Zugriffsfunktion portabel in C
  6322.     extern void* SP (void);
  6323.   #endif
  6324. #if defined(stack_grows_down) # defined(MC680X0) || defined(I80X86) || defined(SPARC) || defined(MIPS) || defined(M88000) || defined(DECALPHA) || ...
  6325.   #define SP_DOWN # SP wächst nach unten
  6326.   #define SPoffset 0 # top-of-SP ist *(SP+SPoffset)
  6327. #endif
  6328. #if defined(stack_grows_up) # defined(HPPA) || ...
  6329.   #define SP_UP # SP wächst nach oben
  6330.   #define SPoffset -1 # top-of-SP ist *(SP+SPoffset)
  6331. #endif
  6332. #if (defined(SP_DOWN) && defined(SP_UP)) || (!defined(SP_DOWN) && !defined(SP_UP))
  6333.   #error "Unknown SP direction -- SP_DOWN/SP_UP neu einstellen!"
  6334. #endif
  6335. # Darauf aufbauend:
  6336. # SPint  ist der Typ der Elemente auf dem SP, ein Integertyp mindestens so
  6337. #        breit wie uintL und mindestens so breit wie aint bzw. void*.
  6338. # SP_(n) = (n+1)tes Langwort auf dem SP.
  6339. # _SP_(n) = &SP_(n).
  6340. # pushSP(item)  legt ein Langwort auf dem SP ab. Synonym: -(SP).
  6341. # popSP(item=)  liefert item=SP_(0) und nimmt es dabei vom SP herunter.
  6342. # skipSP(n);  nimmt n Langworte vom SP herunter.
  6343.   #if (oint_addr_len <= intLsize)
  6344.     typedef uintL  SPint;
  6345.   #else
  6346.     typedef aint  SPint;
  6347.   #endif
  6348.   #ifdef SP_DOWN
  6349.     #define skipSPop  +=
  6350.     #define SPop      +
  6351.   #endif
  6352.   #ifdef SP_UP
  6353.     #define skipSPop  -=
  6354.     #define SPop      -
  6355.   #endif
  6356.   #define _SP_(n)  (((SPint*)SP()) + SPoffset SPop (uintP)(n))
  6357.   #if !(defined(GNU) && (defined(MC680X0)) && !defined(NO_ASM)) # im allgemeinen
  6358.     #define SP_(n)  (((SPint*)SP())[SPoffset SPop (uintP)(n)])
  6359.     #define skipSP(n)  \
  6360.       {var reg1 SPint* sp = (SPint*)SP(); \
  6361.        sp skipSPop (uintP)(n);            \
  6362.        setSP(sp);                         \
  6363.       }
  6364.     #define pushSP(item)  \
  6365.       {var reg1 SPint* sp = (SPint*)SP();                                    \
  6366.        sp skipSPop -1;                                                       \
  6367.        setSP(sp);             # Erst SP herabsetzen (wegen Interruptgefahr!) \
  6368.        sp[SPoffset] = (item); # dann item als top-of-SP eintragen            \
  6369.       }
  6370.     #define popSP(item_zuweisung)  \
  6371.       {var reg1 SPint* sp = (SPint*)SP();                                        \
  6372.        item_zuweisung sp[SPoffset]; # Erst item als top-of-SP holen              \
  6373.        sp skipSPop 1;                                                            \
  6374.        setSP(sp);                   # dann erst (Interruptgefahr!) SP hochsetzen \
  6375.       }
  6376.   #endif
  6377.   #if defined(GNU) && defined(MC680X0) && !defined(NO_ASM)
  6378.     # Mit GNU auf einem 680X0 liegt SP in einem Register. Zugriff und
  6379.     # Veränderung von SP bilden daher eine ununterbrechbare Einheit.
  6380.     # Und es gilt SP_DOWN und SPoffset=0.
  6381.     #define SP_(n)  \
  6382.       ({var reg1 uintL __n = sizeof(SPint) * (n); \
  6383.         var reg1 SPint __item;                    \
  6384.         __asm__ __volatile__ ("movel "REGISTER_PREFIX"sp@(%1:l),%0" : "=g" (__item) : "r" (__n) ); \
  6385.         __item;                                   \
  6386.        })
  6387.     #define skipSP(n)  \
  6388.       {var reg1 uintL __n = sizeof(SPint) * (n);                                   \
  6389.        __asm__ __volatile__ ("addl %0,"REGISTER_PREFIX"sp" : : "g" (__n) : "sp" ); \
  6390.       }
  6391.     #define pushSP(item)  \
  6392.       {var reg1 SPint __item = (item);                                                   \
  6393.        __asm__ __volatile__ ("movel %0,"REGISTER_PREFIX"sp@-" : : "g" (__item) : "sp" ); \
  6394.       }
  6395.     #define popSP(item_zuweisung)  \
  6396.       {var reg1 SPint __item;                                                             \
  6397.        __asm__ __volatile__ ("movel "REGISTER_PREFIX"sp@+,%0" : "=r" (__item) : : "sp" ); \
  6398.        item_zuweisung __item;                                                             \
  6399.       }
  6400.   #endif
  6401. # Größe eines jmp_buf im SP:
  6402.   #ifndef jmpbufsize
  6403.     #define jmpbufsize ceiling(sizeof(jmp_buf),sizeof(SPint))
  6404.   #endif
  6405. # Header im Bytecode einer compilierten Closure:
  6406.   #ifndef FAST_SP
  6407.     #define CCHD 2
  6408.   #else
  6409.     #define CCHD 0
  6410.   #endif
  6411.  
  6412. # LISP-Stack: STACK
  6413.   #if defined(GNU) && (SAFETY < 2)
  6414.     #if defined(MC680X0)
  6415.       #define STACK_register  "a4"  # höchstes Adreßregister nach sp=A7,fp=A6/A5
  6416.     #endif
  6417.     #if defined(SPARC)
  6418.       #define STACK_register  "%g5"  # ein globales Register
  6419.     #endif
  6420.     #if defined(HPPA_REG_WORKS)
  6421.       #define STACK_register  "%r10"  # eines der allgemeinen Register %r5..%r18
  6422.     #endif
  6423.     #if defined(M88000)
  6424.       #define STACK_register  "%r14"  # eines der allgemeinen Register %r14..%r25
  6425.     #endif
  6426.     #if defined(ARM)
  6427.       #define STACK_register  "%r8"  # eines der allgemeinen Register %r4..%r8
  6428.     #endif
  6429.     #if defined(DECALPHA)
  6430.       #define STACK_register  "$9"  # eines der allgemeinen Register $9..$14
  6431.     #endif
  6432.   #endif
  6433.   #if !defined(STACK_register)
  6434.     # eine globale Variable
  6435.     extern object* STACK;
  6436.   #else
  6437.     # eine globale Registervariable
  6438.     register object* STACK __asm__(STACK_register);
  6439.     #ifdef HAVE_SAVED_REGISTERS
  6440.       register long STACK_reg __asm__(STACK_register);
  6441.     #endif
  6442.   #endif
  6443.   #if defined(SPARC) && !defined(GNU) && !defined(__SUNPRO_C) && (SAFETY < 2)
  6444.     # eine globale Registervariable, aber Zugriffsfunktionen extern in Assembler
  6445.     #define STACK  _getSTACK()
  6446.     extern object* _getSTACK (void);
  6447.     #define setSTACK(zuweisung)  \
  6448.       { var object* tempSTACK; _setSTACK(temp##zuweisung); } # Ähem, igitt!
  6449.     extern void _setSTACK (void* new_STACK);
  6450.   #else
  6451.     #define setSTACK(zuweisung)  zuweisung
  6452.   #endif
  6453. #ifdef AMIGAOS
  6454.   #define STACK_DOWN # STACK wächst nach unten
  6455. #endif
  6456. #if defined(UNIX) || defined(DJUNIX) || defined(EMUNIX) || defined(WATCOM) || defined(RISCOS) || defined(HYPERSTONE) || defined(WIN32_UNIX) || defined(WIN32_DOS)
  6457.   #define STACK_UP # STACK wächst nach oben
  6458. #endif
  6459. #if (defined(STACK_DOWN) && defined(STACK_UP)) || (!defined(STACK_DOWN) && !defined(STACK_UP))
  6460.   #error "Unknown STACK direction -- STACK_DOWN/STACK_UP neu einstellen!"
  6461. #endif
  6462.  
  6463. # Jeder Aufruf einer externen Funktion (oder eine Folge von solchen) muß
  6464. # zwischen
  6465. #   begin_call();
  6466. # und
  6467. #   end_call();
  6468. # eingerahmt werden.
  6469. # Zweck: Damit im Falle einer Unterbrechung während des entsprechenden
  6470. # Zeitraums der STACK - falls er in einem Register liegt - auf einen halbwegs
  6471. # aktuellen Wert gebracht werden kann.
  6472. # Soll während des Ablaufs einer externen Funktion doch wieder auf den STACK
  6473. # zugegriffen werden, so ist der entsprechende Code zwischen
  6474. #   begin_callback();
  6475. # und
  6476. #   end_callback();
  6477. # einzurahmen.
  6478. #if defined(STACK_register) && !(defined(SUN4) && (SAFETY < 2))
  6479.   #define HAVE_SAVED_STACK
  6480.   extern object* saved_STACK;
  6481.   #define begin_call()  saved_STACK = STACK
  6482.   #define end_call()  saved_STACK = (object*)NULL
  6483.   #if defined(HAVE_SAVED_REGISTERS) # defined(GNU) && defined(DECALPHA)
  6484.     extern struct registers
  6485.                   { 
  6486.                     long STACK_register_contents;
  6487.                     long mv_count_register_contents;
  6488.                     long value1_register_contents;
  6489.                     struct registers *prev;
  6490.                   } *callback_saved_registers;
  6491.     #define begin_callback()  \
  6492.       { struct registers *registers = alloca(sizeof(struct registers)); \
  6493.         registers->prev = callback_saved_registers; \
  6494.         registers->STACK_register_contents = STACK_reg; \
  6495.         registers->mv_count_register_contents = mv_count_reg; \
  6496.         registers->value1_register_contents   = value1_reg;   \
  6497.         callback_saved_registers = registers; \
  6498.         STACK = saved_STACK; end_call();  \
  6499.       }
  6500.     #define end_callback()  \
  6501.       { struct registers *registers = callback_saved_registers; \
  6502.         begin_call(); \
  6503.         STACK_reg = registers->STACK_register_contents; \
  6504.         mv_count_reg = registers->mv_count_register_contents; \
  6505.         value1_reg = registers->value1_register_contents; \
  6506.         callback_saved_registers = registers->prev; \
  6507.       }
  6508.   #else
  6509.     #define begin_callback()  setSTACK(STACK = saved_STACK); end_call()
  6510.     #define end_callback()  begin_call()
  6511.   #endif
  6512. #elif defined(EMUNIX) && defined(WINDOWS)
  6513.   # Bei RSXW32 müssen wir den SP vorübergehend in die unteren 64 KB legen,
  6514.   # damit MS-Windows-Aufrufe möglich werden. Ansonsten brauchen wir aber
  6515.   # einen größeren Stack.
  6516.   #define begin_call()  if ((aint)SP() > (aint)SP_start) alloca((aint)SP() - (aint)SP_start)
  6517.   #define end_call()
  6518.   # Bei Callbacks bleiben wir im kleinen Stack.
  6519.   #define begin_callback()
  6520.   #define end_callback()
  6521. #else
  6522.   # Falls STACK eine globale Variable ist oder in einem Register liegt,
  6523.   # das von Betriebssystem und Library intakt gelassen wird (das ist bei
  6524.   # SUN4 der Fall), brauchen wir uns auch keine Sorgen zu machen.
  6525.   #if defined(GNU) && (SAFETY < 2) && defined(SPARC) && !defined(WIDE)
  6526.     # subr_self_register %g4 muß gerettet werden.
  6527.     #define HAVE_SAVED_SUBR_SELF
  6528.     extern object saved_subr_self;
  6529.     #define begin_call()  saved_subr_self = subr_self
  6530.     #define end_call()  subr_self = saved_subr_self
  6531.     #define begin_callback()  end_call()
  6532.     #define end_callback()  begin_call()
  6533.   #else
  6534.     #define begin_call()
  6535.     #define end_call()
  6536.     #define begin_callback()  end_call()
  6537.     #define end_callback()  begin_call()
  6538.   #endif
  6539. #endif
  6540.  
  6541. # Jeder Betriebsystem-Aufruf (oder eine Folge von solchen) muß zwischen
  6542. #   begin_system_call();
  6543. # und
  6544. #   end_system_call();
  6545. # eingerahmt werden.
  6546. # Zweck: Damit im Falle einer Unterbrechung während des entsprechenden
  6547. # Zeitraums der STACK - falls er in einem Register liegt - auf einen halbwegs
  6548. # aktuellen Wert gebracht werden kann.
  6549. #if defined(AMIGAOS) || defined(NO_ASYNC_INTERRUPTS)
  6550.   # AMIGAOS: Solange nicht ixemul.library benutzt wird, ist während
  6551.   #   Betriebssystem-Aufrufen das Programm sowieso nicht unterbrechbar.
  6552.   # NO_ASYNC_INTERRUPTS: Wenn wir auf asynchrone Interrupts nicht reagieren,
  6553.   #   ist das Programm nicht unterbrechbar.
  6554.   #define begin_system_call()
  6555.   #define end_system_call()
  6556. #else
  6557.   #define begin_system_call()  begin_call()
  6558.   #define end_system_call()  end_call()
  6559. #endif
  6560.  
  6561. # Unter Unix wird der Speicherbereich für den SP vom
  6562. # Betriebssystem bereitgestellt, kein malloc() nötig.
  6563. # Ebenso unter EMX (ausgenommen RSXW32 mit seinem Mini-60KB-Stack).
  6564. #if (defined(UNIX) && !defined(UNIX_MINT)) || (defined(EMUNIX) && !defined(WINDOWS)) || defined(RISCOS) || defined(WIN32_UNIX) || defined(WIN32_DOS) # || defined(AMIGAOS) # ?JCH??
  6565.   #define NO_SP_MALLOC
  6566. #endif
  6567.  
  6568. # Testet auf SP-Überlauf.
  6569. # check_SP();            testet auf Überlauf
  6570. # check_SP_notUNIX();    dito, außer wenn temporärer Überlauf nicht ins Gewicht fällt
  6571.   #define check_SP()  if (SP_overflow()) SP_ueber()
  6572.   #if (defined(EMUNIX) && defined(WINDOWS))
  6573.     # Der SP liegt entweder im Original-Bereich (<= SP_start) oder
  6574.     # im neu allozierten Bereich, der durch SP_bound begrenzt ist.
  6575.     #define SP_overflow()  \
  6576.       ( (aint)SP() > (aint)SP_start && (aint)SP() < (aint)SP_bound )
  6577.     extern void* SP_start;
  6578.   #elif !defined(NO_SP_MALLOC) || defined(AMIGAOS)
  6579.     #ifdef SP_DOWN
  6580.       #define SP_overflow()  ( (aint)SP() < (aint)SP_bound )
  6581.     #endif
  6582.     #ifdef SP_UP
  6583.       #define SP_overflow()  ( (aint)SP() > (aint)SP_bound )
  6584.     #endif
  6585.   #else # NO_SP_MALLOC
  6586.     # Für den SP ist das Betriebssystem verantwortlich.
  6587.     # Woher sollen wir einen vernünftigen Wert für SP_bound bekommen?
  6588.     #define SP_overflow()  FALSE
  6589.   #endif
  6590.   extern void* SP_bound;
  6591.   nonreturning_function(extern, SP_ueber, (void));
  6592.   #if defined(UNIX) || defined(WIN32_UNIX)
  6593.     #define check_SP_notUNIX()
  6594.   #else
  6595.     #define check_SP_notUNIX()  check_SP()
  6596.   #endif
  6597.  
  6598. # Testet auf STACK-Überlauf.
  6599. # check_STACK();
  6600.   #define check_STACK()  if (STACK_overflow()) STACK_ueber()
  6601.   #ifdef STACK_DOWN
  6602.     #define STACK_overflow()  ( (aint)STACK < (aint)STACK_bound )
  6603.   #endif
  6604.   #ifdef STACK_UP
  6605.     #define STACK_overflow()  ( (aint)STACK > (aint)STACK_bound )
  6606.   #endif
  6607.   extern void* STACK_bound;
  6608.   nonreturning_function(extern, STACK_ueber, (void));
  6609.  
  6610. # Testet, ob noch n Bytes auf dem STACK frei sind.
  6611. # get_space_on_STACK(n);
  6612.   #ifdef STACK_DOWN
  6613.     #define get_space_on_STACK(n)  \
  6614.       if ( (aint)STACK < (aint)STACK_bound + (aint)(n) ) STACK_ueber()
  6615.   #else
  6616.     #define get_space_on_STACK(n)  \
  6617.       if ( (aint)STACK + (aint)(n) > (aint)STACK_bound ) STACK_ueber()
  6618.   #endif
  6619.  
  6620. # LISP-Interpreter verlassen
  6621. # quit();
  6622. # > final_exitcode: 0 bei normalem Ende, 1 bei Abbruch
  6623.   nonreturning_function(extern, quit, (void));
  6624.   extern boolean final_exitcode;
  6625. # wird verwendet von CONTROL, WINDOWS
  6626.  
  6627. # Fehlermeldung wegen Erreichen einer unerreichbaren Programmstelle.
  6628. # Kehrt nicht zurück.
  6629. # fehler_notreached(file,line);
  6630. # > file: Filename (mit Anführungszeichen) als konstanter ASCIZ-String
  6631. # > line: Zeilennummer
  6632.   nonreturning_function(extern, fehler_notreached, (const char * file, uintL line));
  6633. # wird von allen Modulen verwendet
  6634.  
  6635. #ifndef LANGUAGE_STATIC
  6636. # Sprache, in der mit dem Benutzer kommuniziert wird:
  6637.   extern uintC language;
  6638.   #define language_english   0
  6639.   #define language_deutsch   1
  6640.   #define language_francais  2
  6641. # wird von allen Modulen verwendet
  6642. #endif
  6643.  
  6644. # Ausgabe eines konstanten ASCIZ-Strings, direkt übers Betriebssystem:
  6645. # asciz_out(string);
  6646.   extern void asciz_out (const char * asciz);
  6647.   extern void err_asciz_out (const char * asciz);
  6648. # wird verwendet von SPVW
  6649.  
  6650. # uintL in Dezimalnotation direkt übers Betriebssystem ausgeben:
  6651. # dez_out(zahl);
  6652.   #define dez_out(x)  dez_out_((uintL)(x))
  6653.   extern void dez_out_ (uintL zahl);
  6654. # wird zum Debuggen verwendet
  6655.  
  6656. # unsigned long in Hexadezimalnotation direkt übers Betriebssystem ausgeben:
  6657. # hex_out(zahl);
  6658.   #define hex_out(x)  hex_out_((unsigned long)(x))
  6659.   extern void hex_out_ (unsigned long zahl);
  6660. # wird zum Debuggen verwendet
  6661.  
  6662. # Speicherbereich in Hexadezimalnotation direkt übers Betriebssystem ausgeben:
  6663. # mem_hex_out(buf,count);
  6664.   extern void mem_hex_out (void* buf, uintL count);
  6665. # wird zum Debuggen verwendet
  6666.  
  6667. # Lisp-Objekt in Lisp-Notation relativ direkt übers Betriebssystem ausgeben:
  6668. # object_out(obj);
  6669. # kann GC auslösen
  6670.   extern void object_out (object obj);
  6671. # wird zum Debuggen verwendet
  6672.  
  6673. # Methode der Speicherverwaltung:
  6674. # SPVW_BLOCKS : Speicherverwaltung mit wenigen Speicherblöcken
  6675. # SPVW_PAGES  : Speicherverwaltung mit vielen Speicherseiten
  6676. # SPVW_MIXED  : Objekte verschiedenen Typs in derselben Seite/demselben Block
  6677. #               möglich
  6678. # SPVW_PURE   : Jeder Speicherblock/jede Speicherseite enthält nur Objekte
  6679. #               ein und desselben Typs
  6680. #if defined(WATCOM) || defined(UNIX_LINUX) || defined(MAP_MEMORY) || defined(TRIVIALMAP_MEMORY)
  6681.   # On DOS, with WATCOMs extender, we have only a limited amount of memory.
  6682.   # Bei Linux legt zu viel malloc() den Rechner für längere Zeit lahm.
  6683.   # Multimapping einzelner Pages ist noch nicht implementiert.??
  6684.   # Singlemapping einzelner Pages ist noch nicht implementiert.??
  6685.   # Verwendet man mmap() als malloc()-Ersatz, braucht man keine einzelnen Pages.
  6686.   #define SPVW_BLOCKS
  6687. #elif (defined(AMIGA) || defined(VIRTUAL_MEMORY)) && defined(GENTAG)
  6688.   # Auf dem Amiga sollte man nicht zu viel Speicher auf einmal holen.
  6689.   # Auf Unix-Systemen kann man nachträglich immer noch Speicher holen,
  6690.   # man sollte aber die Daten wenn möglich in wenigen Pages konzentrieren.
  6691.   # avl.d setzt den Macro GENTAG voraus.
  6692.   #define SPVW_PAGES
  6693. #else
  6694.   #define SPVW_BLOCKS
  6695. #endif
  6696. #if defined(MULTIMAP_MEMORY)
  6697.   # MULTIMAP_MEMORY -> Mixed Pages dienen besserer Speicher-Ausnutzung.
  6698.   #define SPVW_MIXED
  6699. #elif defined(SINGLEMAP_MEMORY)
  6700.   # SINGLEMAP_MEMORY -> Nur Pure Pages/Blocks sinnvoll, denn
  6701.   # die Adresse einer Page bestimmt den Typ der Objekte, die sie enthält.
  6702.   #define SPVW_PURE
  6703. #elif defined(MC68000) || defined(SUN3) || defined(AMIGA) || defined(SPVW_BLOCKS) || defined(TRIVIALMAP_MEMORY)
  6704.   # MC68000 oder SUN3 -> type_pointable(...) kostet nichts oder nur wenig.
  6705.   # AMIGA -> nur endlich viel Speicher, Mixed Pages nutzen ihn besser.
  6706.   # SPVW_BLOCKS -> SPVW_PURE_BLOCKS nur für SINGLEMAP_MEMORY implementiert.
  6707.   # TRIVIALMAP_MEMORY -> Nicht viele Blöcke möglich, da wenig Adreßraum.
  6708.   #define SPVW_MIXED
  6709. #elif 1 # vorläufig! ??
  6710.   #define SPVW_MIXED
  6711. #endif
  6712. #if !(defined(SPVW_BLOCKS) || defined(SPVW_PAGES))
  6713.   #error "SPVW_BLOCKS/SPVW_PAGES neu einstellen!"
  6714. #endif
  6715. #if !(defined(SPVW_MIXED) || defined(SPVW_PURE))
  6716.   #error "SPVW_MIXED/SPVW_PURE neu einstellen!"
  6717. #endif
  6718. #if (defined(SPVW_BLOCKS) && defined(SPVW_PURE)) != defined(SINGLEMAP_MEMORY)
  6719.   #error "SINGLEMAP_MEMORY impliziert SPVW_PURE_BLOCKS und umgekehrt!"
  6720. #endif
  6721. #if (defined(SPVW_BLOCKS) && defined(SPVW_MIXED)) < defined(TRIVIALMAP_MEMORY)
  6722.   #error "TRIVIALMAP_MEMORY impliziert SPVW_MIXED_BLOCKS!"
  6723. #endif
  6724. #if (defined(SPVW_BLOCKS) && (defined(SPVW_PURE) || (defined(SPVW_MIXED) && (defined(TRIVIALMAP_MEMORY) || !defined(UNIX_AIX))))) < defined(GENERATIONAL_GC)
  6725.   #error "GENERATIONAL_GC impliziert SPVW_PURE_BLOCKS oder SPVW_MIXED_BLOCKS_TRIVIALMAP oder SPVW_MIXED_BLOCKS_OPPOSITE!"
  6726. #endif
  6727.  
  6728. # Algorithmus nach Morris, der die Conses kompaktiert, ohne sie dabei
  6729. # durcheinanderzuwürfeln:
  6730. #if defined(SPVW_BLOCKS) && defined(VIRTUAL_MEMORY) && !defined(NO_MORRIS_GC)
  6731.   #define MORRIS_GC
  6732. #endif
  6733.  
  6734. # Lege subr_tab und symbol_tab per Memory-Mapping an vorgegebene Adressen.
  6735. # (Die Morris-GC verwendet bei MULTIMAP_MEMORY den Macro upointer(). Bei
  6736. # &symbol_tab = 0x20000000 wäre upointer(NIL)=0. Mist!)
  6737. #if defined(MAP_MEMORY) && !(defined(MULTIMAP_MEMORY) && defined(MORRIS_GC))
  6738.   #define MAP_MEMORY_TABLES
  6739. #endif
  6740.  
  6741. # UP, führt eine Garbage Collection aus
  6742. # gar_col();
  6743. # kann GC auslösen
  6744.   extern void gar_col(void);
  6745. # wird verwendet von DEBUG
  6746.  
  6747. # GC-Statistik
  6748.   extern uintL gc_count;
  6749.   extern uintL2 gc_space;
  6750.   extern internal_time gc_time;
  6751. # wird verwendet von TIME
  6752.  
  6753. # UP, beschafft ein Cons
  6754. # allocate_cons()
  6755. # < ergebnis: Pointer auf neues CONS, mit CAR und CDR =NIL
  6756. # kann GC auslösen
  6757.   extern object allocate_cons (void);
  6758. # wird verwendet von LIST, SEQUENCE, PACKAGE, EVAL, CONTROL, RECORD,
  6759. #                    PREDTYPE, IO, STREAM, PATHNAME, SYMBOL, ARRAY, LISPARIT
  6760.  
  6761. # UP: Liefert ein neu erzeugtes uninterniertes Symbol mit gegebenem Printnamen.
  6762. # make_symbol(string)
  6763. # > string: Simple-String
  6764. # < ergebnis: neues Symbol mit diesem Namen, mit Home-Package=NIL.
  6765. # kann GC auslösen
  6766.   extern object make_symbol (object string);
  6767. # wird verwendet von PACKAGE, IO, SYMBOL
  6768.  
  6769. # UP, beschafft Vektor
  6770. # allocate_vector(len)
  6771. # > len: Länge des Vektors
  6772. # < ergebnis: neuer Vektor (Elemente werden mit NIL initialisiert)
  6773. # kann GC auslösen
  6774.   extern object allocate_vector (uintL len);
  6775. # wird verwendet von ARRAY, IO, EVAL, PACKAGE, CONTROL, HASHTABL
  6776.  
  6777. # UP, beschafft Bit-Vektor
  6778. # allocate_bit_vector(len)
  6779. # > len: Länge des Bitvektors (in Bits)
  6780. # < ergebnis: neuer Bitvektor (LISP-Objekt)
  6781. # kann GC auslösen
  6782.   extern object allocate_bit_vector (uintL len);
  6783. # wird verwendet von ARRAY, IO, RECORD, LISPARIT, STREAM
  6784.  
  6785. # UP, beschafft String
  6786. # allocate_string(len)
  6787. # > len: Länge des Strings (in Bytes)
  6788. # < ergebnis: neuer Simple-String (LISP-Objekt)
  6789. # kann GC auslösen
  6790.   extern object allocate_string (uintL len);
  6791. # wird verwendet von ARRAY, CHARSTRG, STREAM, PATHNAME
  6792.  
  6793. # UP, beschafft Array
  6794. # allocate_array(flags,rank,type)
  6795. # > uintB flags: Flags
  6796. # > uintC rank: Rang
  6797. # > tint type: Typinfo
  6798. # < ergebnis: LISP-Objekt Array
  6799. # kann GC auslösen
  6800.   extern object allocate_array (uintB flags, uintC rank, tint type);
  6801. # wird verwendet von ARRAY, IO
  6802.  
  6803. # UP, beschafft Simple-Record
  6804. # allocate_srecord(flags,rectype,reclen,type)
  6805. # > uintB flags: Flags
  6806. # > sintB rectype: nähere Typinfo
  6807. # > uintC (eigentlich uintW) reclen: Länge
  6808. # > tint type: Typinfo
  6809. # < ergebnis: LISP-Objekt Record (Elemente werden mit NIL initialisiert)
  6810. # kann GC auslösen
  6811.   #define allocate_srecord(flags,rectype,reclen,type)  \
  6812.     allocate_srecord_(                                                    \
  6813.        (BIG_ENDIAN_P ? ((uintW)(flags)<<intBsize)+(uintW)(uintB)(rectype) \
  6814.                      : (uintW)(flags)+((uintW)(uintB)(rectype)<<intBsize) \
  6815.        ),                                                                 \
  6816.        reclen,                                                            \
  6817.        type)
  6818.   extern object allocate_srecord_ (uintW flags_rectype, uintC reclen, tint type);
  6819. # wird verwendet von RECORD, EVAL
  6820.  
  6821. # UP, beschafft Extended-Record
  6822. # allocate_xrecord(flags,rectype,reclen,recxlen,type)
  6823. # > uintB flags: Flags
  6824. # > sintB rectype: nähere Typinfo
  6825. # > uintC (eigentlich uintB) reclen: Länge
  6826. # > uintC (eigentlich uintB) recxlen: Extra-Länge
  6827. # > tint type: Typinfo
  6828. # < ergebnis: LISP-Objekt Record (Elemente werden mit NIL bzw. 0 initialisiert)
  6829. # kann GC auslösen
  6830.   #define allocate_xrecord(flags,rectype,reclen,recxlen,type)  \
  6831.     allocate_xrecord_(                                                    \
  6832.        (BIG_ENDIAN_P ? ((uintW)(flags)<<intBsize)+(uintW)(uintB)(rectype) \
  6833.                      : (uintW)(flags)+((uintW)(uintB)(rectype)<<intBsize) \
  6834.        ),                                                                 \
  6835.        reclen,                                                            \
  6836.        recxlen,                                                           \
  6837.        type)
  6838.   extern object allocate_xrecord_ (uintW flags_rectype, uintC reclen, uintC recxlen, tint type);
  6839. # wird verwendet von
  6840.  
  6841. # UP, beschafft Structure
  6842. # allocate_structure(reclen)
  6843. # > uintC reclen: Länge
  6844. # < ergebnis: LISP-Objekt Structure (Elemente werden mit NIL initialisiert)
  6845. # kann GC auslösen
  6846.   #ifdef case_structure
  6847.     #define allocate_structure(reclen)  \
  6848.       allocate_srecord(0,Rectype_Structure,reclen,structure_type)
  6849.   #else
  6850.     #define allocate_structure(reclen)  \
  6851.       allocate_srecord(0,Rectype_Structure,reclen,orecord_type)
  6852.   #endif
  6853. # wird verwendet von RECORD
  6854.  
  6855. # UP, beschafft Stream
  6856. # allocate_stream(strmflags,strmtype,reclen)
  6857. # > uintB strmflags: Flags
  6858. # > uintB strmtype: nähere Typinfo
  6859. # > uintC reclen: Länge
  6860. # < ergebnis: LISP-Objekt Stream (Elemente werden mit NIL initialisiert)
  6861. # kann GC auslösen
  6862.   #ifdef case_stream
  6863.     #define allocate_stream(strmflags,strmtype,reclen)  \
  6864.       allocate_xrecord(strmflags,strmtype,reclen,0,stream_type)
  6865.   #else
  6866.     extern object allocate_stream (uintB strmflags, uintB strmtype, uintC reclen);
  6867.   #endif
  6868. # wird verwendet von STREAM
  6869.  
  6870. # UP, beschafft Package
  6871. # allocate_package()
  6872. # < ergebnis: LISP-Objekt Package
  6873. # kann GC auslösen
  6874.   #define allocate_package()  \
  6875.     allocate_xrecord(0,Rectype_Package,package_length,0,orecord_type)
  6876. # wird verwendet von PACKAGE
  6877.  
  6878. # UP, beschafft Hash-Table
  6879. # allocate_hash_table()
  6880. # < ergebnis: LISP-Objekt Hash-Table
  6881. # kann GC auslösen
  6882.   #define allocate_hash_table()  \
  6883.     allocate_xrecord(0,Rectype_Hashtable,hashtable_length,0,orecord_type)
  6884. # wird verwendet von
  6885.  
  6886. # UP, beschafft Readtable
  6887. # allocate_readtable()
  6888. # < ergebnis: LISP-Objekt Readtable
  6889. # kann GC auslösen
  6890.   #define allocate_readtable()  \
  6891.     allocate_xrecord(0,Rectype_Readtable,readtable_length,0,orecord_type)
  6892. # wird verwendet von IO
  6893.  
  6894. # UP, beschafft Pathname
  6895. # allocate_pathname()
  6896. # < ergebnis: LISP-Objekt Pathname
  6897. # kann GC auslösen
  6898.   #define allocate_pathname()  \
  6899.     allocate_xrecord(0,Rectype_Pathname,pathname_length,0,orecord_type)
  6900. # wird verwendet von PATHNAME
  6901.  
  6902. #ifdef LOGICAL_PATHNAMES
  6903. # UP, beschafft Logical Pathname
  6904. # allocate_logpathname()
  6905. # < ergebnis: LISP-Objekt Logical Pathname
  6906. # kann GC auslösen
  6907.   #define allocate_logpathname()  \
  6908.     allocate_xrecord(0,Rectype_Logpathname,logpathname_length,0,orecord_type)
  6909. # wird verwendet von PATHNAME
  6910. #endif
  6911.  
  6912. # UP, beschafft Random-State
  6913. # allocate_random_state()
  6914. # < ergebnis: LISP-Objekt Random-State
  6915. # kann GC auslösen
  6916.   #define allocate_random_state()  \
  6917.     allocate_xrecord(0,Rectype_Random_State,random_state_length,0,orecord_type)
  6918. # wird verwendet von IO, LISPARIT
  6919.  
  6920. # UP, beschafft Byte
  6921. # allocate_byte()
  6922. # < ergebnis: LISP-Objekt Byte
  6923. # kann GC auslösen
  6924.   #define allocate_byte()  \
  6925.     allocate_xrecord(0,Rectype_Byte,byte_length,0,orecord_type)
  6926. # wird verwendet von LISPARIT
  6927.  
  6928. # UP, beschafft Fsubr
  6929. # allocate_fsubr()
  6930. # < ergebnis: LISP-Objekt Fsubr
  6931. # kann GC auslösen
  6932.   #define allocate_fsubr()  \
  6933.     allocate_xrecord(0,Rectype_Fsubr,fsubr_length,0,orecord_type)
  6934. # wird verwendet von SPVW
  6935.  
  6936. # UP, beschafft Load-time-Eval
  6937. # allocate_loadtimeeval()
  6938. # < ergebnis: LISP-Objekt Load-time-Eval
  6939. # kann GC auslösen
  6940.   #define allocate_loadtimeeval()  \
  6941.     allocate_xrecord(0,Rectype_Loadtimeeval,loadtimeeval_length,0,orecord_type)
  6942. # wird verwendet von IO, RECORD
  6943.  
  6944. # UP, beschafft Symbol-Macro
  6945. # allocate_symbolmacro()
  6946. # < ergebnis: LISP-Objekt Symbol-Macro
  6947. # kann GC auslösen
  6948.   #define allocate_symbolmacro()  \
  6949.     allocate_xrecord(0,Rectype_Symbolmacro,symbolmacro_length,0,orecord_type)
  6950. # wird verwendet von CONTROL, RECORD
  6951.  
  6952. #ifdef FOREIGN
  6953. # UP, beschafft Foreign-Pointer-Verpackung
  6954. # allocate_fpointer(foreign)
  6955. # > foreign: vom Typ FOREIGN
  6956. # < ergebnis: LISP-Objekt, das foreign enthält
  6957. # kann GC auslösen
  6958.   extern object allocate_fpointer (FOREIGN foreign);
  6959. # wird verwendet von REXX
  6960. #endif
  6961.  
  6962. # UP, beschafft Foreign-Addresse
  6963. # allocate_faddress()
  6964. # < ergebnis: LISP-Objekt Foreign-Addresse
  6965. # kann GC auslösen
  6966.   #define allocate_faddress()  \
  6967.     allocate_xrecord(0,Rectype_Faddress,faddress_length,faddress_xlength,orecord_type)
  6968. # wird verwendet von FOREIGN
  6969.  
  6970. # UP, beschafft Foreign-Variable
  6971. # allocate_fvariable()
  6972. # < ergebnis: LISP-Objekt Foreign-Variable
  6973. # kann GC auslösen
  6974.   #define allocate_fvariable()  \
  6975.     allocate_xrecord(0,Rectype_Fvariable,fvariable_length,0,orecord_type)
  6976. # wird verwendet von FOREIGN
  6977.  
  6978. # UP, beschafft Foreign-Funktion
  6979. # allocate_ffunction()
  6980. # < ergebnis: LISP-Objekt Foreign-Funktion
  6981. # kann GC auslösen
  6982.   #define allocate_ffunction()  \
  6983.     allocate_xrecord(0,Rectype_Ffunction,ffunction_length,0,orecord_type)
  6984. # wird verwendet von FOREIGN
  6985.  
  6986. # UP, beschafft Finalisierer
  6987. # allocate_finalizer()
  6988. # < ergebnis: LISP-Objekt Finalisierer
  6989. # kann GC auslösen
  6990.   #define allocate_finalizer()  \
  6991.     allocate_xrecord(0,Rectype_Finalizer,finalizer_length,0,orecord_type)
  6992. # wird verwendet von RECORD
  6993.  
  6994. #ifdef SOCKET_STREAMS
  6995.   #define allocate_socket_server() \
  6996.     allocate_xrecord(0,Rectype_Socket_Server,socket_server_length,0,orecord_type)
  6997. #endif
  6998.  
  6999. #ifdef YET_ANOTHER_RECORD
  7000. # UP, beschafft Yetanother
  7001. # allocate_yetanother()
  7002. # < ergebnis: LISP-Objekt Yetanother
  7003. # kann GC auslösen
  7004.   #define allocate_yetanother()  \
  7005.     allocate_xrecord(0,Rectype_Yetanother,yetanother_length,0,orecord_type)
  7006. # wird verwendet von
  7007. #endif
  7008.  
  7009. # UP, beschafft Handle-Verpackung
  7010. # allocate_handle(handle)
  7011. # < ergebnis: LISP-Objekt, das handle enthält
  7012.   #ifdef FOREIGN_HANDLE
  7013.     # kann GC auslösen
  7014.     extern object allocate_handle (Handle handle);
  7015.   #else
  7016.     #define allocate_handle(handle)  fixnum((uintL)(handle))
  7017.   #endif
  7018.  
  7019. # UP, beschafft Bignum
  7020. # allocate_bignum(len,sign)
  7021. # > uintC len: Länge der Zahl (in Digits)
  7022. # > sintB sign: Flag für Vorzeichen (0 = +, -1 = -)
  7023. # < ergebnis: neues Bignum (LISP-Objekt)
  7024. # kann GC auslösen
  7025.   extern object allocate_bignum (uintC len, sintB sign);
  7026. # wird verwendet von LISPARIT, STREAM
  7027.  
  7028. # UP, beschafft Single-Float
  7029. # allocate_ffloat(value)
  7030. # > ffloat value: Zahlwert (Bit 31 = Vorzeichen)
  7031. # < ergebnis: neues Single-Float (LISP-Objekt)
  7032. # kann GC auslösen
  7033.   extern object allocate_ffloat (ffloat value);
  7034. # wird verwendet von LISPARIT
  7035.  
  7036. # UP, beschafft Double-Float
  7037. #ifdef intQsize
  7038. # allocate_dfloat(value)
  7039. # > dfloat value: Zahlwert (Bit 63 = Vorzeichen)
  7040. # < ergebnis: neues Double-Float (LISP-Objekt)
  7041. # kann GC auslösen
  7042.   extern object allocate_dfloat (dfloat value);
  7043. #else
  7044. # allocate_dfloat(semhi,mlo)
  7045. # > semhi,mlo: Zahlwert (Bit 31 von semhi = Vorzeichen)
  7046. # < ergebnis: neues Double-Float (LISP-Objekt)
  7047. # kann GC auslösen
  7048.   extern object allocate_dfloat (uint32 semhi, uint32 mlo);
  7049. #endif
  7050. # wird verwendet von LISPARIT
  7051.  
  7052. # UP, beschafft Long-Float
  7053. # allocate_lfloat(len,expo,sign)
  7054. # > uintC len: Länge der Mantisse (in Digits)
  7055. # > uintL expo: Exponent
  7056. # > signean sign: Vorzeichen (0 = +, -1 = -)
  7057. # < ergebnis: neues Long-Float, noch ohne Mantisse
  7058. # Ein LISP-Objekt liegt erst dann vor, wenn die Mantisse eingetragen ist!
  7059. # kann GC auslösen
  7060.   extern object allocate_lfloat (uintC len, uintL expo, signean sign);
  7061. # wird verwendet von LISPARIT
  7062.  
  7063. # UP, erzeugt Bruch
  7064. # make_ratio(num,den)
  7065. # > object num: Zähler (muß Integer /= 0 sein, relativ prim zu den)
  7066. # > object den: Nenner (muß Integer > 1 sein)
  7067. # < ergebnis: Bruch
  7068. # kann GC auslösen
  7069.   extern object make_ratio (object num, object den);
  7070. # wird verwendet von LISPARIT
  7071.  
  7072. # UP, erzeugt komplexe Zahl
  7073. # make_complex(real,imag)
  7074. # > real: Realteil (muß reelle Zahl sein)
  7075. # > imag: Imaginärteil (muß reelle Zahl /= Fixnum 0 sein)
  7076. # < ergebnis: komplexe Zahl
  7077. # kann GC auslösen
  7078.   extern object make_complex (object real, object imag);
  7079. # wird verwendet von LISPARIT
  7080.  
  7081. # UP: Liefert einen LISP-String mit vorgegebenem Inhalt.
  7082. # make_string(charptr,len)
  7083. # > uintB* charptr: Adresse einer Zeichenfolge
  7084. # > uintL len: Länge der Zeichenfolge
  7085. # < ergebnis: Simple-String mit den len Zeichen ab charptr als Inhalt
  7086. # kann GC auslösen
  7087.   extern object make_string (const uintB* charptr, uintL len);
  7088. # wird verwendet von PATHNAME, LISPARIT
  7089.  
  7090. # UP: Liefert die Länge eines ASCIZ-Strings.
  7091. # asciz_length(asciz)
  7092. # > char* asciz: ASCIZ-String
  7093. #       (Adresse einer durch ein Nullbyte abgeschlossenen Zeichenfolge)
  7094. # < ergebnis: Länge der Zeichenfolge (ohne Nullbyte)
  7095.   extern uintL asciz_length (const char * asciz);
  7096. # wird verwendet von SPVW
  7097.  
  7098. # UP: Vergleicht zwei ASCIZ-Strings.
  7099. # asciz_equal(asciz1,asciz2)
  7100. # > char* asciz1: erster ASCIZ-String
  7101. # > char* asciz2: zweiter ASCIZ-String
  7102. # < ergebnis: TRUE falls die Zeichenfolgen gleich sind
  7103.   extern boolean asciz_equal (const char * asciz1, const char * asciz2);
  7104. # wird verwendet von STREAM
  7105.  
  7106. #if defined(GNU) && (SAFETY < 2)
  7107.   #if (__GNUC__ >= 2) # GCC 2 hat __builtin_strlen und __builtin_strcmp
  7108.     #define asciz_length(a)  ((uintL)__builtin_strlen(a))
  7109.     #if !defined(AMIGAOS) # der Amiga-GCC2 macht da aber eine Ausnahme
  7110.       #define asciz_equal(a1,a2)  (__builtin_strcmp(a1,a2)==0)
  7111.     #endif
  7112.   #endif
  7113. #endif
  7114. #ifndef asciz_length
  7115.   #ifdef HAVE_SAVED_STACK
  7116.     # Kann nicht strlen() statt asciz_length() benutzen, denn das würde
  7117.     # ein begin_system_call()/end_system_call() erfordern.
  7118.   #else
  7119.     # Gehen wir davon aus, daß strlen() effizient implementiert ist.
  7120.     #ifdef STDC_HEADERS
  7121.       #include <string.h> # deklariert strlen()
  7122.     #endif
  7123.     #ifdef RETSTRLENTYPE # wenn strlen() kein Macro ist
  7124.       extern RETSTRLENTYPE strlen (STRLEN_CONST char* s);
  7125.     #endif
  7126.     #define asciz_length(a)  ((uintL)strlen(a))
  7127.   #endif
  7128. #endif
  7129. #ifndef asciz_equal
  7130.   #if 1
  7131.     # strcmp() ist vermutlich Overkill für asciz_equal().
  7132.   #else
  7133.     # Gehen wir davon aus, daß strcmp() es auch tut.
  7134.     #ifdef STDC_HEADERS
  7135.       #include <string.h> # deklariert strcmp()
  7136.     #else
  7137.       extern int strcmp (char* s1, char* s2);
  7138.     #endif
  7139.     #define asciz_equal(p1,p2)  (strcmp(p1,p2)==0)
  7140.   #endif
  7141. #endif
  7142.  
  7143. # UP: Wandelt einen ASCIZ-String in einen LISP-String um.
  7144. # asciz_to_string(asciz)
  7145. # > char* asciz: ASCIZ-String
  7146. #       (Adresse einer durch ein Nullbyte abgeschlossenen Zeichenfolge)
  7147. # < ergebnis: String mit der Zeichenfolge (ohne Nullbyte) als Inhalt
  7148. # kann GC auslösen
  7149.   extern object asciz_to_string (const char * asciz);
  7150. # wird verwendet von SPVW/CONSTSYM, STREAM, PATHNAME, PACKAGE, GRAPH
  7151.  
  7152. # UP: Wandelt einen String in einen ASCIZ-String um.
  7153. # string_to_asciz(obj)
  7154. # > object obj: String
  7155. # < ergebnis: Simple-String mit denselben Zeichen und einem Nullbyte mehr am Schluß
  7156. # < TheAsciz(ergebnis): Adresse der darin enthaltenen Zeichenfolge
  7157. # kann GC auslösen
  7158.   extern object string_to_asciz (object obj);
  7159.   #define TheAsciz(obj)  ((char*)(&TheSstring(obj)->data[0]))
  7160. # wird verwendet von STREAM, PATHNAME
  7161.  
  7162. # Wandelt einen String in einen ASCIZ-String im C-Stack um.
  7163. # with_string_0(string,asciz,statement);
  7164. # copies the contents of string (which should be a Lisp string) to a safe area
  7165. # (zero-terminating it), binds the variable asciz pointing to it, and
  7166. # executes the statement.
  7167. #if 0
  7168.   #define with_string_0(string,ascizvar,statement)  \
  7169.     { var char* ascizvar = TheAsciz(string_to_asciz(string)); \
  7170.       statement                                               \
  7171.     }
  7172. #else
  7173.   #define with_string_0(string,ascizvar,statement)  \
  7174.     { var uintL ascizvar##_len;                                     \
  7175.       var reg2 uintB* ptr1 = unpack_string(string,&ascizvar##_len); \
  7176.      {var DYNAMIC_ARRAY(_EMA_,ascizvar##_data,uintB,ascizvar##_len+1);   \
  7177.       {var reg1 uintB* ptr2 = &ascizvar##_data[0];                  \
  7178.        var reg3 uintL count;                                        \
  7179.        dotimesL(count,ascizvar##_len, { *ptr2++ = *ptr1++; } );     \
  7180.        *ptr2 = '\0';                                                \
  7181.       }                                                             \
  7182.       {var char* ascizvar = (char*) &ascizvar##_data[0];            \
  7183.        statement                                                    \
  7184.       }                                                             \
  7185.       FREE_DYNAMIC_ARRAY(ascizvar##_data);                          \
  7186.     }}
  7187. #endif
  7188. # wird verwendet von MISC, FOREIGN, STDWIN
  7189.  
  7190. # UP: Liefert eine Tabelle aller Zirkularitäten innerhalb eines Objekts.
  7191. # (Eine Zirkularität ist ein in diesem Objekt enthaltenes Teil-Objekt,
  7192. # auf den es mehr als einen Zugriffsweg gibt.)
  7193. # get_circularities(obj,pr_array,pr_closure)
  7194. # > object obj: Objekt
  7195. # > boolean pr_array: Flag, ob Arrayelemente rekursiv als Teilobjekte gelten
  7196. # > boolean pr_closure: Flag, ob Closurekomponenten rekursiv als Teilobjekte gelten
  7197. # < ergebnis: T falls Stacküberlauf eintrat,
  7198. #             NIL falls keine Zirkularitäten vorhanden,
  7199. #             #(0 ...) ein (n+1)-elementiger Vektor, der die Zahl 0 und die n
  7200. #                      Zirkularitäten als Elemente enthält, n>0.
  7201. # kann GC auslösen
  7202.   extern object get_circularities (object obj, boolean pr_array, boolean pr_closure);
  7203. # wird verwendet von IO
  7204.  
  7205. # UP: Entflicht #n# - Referenzen im Objekt *ptr mit Hilfe der Aliste alist.
  7206. # > *ptr : Objekt
  7207. # > alist : Aliste (Read-Label --> zu substituierendes Objekt)
  7208. # < *ptr : Objekt mit entflochtenen Referenzen
  7209. # < ergebnis : fehlerhafte Referenz oder nullobj falls alles OK
  7210.   extern object subst_circ (object* ptr, object alist);
  7211. # wird verwendet von IO
  7212.  
  7213. # Break-Semaphoren
  7214. # Solange eine Break-Semaphore gesetzt ist, kann das Lisp-Programm nicht
  7215. # unterbrochen werden. Zweck:
  7216. # - Sicherstellung von Konsistenzen,
  7217. # - Nicht reentrante Datenstrukturen (wie z.B. DTA_buffer) können nicht
  7218. #   rekursiv verwendet werden.
  7219.   typedef union {uintB einzeln[4]; uintL gesamt; } break_sems_;
  7220.   extern break_sems_ break_sems;
  7221.   #define break_sem_1  break_sems.einzeln[0]
  7222.   #define break_sem_2  break_sems.einzeln[1]
  7223.   #define break_sem_3  break_sems.einzeln[2]
  7224.   #define break_sem_4  break_sems.einzeln[3]
  7225. # wird verwendet von SPVW, Macros set/clr_break_sem_1/2/3/4
  7226.  
  7227. # Setzt Break-Semaphore 1 und schützt so gegen Unterbrechungen
  7228. # set_break_sem_1();
  7229.   #define set_break_sem_1()  (break_sem_1 = 1)
  7230. # wird verwendet von SPVW, ARRAY
  7231.  
  7232. # Löscht Break-Semaphore 1 und gibt so Unterbrechungen wieder frei
  7233. # clr_break_sem_1();
  7234.   #define clr_break_sem_1()  (break_sem_1 = 0)
  7235. # wird verwendet von SPVW, ARRAY
  7236.  
  7237. # Setzt Break-Semaphore 2 und schützt so gegen Unterbrechungen
  7238. # set_break_sem_2();
  7239.   #define set_break_sem_2()  (break_sem_2 = 1)
  7240. # wird verwendet von PACKAGE, HASHTABL
  7241.  
  7242. # Löscht Break-Semaphore 2 und gibt so Unterbrechungen wieder frei
  7243. # clr_break_sem_2();
  7244.   #define clr_break_sem_2()  (break_sem_2 = 0)
  7245. # wird verwendet von PACKAGE, HASHTABL
  7246.  
  7247. # Setzt Break-Semaphore 3 und schützt so gegen Unterbrechungen
  7248. # set_break_sem_3();
  7249.   #define set_break_sem_3()  (break_sem_3 = 1)
  7250. # wird verwendet von PACKAGE
  7251.  
  7252. # Löscht Break-Semaphore 3 und gibt so Unterbrechungen wieder frei
  7253. # clr_break_sem_3();
  7254.   #define clr_break_sem_3()  (break_sem_3 = 0)
  7255. # wird verwendet von PACKAGE
  7256.  
  7257. # Setzt Break-Semaphore 4 und schützt so gegen Unterbrechungen
  7258. # set_break_sem_4();
  7259.   #define set_break_sem_4()  (break_sem_4 = 1)
  7260. # wird verwendet von STREAM, PATHNAME
  7261.  
  7262. # Löscht Break-Semaphore 4 und gibt so Unterbrechungen wieder frei
  7263. # clr_break_sem_4();
  7264.   #define clr_break_sem_4()  (break_sem_4 = 0)
  7265. # wird verwendet von STREAM, PATHNAME
  7266.  
  7267. # Flag, ob SYS::READ-FORM sich ILISP-kompatibel verhalten soll:
  7268.   extern boolean ilisp_mode;
  7269.  
  7270. # Liefert die Größe des von den LISP-Objekten belegten Platzes.
  7271.   extern uintL used_space (void);
  7272. # wird verwendet von TIME, DEBUG
  7273.  
  7274. # Liefert die Größe des für LISP-Objekte noch verfügbaren Platzes.
  7275.   extern uintL free_space (void);
  7276. # wird verwendet von DEBUG
  7277.  
  7278. # UP, speichert Speicherabbild auf Diskette
  7279. # savemem(stream);
  7280. # > object stream: offener File-Output-Stream, wird geschlossen
  7281. # kann GC auslösen
  7282.   extern void savemem (object stream);
  7283. # wird verwendet von PATHNAME
  7284.  
  7285. # UP: Ruft ein Fremdprogramm auf.
  7286. # execute(memneed)
  7287. # > -(STACK): Filename des Fremdprogramms, ein Simple-ASCIZ-String
  7288. # > -(STACK): Argumente (Command Tail), ein Simple-String
  7289. # > uintL memneed: Fürs Fremdprogramm zu reservierende Byte-Zahl (gerade)
  7290. # < sintL ergebnis : Falls negativ, Fehlernummer.
  7291. #                    Sonst Returncode des aufgerufenen Programms.
  7292. # STACK wird aufgeräumt
  7293. # kann GC auslösen
  7294.   extern sintL execute (uintL memneed);
  7295. # wird verwendet von PATHNAME
  7296.  
  7297. #ifdef HAVE_SIGNALS
  7298. # Temporarily do not ignore the status of subprocesses.
  7299.   extern void begin_want_sigcld (void);
  7300.   extern void end_want_sigcld (void);
  7301. # wird verwendet von PATHNAME
  7302. #endif
  7303.  
  7304.  
  7305. # Deklaration der FSUBRs.
  7306. # Als C-Funktionen: C_name, vom Typ fsubr_function (keine Argumente, kein Wert)
  7307.  
  7308. # C-Funktionen sichtbar machen:
  7309.   #define LISPSPECFORM  LISPSPECFORM_A
  7310.   #include "fsubr.c"
  7311.   #undef LISPSPECFORM
  7312. # wird verwendet von
  7313.  
  7314. # Fsubr-Tabelle sichtbar machen:
  7315.   #define LISPSPECFORM  LISPSPECFORM_C
  7316.   extern struct fsubr_tab_ {
  7317.                              #include "fsubr.c"
  7318.                            }
  7319.          fsubr_tab;
  7320.   #undef LISPSPECFORM
  7321. # wird verwendet von CONTROL, SPVW
  7322.  
  7323.  
  7324. # Deklaration der SUBR-Tabelle.
  7325. # Als C-Funktionen: C_name
  7326. # vom Typ subr_norest_function (keine Argumente, kein Wert)
  7327. # bzw. subr_rest_function (zwei Argumente, kein Wert):
  7328.   typedef Values subr_norest_function (void);
  7329.   typedef Values subr_rest_function (reg4 uintC argcount, reg3 object* rest_args_pointer);
  7330.  
  7331. # Als LISP-Subr:    L(name)
  7332.  
  7333. # C-Funktionen sichtbar machen:
  7334.   #define LISPFUN  LISPFUN_A
  7335.   #include "subr.c"
  7336.   #undef LISPFUN
  7337. # wird verwendet von
  7338.  
  7339. # Subr-Tabelle sichtbar machen:
  7340.   #define LISPFUN  LISPFUN_C
  7341.   extern struct subr_tab_ {
  7342.                             #include "subr.c"
  7343.                           }
  7344.          subr_tab_data;
  7345.   #undef LISPFUN
  7346. # wird verwendet von Macro L
  7347.  
  7348. # Abkürzung fürs LISP-Subr mit einem gegebenen Namen: L(name)
  7349.   #if !defined(MAP_MEMORY_TABLES)
  7350.     #define subr_tab  subr_tab_data
  7351.     #define subr_tab_ptr_as_object(subr_addr)  (type_constpointer_object(subr_type,subr_addr))
  7352.     #define L(name)  subr_tab_ptr_as_object(&subr_tab.D_##name)
  7353.   #else
  7354.     # define subr_tab_addr  ((struct subr_tab_ *)type_constpointer_object(subr_type,0))
  7355.     #define subr_tab_addr  ((struct subr_tab_ *)type_zero_oint(subr_type))
  7356.     #define subr_tab  (*subr_tab_addr)
  7357.     #define subr_tab_ptr_as_object(subr_addr)  (as_object((oint)(subr_addr)))
  7358.     #define L(name)  subr_tab_ptr_as_object(&subr_tab_addr->D_##name)
  7359.   #endif
  7360. # wird verwendet von allen Modulen
  7361.  
  7362.  
  7363. # Pseudofunktionen sind Adressen von C-Funktionen, die direkt angesprungen werden können.
  7364. # Für SAVEMEM/LOADMEM gibt es eine Tabelle aller Pseudofunktionen.
  7365.   typedef object pseudofun_(); # C-Funktion mit Objekt als Ergebnis
  7366.   typedef pseudofun_ *  Pseudofun; # Pointer auf so eine Funktion
  7367.  
  7368. # Deklaration der Pseudofunktionen-Tabelle:
  7369.   #ifdef STRM_WR_SS
  7370.     #define PSEUDOFUNSS(name)  PSEUDOFUN(name)
  7371.   #else
  7372.     #define PSEUDOFUNSS(name)
  7373.   #endif
  7374.   #define PSEUDOFUN  PSEUDOFUN_A
  7375.   extern struct pseudofun_tab_ {
  7376.                                  #include "pseudofun.c"
  7377.                                }
  7378.          pseudofun_tab;
  7379.   #undef PSEUDOFUN
  7380. # wird verwendet von STREAM, SPVW
  7381.  
  7382.  
  7383. # Deklaration der Symbol-Tabelle:
  7384.   #define LISPSYM  LISPSYM_A
  7385.   extern struct symbol_tab_ {
  7386.                               #include "constsym.c"
  7387.                             }
  7388.          symbol_tab_data;
  7389.   #undef LISPSYM
  7390. # wird verwendet von Macro S
  7391.  
  7392. # Abkürzung für LISP-Symbol mit einem gegebenen Namen: S(name)
  7393.   #define S(name)  S_help_(S_##name)
  7394.   #if !defined(MAP_MEMORY_TABLES)
  7395.     #define symbol_tab  symbol_tab_data
  7396.     #define S_help_(name)  (type_constpointer_object(symbol_type,&symbol_tab.name))
  7397.   #else
  7398.     # define symbol_tab_addr ((struct symbol_tab_ *)type_constpointer_object(symbol_type,0))
  7399.     #define symbol_tab_addr ((struct symbol_tab_ *)type_zero_oint(symbol_type))
  7400.     #define symbol_tab  (*symbol_tab_addr)
  7401.     #define S_help_(name)  (as_object((oint)(&symbol_tab_addr->name)))
  7402.     #if 0 # Manche Compiler erlauben obigen Ausdruck
  7403.           # - obwohl eine 'constant expression' -
  7404.           # nicht als Initialisierer von static-Variablen.
  7405.           # Wir müssen nachhelfen:
  7406.       #undef S_help_
  7407.       #define S_help_(name)  (as_object( (char*)(&((struct symbol_tab_ *)0)->name) + (uintP)symbol_tab_addr ))
  7408.     #endif
  7409.   #endif
  7410. # wird verwendet von allen Modulen
  7411.  
  7412. #define NIL  S(nil)
  7413. #define T    S(t)
  7414.  
  7415. # Der Macro NIL_IS_CONSTANT gibt an, ob NIL vom C-Compiler als
  7416. # 'constant expression' anerkannt wird. Wenn ja, können die Tabellen
  7417. # zum großen Teil bereits vom C-Compiler initialisiert werden.
  7418.   #if (oint_addr_shift==0)
  7419.     #define NIL_IS_CONSTANT  TRUE
  7420.   #else
  7421.     #define NIL_IS_CONSTANT  FALSE
  7422.   #endif
  7423.  
  7424. # Deklaration der Tabelle der sonstigen festen Objekte:
  7425.   #define LISPOBJ  LISPOBJ_A
  7426.   extern struct object_tab_ {
  7427.                               #include "constobj.c"
  7428.                             }
  7429.          object_tab;
  7430.   #undef LISPOBJ
  7431. # wird verwendet von Macro O
  7432.  
  7433. # Abkürzung für sonstiges LISP-Objekt mit einem gegebenem Namen:
  7434.   #define O(name)  (object_tab.name)
  7435.  
  7436. # Abkürzung für von language abhängiges LISP-Objekt mit einem gegebenem Namen:
  7437.   #ifndef ENABLE_NLS
  7438.     #ifdef LANGUAGE_STATIC
  7439.       #define OL(name)  O(name)
  7440.     #else
  7441.       #define OL(name)  ((&O(name))[language])
  7442.     #endif
  7443.   #else
  7444.     #ifdef NLS_COMPILE_TIME_TRANSLATION
  7445.       #define OL(name) O(name)
  7446.     #else
  7447.       #define OL(name) (pushSTACK(O(name)), funcall(L(gettext),1), value1)
  7448.     #endif
  7449.   #endif
  7450.  
  7451. #if defined(GENERATIONAL_GC) && defined(SPVW_MIXED)
  7452. # handle_fault_range(PROT_READ,start,end) macht einen Adreßbereich lesbar,
  7453. # handle_fault_range(PROT_READ_WRITE,start,end) macht ihn schreibbar.
  7454.   extern boolean handle_fault_range (int prot, aint start_address, aint end_address);
  7455. #endif
  7456.  
  7457.  
  7458. # ###################### MODBIBL zu MODULES.D ############################ #
  7459.  
  7460. # Anzahl der externen Module:
  7461.   extern uintC module_count;
  7462.  
  7463. # Daten für die Initialisierung der subr_tab eines Moduls:
  7464.   typedef struct { char* packname; # Name der Home-Package des Symbols oder NULL
  7465.                    char* symname; # Name des Symbols
  7466.                  }
  7467.           subr_initdata;
  7468.  
  7469. # Daten für die Initialisierung der object_tab eines Moduls:
  7470.   typedef struct { char* initstring; } # Initialisierungs-String
  7471.           object_initdata;
  7472.  
  7473. # Tabelle bzw. Liste der Module:
  7474.   typedef struct module_
  7475.                  { char* name; # Name
  7476.                    subr_* stab; uintC* stab_size; # eine eigene subr_tab
  7477.                    object* otab; uintC* otab_size; # eine eigene object_tab
  7478.                    boolean initialized;
  7479.                    # Daten zur Initialisierung:
  7480.                    subr_initdata* stab_initdata;
  7481.                    object_initdata* otab_initdata;
  7482.                    # Funktionen zur Initialisierung
  7483.                    void (*initfunction1) _ARGS((struct module_ *)); # nur einmal
  7484.                    void (*initfunction2) _ARGS((struct module_ *)); # immer bei Programmstart
  7485.                    #ifdef DYNAMIC_MODULES
  7486.                    struct module_ * next; # verkettete Liste
  7487.                    #endif
  7488.                  }
  7489.           module_;
  7490.   #ifdef DYNAMIC_MODULES
  7491.     BEGIN_DECLS
  7492.     extern void add_module (module_ * new_module);
  7493.     END_DECLS
  7494.   #else
  7495.     extern module_ modules[]; # 1+module_count Einträge, dann ein leerer Eintrag
  7496.   #endif
  7497.  
  7498.  
  7499. # ####################### EVALBIBL zu EVAL.D ############################## #
  7500.  
  7501. /*
  7502.  
  7503. Spezifikationen für den Evaluator
  7504. #################################
  7505.  
  7506. SUBRs und FSUBRs
  7507. ================
  7508.  
  7509. Sie werden konstruiert mit
  7510.   LISPFUN             für allgemeine LISP-Funktionen,
  7511.   LISPFUNN            für normale LISP-Funktionen (nur required-Parameter),
  7512.   LISPSPECFORM        für Special-Forms (FSUBRs).
  7513. Beachte, daß SUBRs mit KEY_ANZ=0 vom Evaluator als SUBRs ohne Keyword-
  7514. Parameter betrachtet werden (was zur Folge hat, daß in diesem Fall das
  7515. ALLOW_FLAG bedeutungslos ist und kein Keyword, auch nicht :ALLOW-OTHER-KEYS,
  7516. akzeptiert wird)!
  7517.  
  7518. Werte
  7519. =====
  7520.  
  7521. Folgendes Format wird für die Übergabe von multiple values verwendet:
  7522. value1 enthält den ersten Wert (NIL falls keine Werte).
  7523. mv_count enthält die Anzahl der Werte.
  7524. Falls mindestens ein Wert vorhanden:   value1 = erster Wert.
  7525. Falls mindestens zwei Werte vorhanden: value2 = zweiter Wert.
  7526. Falls mindestens drei Werte vorhanden: value3 = dritter Wert.
  7527. Alle Werte sind in mv_space abgelegt.
  7528. Empfohlene Befehle zur Rückgabe (an den Aufrufer) von
  7529.   0 Werten:   value1=NIL; mv_count=0;
  7530.   1 Wert:     value1=...; mv_count=1;
  7531.   2 Werten:   value1=...; value2=...; mv_count=2;
  7532.   3 Werten:   value1=...; value2=...; value3=...; mv_count=3;
  7533.   mehr als 3 Werten:
  7534.               if (Wertezahl >= mv_limit) goto fehler_zuviele_werte;
  7535.               Werte der Reihe nach auf den STACK legen
  7536.               STACK_to_mv(Wertezahl);
  7537.  
  7538. Parameterübergabe an SUBRs
  7539. ==========================
  7540.  
  7541. Die Argumente werden auf dem LISP-Stack übergeben, dabei liegt das erste
  7542. Argument zuoberst. Zuerst kommen die required-Argumente, dann die optionalen
  7543. Argumente (jeweils #UNBOUND, falls nicht angegeben), dann die
  7544. Keyword-Argumente (wieder jeweils #UNBOUND, falls nicht angegeben).
  7545. In subr_self befindet sich das SUBR-Objekt.
  7546. Ist kein &REST-Argument vorgesehen, so ist dies alles. Ist &REST-Argument
  7547. vorgesehen, so folgen im Stack alle weiteren Argumente (nach den optionalen)
  7548. einzeln, und es werden übergeben: die Anzahl dieser Argumente und ein Pointer
  7549. übers erste dieser Argumente. (Dann ist die Anzahl der LISP-Objekte auf dem
  7550. Stack also nicht immer dieselbe!)
  7551. Beim Rücksprung müssen alle Argumente vom LISP-Stack entfernt sein
  7552. (d.h. z.B. bei SUBRs mit &REST: der Stackpointer STACK muß den Wert
  7553. args_pointer = rest_args_pointer STACKop (feste Argumentezahl)
  7554. = Pointer übers erste Argument überhaupt) haben, und mv_count/mv_space
  7555. muß die Werte enthalten.
  7556.  
  7557. Parameterübergabe an FSUBRs
  7558. ===========================
  7559.  
  7560. Die Parameter werden auf dem LISP-Stack übergeben, dabei liegt der erste
  7561. Parameter zuoberst. Zuerst kommen die required-Parameter, dann die optionalen
  7562. Parameter (#UNBOUND, falls nicht angegeben), dann - falls Body-Flag wahr -
  7563. der gesamte restliche Body (meist eine Liste).
  7564. Die Anzahl der auf dem LISP-Stack liegenden Objekte ist also immer dieselbe,
  7565. nämlich  reqParameterZahl + optParameterZahl + (0 oder 1 falls Body-Flag).
  7566. Beim Aufruf enthält subr_self das FSUBR-Objekt, und die gesamte Form befindet
  7567. sich im EVAL-Frame, direkt über den Parametern.
  7568. Beim Rücksprung müssen alle Parameter vom LISP-Stack entfernt sein
  7569. (d.h. der Stackpointer STACK muß um Objektezahl erhöht worden sein),
  7570. und mv_count/mv_space muß die Werte enthalten.
  7571.  
  7572. Environments
  7573. ============
  7574.  
  7575. Allgemeines
  7576. -----------
  7577. Das lexikalische Environment ist aufgeteilt in 5 Komponenten:
  7578.   - Das Variablen-Environment (VAR_ENV),
  7579.   - Das Funktions- und Macro-Environment (FUN_ENV),
  7580.   - Das Block-Environment (BLOCK_ENV),
  7581.   - Das Tagbody-Environment (GO_ENV),
  7582.   - Das Deklarations-Environment (DECL_ENV).
  7583. Das Environment wird in 5 "globalen Variablen" gehalten. Bei Veränderung
  7584. wird es mit speziellen Frames dynamisch gebunden.
  7585. An SYM_FUNCTION, MACROEXP, MACROEXP0, PARSE_DD wird ein einzelnes
  7586. Funktions- und Macro-Environment übergeben.
  7587. GET_CLOSURE erwartet einen Pointer auf alle Environments en bloc: A3 mit
  7588. VAR_(A3)=VAR_ENV, FUN_(A3)=FUN_ENV, BLOCK_(A3)=BLOCK_ENV, GO_(A3)=GO_ENV,
  7589. DECL_(A3)=DECL_ENV.
  7590.  
  7591. Das Variablen-Environment
  7592. -------------------------
  7593. Es enthält die lokalen Variablenbindungen.
  7594. Ein Variablen-Environment ist gegeben durch einen Pointer auf einen
  7595. Variablenbindungs-Frame oder durch NIL (das bedeutet ein leeres lexikalisches
  7596. Environment) oder durch einen Vektor folgenden Aufbaus:
  7597. Der Vektor enthält n Bindungen und hat die Länge 2n+1. Die Elemente sind
  7598. n-mal jeweils Variable (ein Symbol) und zugehöriger Wert (als "Wert" kann
  7599. auch #<SPECDECL> auftreten, dann ist die Variable dynamisch zu referenzieren)
  7600. und als letztes Element das Vorgänger-Environment.
  7601.  
  7602. Das Funktions- und Macro-Environment
  7603. ------------------------------------
  7604. Es enthält die lokalen Funktions- und Macro-Definitionen.
  7605. Ein Funktions- und Macro-Environment ist gegeben durch einen Pointer auf
  7606. einen Funktions- oder Macrobindungs-Frame oder durch NIL (das bedeutet ein
  7607. leeres lexikalisches Environment) oder durch einen Vektor folgenden Aufbaus:
  7608. Der Vektor enthält n Bindungen und hat die Länge 2n+1. Die Elemente sind
  7609. n-mal jeweils Funktionsname (ein Symbol) und zugehörige Definition (eine
  7610. Closure oder NIL oder ein Cons (SYS::MACRO . Closure) ) und als letztes
  7611. Element das Vorgänger-Environment.
  7612.  
  7613. Das Block-Environment
  7614. ---------------------
  7615. Es enthält die lexikalisch sichtbaren Block-Exitpoints.
  7616. Ein Block-Environment ist gegeben durch einen Pointer auf einen Block-Frame
  7617. oder durch eine Assoziationsliste, deren Elemente jeweils als CAR den
  7618. Block-Namen (ein Symbol) haben und als CDR entweder den Pointer auf den
  7619. zugehörigen Frame oder, falls der Block bereits verlassen wurde, #DISABLED.
  7620.  
  7621. Das Tagbody-Environment
  7622. -----------------------
  7623. Es enthält die lexikalisch sichtbaren Go-Marken der Tagbodys.
  7624. Ein Tagbody-Environment ist gegeben durch einen Pointer auf einen
  7625. Tagbody-Frame oder durch eine Assoziationsliste, deren Elemente jeweils als
  7626. CAR einen Vektor (mit den Go-Marken als Elementen) haben und als CDR entweder
  7627. den Pointer auf den zugehörigen Frame oder, falls der Tagbody bereits
  7628. verlassen wurde, #<DISABLED>.
  7629.  
  7630. Das Deklarations-Environment
  7631. ----------------------------
  7632. Es enthält die lexikalisch sichtbaren Deklarationen.
  7633. Ein Deklarations-Environment ist gegeben durch eine Liste von Declaration-
  7634. Specifiers, deren CAR jeweils entweder OPTIMIZE oder DECLARATION oder
  7635. ein benutzerdefinierter Deklarationstyp ist.
  7636.  
  7637. Übergabe von Environments an LISP-Funktionen
  7638. --------------------------------------------
  7639. Dafür gibt es zwei Datenstrukturen:
  7640. Bei Übergabe als zweites Argument an Macro-Expander-Funktionen (CLTL S.
  7641. 145-146) und bei Annahme durch MACROEXPAND und MACROEXPAND-1 (CLTL S. 151)
  7642. handelt es sich nur um einen 2-elementigen Simple-Vector, bestehend aus einem
  7643. genesteten Variablen-Environment und einem genesteten Funktions- und Macro-
  7644. Environment. Dasselbe bei Übergabe an SYSTEM::%EXPAND-LAMBDABODY-MAIN u.ä.
  7645. Bei Übergabe als zweites Argument an den Wert von *EVALHOOK* bzw. als drittes
  7646. Argument an den Wert von *APPLYHOOK* (CLTL S. 322) und bei Annahme durch
  7647. EVALHOOK und APPLYHOOK (CLTL S. 323) handelt es sich um einen 5-elementigen
  7648. Simple-Vector mit den fünf Einzelkomponenten, alle genestet.
  7649.  
  7650. Frames
  7651. ======
  7652. Für den Aufruf von SUBRs, FSUBRs und compilierten Closures werden keine
  7653. Frames verwendet.
  7654. Es gibt folgende 14 Arten von Frames:
  7655.   - Environmentbindungs-Frame (ENV_FRAME),
  7656.   - APPLY-Frame (APPLY_FRAME),
  7657.   - EVAL-Frame (EVAL_FRAME),
  7658.   - dynamischer Variablenbindungs-Frame (DYNBIND_FRAME),
  7659.   - Variablenbindungs-Frame (VAR_FRAME),
  7660.   - Funktions- oder Macrobindungs-Frame (FUN_FRAME),
  7661.   - interpretierter Block-Frame (IBLOCK_FRAME),
  7662.   - compilierter Block-Frame (CBLOCK_FRAME),
  7663.   - interpretierter Tagbody-Frame (ITAGBODY_FRAME),
  7664.   - compilierter Tagbody-Frame (CTAGBODY_FRAME),
  7665.   - Catch-Frame (CATCH_FRAME),
  7666.   - Unwind-Protect-Frame (UNWIND_PROTECT_FRAME),
  7667.   - Handler-Frame (HANDLER_FRAME),
  7668.   - Driver-Frame (DRIVER_FRAME).
  7669. Zuunterst in einem Frame kommt ein Langwort, das die Frametyp-Information
  7670. und einen Pointer über den Frame (= den Wert des STACK vor Aufbau und nach
  7671. Abbau des Frame) enthält.
  7672. In der Frame-Info sind die Bits
  7673.   SKIP2_BIT      gelöscht, falls darüber noch ein weiteres Langwort kommt,
  7674.                    das kein LISP-Objekt ist und deswegen von der GC
  7675.                    übersprungen werden muß,
  7676.   EXITPOINT_BIT  gesetzt bei allen außer VAR und FUN,
  7677.   NESTED_BIT     bei IBLOCK und ITAGBODY gesetzt, wenn Exitpoint bzw.
  7678.                    Go-Marken bereits in eine Aliste gesteckt wurden.
  7679. Die Normalwerte für die Frametyp-Info-Bytes sind ENVxx_FRAME_INFO,
  7680. APPLY_FRAME_INFO, EVAL_FRAME_INFO, VAR_FRAME_INFO, FUN_FRAME_INFO,
  7681. IBLOCK_FRAME_INFO, CBLOCK_FRAME_INFO, ITAGBODY_FRAME_INFO, CTAGBODY_FRAME_INFO,
  7682. CATCH_FRAME_INFO, UNWIND_PROTECT_FRAME_INFO, DRIVER_FRAME_INFO.
  7683. Die Routine, die in (SP).L mit SP=SP_(STACK) steht (bei IBLOCK-, CBLOCK-,
  7684. ITAGBODY-, CTAGBODY-, CATCH-, UNWIND-PROTECT-Frames), wird
  7685. angesprungen durch   MOVE.L SP_(STACK),SP ! RTS  .
  7686. Bei DRIVER-Frames durch   MOVE.L SP_(STACK),SP ! MOVE.L (SP),-(SP) ! RTS  .
  7687. In der portablen C-Version steht in SP_(STACK) ein Pointer auf einen
  7688. setjmp/longjmp-Buffer.
  7689.  
  7690. Environmentbindungs-Frames
  7691. --------------------------
  7692. Sie enthalten dynamische Bindungen von maximal 5 Environments.
  7693. Frame-Info ist ENVxx_FRAME_INFO (xx je nachdem, welche der Environments hier
  7694. gebunden sind). Aufbau:
  7695.     Offset        Stack-Inhalt
  7696.   20/16/12/8/4  [alter Wert von DECL_ENV]
  7697.   16/12/8/4     [alter Wert von GO_ENV]
  7698.   12/8/4        [alter Wert von BLOCK_ENV]
  7699.   8/4           [alter Wert von FUN_ENV]
  7700.   4             [alter Wert von VAR_ENV]
  7701.   0             Frame-Info; Pointer über Frame
  7702. Im einzelnen:
  7703. ENV1V_frame    für 1 VAR_ENV
  7704. ENV1F_frame    für 1 FUN_ENV
  7705. ENV1B_frame    für 1 BLOCK_ENV
  7706. ENV1G_frame    für 1 GO_ENV
  7707. ENV1D_frame    für 1 DECL_ENV
  7708. ENV2VD_frame   für 1 VAR_ENV und 1 DECL_ENV
  7709. ENV5_frame     für alle 5 Environments
  7710.  
  7711. APPLY-Frames
  7712. ------------
  7713. Sie werden erzeugt bei jedem Aufruf (APPLY oder FUNCALL) einer interpretierten
  7714. Closure.
  7715. Aufbau:
  7716.   Offset     Stack-Inhalt
  7717.   4n+12
  7718.   4n+8      Argument 1
  7719.   ...
  7720.   12        Argument n
  7721.   8         Funktion, die gerade aufgerufen wird
  7722.   4         SP
  7723.   0         Frame-Info; Pointer über Frame
  7724. SP ist ein Pointer in den Programmstack. Rücksprung zu (SP).L nach Auflösung
  7725. des APPLY-Frames gibt den Inhalt von A0/... als Werte der Form zurück.
  7726. Die Frame-Info hat den Wert APPLY_FRAME_INFO oder TRAPPED_APPLY_FRAME_INFO.
  7727.  
  7728. EVAL-Frames
  7729. -----------
  7730. Sie werden erzeugt bei jedem Aufruf des EVAL-Unterprogramms.
  7731. Aufbau:
  7732.   Offset     Stack-Inhalt
  7733.   8         Form, die gerade evaluiert wird
  7734.   4         SP
  7735.   0         Frame-Info; Pointer über Frame
  7736. SP ist ein Pointer in den Programmstack. Rücksprung zu (SP).L nach Auflösung
  7737. des EVAL-Frames gibt den Inhalt von A0/... als Werte der Form zurück.
  7738. Die Frame-Info hat den Wert EVAL_FRAME_INFO oder TRAPPED_EVAL_FRAME_INFO.
  7739.  
  7740. Dynamische Variablenbindungs-Frames
  7741. -----------------------------------
  7742. Sie binden dynamisch Symbole an Werte.
  7743. Der Aufbau eines solchen Frames mit n Bindungen ist wie folgt:
  7744.   Offset  Stack-Inhalt
  7745.   8n+4
  7746.   8n      Wert 1
  7747.   8n-4    Symbol 1
  7748.   ...     ...
  7749.   8       Wert n
  7750.   4       Symbol n
  7751.   0       Frame-Info; Pointer über Frame
  7752. Der Inhalt des Frameinfo-Bytes ist DYNBIND_FRAME_INFO.
  7753.  
  7754. Variablenbindungs-Frames
  7755. ------------------------
  7756. Sie werden erzeugt beim Anwenden von interpretierten Closures (für die in der
  7757. Lambda-Liste spezifizierten Variablenbindungen und ggfs. in den Deklarationen
  7758. angegebenen dynamischen Referenzen) und von LET und LET*, sowie von allen
  7759. Konstrukten, die implizit LET oder LET* benutzen (wie DO, DO*, PROG, PROG*,
  7760. DOLIST, DOTIMES, ...).
  7761. Der Aufbau eines Variablenbindungs-Frames mit n Bindungen ist wie folgt:
  7762. #ifndef NO_symbolflags
  7763.   Offset  Stack-Inhalt
  7764.   12+8n
  7765.   8+8n    Wert 1
  7766.   4+8n    Symbol 1
  7767.   ...     ...
  7768.   16      Wert n
  7769.   12      Symbol n
  7770.   8       NEXT_ENV
  7771.   4       m
  7772.   0       Frame-Info; Pointer über Frame
  7773. #else
  7774.   Offset  Stack-Inhalt
  7775.   12+12n
  7776.   8+12n   Wert 1
  7777.   4+12n   Symbol 1
  7778.   12n     Markierungsbits 1
  7779.   ...     ...
  7780.   20      Wert n
  7781.   16      Symbol n
  7782.   12      Markierungsbits n
  7783.   8       NEXT_ENV
  7784.   4       m
  7785.   0       Frame-Info; Pointer über Frame
  7786. #endif
  7787. Die Symbol/Wert-Paare sind dabei in der Reihenfolge numeriert und abgelegt,
  7788. in der die Bindungen aktiv werden (d.h. z.B. bei interpretierten Closures:
  7789. zuerst die dynamischen Referenzen (SPECIAL-Deklarationen), dann die required-
  7790. Parameter, dann die optionalen Parameter, dann der Rest-Parameter, dann die
  7791. Keyword-Parameter, dann die AUX-Variablen).
  7792. Die Symbole enthalten im Stack folgende Markierungsbits: ACTIVE_BIT, ist
  7793. gesetzt, wenn die Bindung aktiv ist, DYNAM_BIT ist gesetzt, wenn die Bindung
  7794. dynamisch ist. (Dynamische Referenzen sind als lexikalisch gekennzeichnet
  7795. mit dem speziellen Wert #SPECDECL!).
  7796. NEXT_ENV ist das nächsthöhere Variablen-Environment.
  7797. m ist ein Langwort, 0 <= m <= n, und bedeutet die Anzahl der Bindungen, die
  7798. noch nicht durch NEST-Operationen in einen Vektor gesteckt wurden. Also
  7799. sind die Symbol/Wert-Paare 1,...,n-m aktiv gewesen, inzwischen aber genestet
  7800. und deswegen im Stack (sofern es statische Bindungen waren) wieder inaktiv.
  7801. Nur noch einige der Paare n-m+1,...,n können statisch und aktiv sein.
  7802. Der Inhalt des Frameinfo-Bytes ist VAR_FRAME_INFO.
  7803.  
  7804. Funktions- und Macrobindungs-Frames
  7805. -----------------------------------
  7806. Sie werden erzeugt von FLET und MACROLET.
  7807. Der Aufbau eines Variablenbindungs-Frames mit n Bindungen ist wie folgt:
  7808.   Offset  Stack-Inhalt
  7809.   12+8n
  7810.   8+8n    Wert 1
  7811.   4+8n    Symbol 1
  7812.   ...     ...
  7813.   16      Wert n
  7814.   12      Symbol n
  7815.   8       NEXT_ENV
  7816.   4       m
  7817.   0       Frame-Info; Pointer über Frame
  7818. NEXT_ENV ist das nächsthöhere Funktions-Environment.
  7819. m ist ein Langwort, 0 <= m <= n, und bedeutet die Anzahl der Bindungen, die
  7820. noch nicht durch NEST-Operationen in einen Vektor gesteckt wurden. Also sind
  7821. die Symbol/Wert-Paare 1,...,n-m aktiv gewesen, inzwischen aber genestet und
  7822. deswegen im Stack wieder inaktiv. Nur noch die Paare n-m+1,...,n sind aktiv.
  7823. Markierungsbits werden hier im Gegensatz zu den Variablenbindungs-Frames
  7824. nicht benötigt.
  7825. Alle Werte sind Closures oder Conses (SYSTEM::MACRO . Closure).
  7826. Der Inhalt des Frameinfo-Bytes ist FUN_FRAME_INFO.
  7827.  
  7828. Interpretierte Block-Frames
  7829. ---------------------------
  7830. Sie werden erzeugt von BLOCK und allen Konstrukten, die ein implizites BLOCK
  7831. enthalten (z.B. DO, DO*, LOOP, PROG, PROG*, ...). Der Aufbau ist folgender:
  7832.   Offset  Stack-Inhalt
  7833.   16
  7834.   12       NAME
  7835.   8        NEXT_ENV
  7836.   4        SP
  7837.   0        Frame-Info; Pointer über Frame
  7838. NAME ist der Name des Blocks. NEXT_ENV ist das nächsthöhere Block-Environment.
  7839. SP ist ein Pointer in den Programmstack, (SP).L ist eine Routine, die den
  7840. Block-Frame auflöst und den Block mit den Werten A0-A2/... verläßt.
  7841. Frame-Info ist IBLOCK_FRAME_INFO, evtl. mit gesetztem NESTED_BIT (dann zeigt
  7842. NEXT_ENV auf eine Aliste, deren erstes Element das Paar (NAME . <Framepointer>)
  7843. ist, weil der Block noch nicht DISABLED ist).
  7844.  
  7845. Compilierte Block-Frames
  7846. ------------------------
  7847. Aufbau:
  7848.   Offset  Stack-Inhalt
  7849.    12
  7850.    8        Cons (NAME . <Framepointer>)
  7851.    4        SP
  7852.    0        Frame-Info; Pointer über Frame
  7853. NAME ist der Name des Blocks.
  7854. SP ist ein Pointer in den Programmstack, (SP).L ist eine Routine, die den
  7855. Block-Frame auflöst und den Block mit den Werten A0-A2/... verläßt.
  7856. Frame-Info ist CBLOCK_FRAME_INFO.
  7857.  
  7858. Interpretierte Tagbody-Frames
  7859. -----------------------------
  7860. Sie werden erzeugt von TAGBODY und allen Konstrukten, die ein implizites
  7861. TAGBODY enthalten (z.B. DO, DO*, PROG, PROG*, ...).
  7862. Der Aufbau eines Tagbody-Frames mit n Tags ist folgender:
  7863.   Offset  Stack-Inhalt
  7864.   12+8n
  7865.   8+8n     BODY 1
  7866.   4+8n     MARKE 1
  7867.   ...      ...
  7868.   16       BODY n
  7869.   12       MARKE n
  7870.   8        NEXT_ENV
  7871.   4        SP
  7872.   0        Frame-Info; Pointer über Frame
  7873. Die Marken sind die Sprungziele; es sind Symbole ud Integers, die sich im
  7874. Body befinden. Der zugehörige "Wert" BODY i enthält den Teil des Bodys, der
  7875. auf MARKE i folgt. NEXT_ENV ist das nächsthöhere Tagbody-Environment.
  7876. SP ist ein Pointer in den Programmstack, (SP).L ist eine Routine, die die
  7877. Aktion (GO MARKEi) ausführt, wenn sie mit BODYi in A0 angesprungen wird.
  7878. Frame-Info ist ITAGBODY_FRAME_INFO, evtl. mit gesetztem NESTED_BIT (dann
  7879. zeigt NEXT_ENV auf eine Aliste, deren erstes Element die Form
  7880. (#(MARKE1 ... MARKEn) . <Framepointer>) hat, weil der Tagbody noch nicht
  7881. DISABLED ist).
  7882.  
  7883. Compilierte Tagbody-Frames
  7884. --------------------------
  7885. Aufbau:
  7886.   Offset  Stack-Inhalt
  7887.    12
  7888.    8        Cons (#(MARKE1 ... MARKEn) . <Framepointer>)
  7889.    4        SP
  7890.    0        Frame-Info; Pointer über Frame
  7891. MARKE1, ..., MARKEn sind die Namen der Tags (im compilierten Code eigentlich
  7892. nur noch zu Fehlermeldungszwecken vorhanden).
  7893. SP ist ein Pointer in den Programmstack, (SP).L ist eine Routine, die die
  7894. Aktion (GO MARKEi) ausführt, wenn sie mit value1 = i (1 <= i <= n) angesprungen
  7895. wird.
  7896. Frame-Info ist CTAGBODY_FRAME_INFO.
  7897.  
  7898. Catch-Frames
  7899. ------------
  7900. Sie werden erzeugt von der Special-Form CATCH. Ihr Aufbau ist wie folgt:
  7901.   Offset  Stack-Inhalt
  7902.    12
  7903.    8        TAG
  7904.    4        SP
  7905.    0        Frame-Info; Pointer über Frame
  7906. Dabei ist TAG die Marke des Catchers.
  7907. SP ist ein Pointer in den Programmstack, (SP).L ist eine Routine, die den
  7908. Frame auflöst und die Werte A0-A2/... zurückgibt.
  7909. Frame-Info ist CATCH_FRAME_INFO.
  7910.  
  7911. Unwind-Protect-Frames
  7912. ---------------------
  7913. Sie werden erzeugt von der Special-Form UNWIND-PROTECT und allen Konstrukten,
  7914. die ein implizites UNWIND-PROTECT enthalten (wie WITH-OPEN-STREAM oder
  7915. WITH-OPEN-FILE). Ihr Aufbau ist wie folgt:
  7916.   Offset  Stack-Inhalt
  7917.    8
  7918.    4        SP
  7919.    0        Frame-Info; Pointer über Frame
  7920. SP ist ein Pointer in den Programmstack. (SP).L ist eine Routine, die den
  7921. Frame auflöst, die aktuellen Werte A0-A2/... rettet, den Cleanup durchführt,
  7922. die geretteten Werte zurückschreibt und schließlich die Adresse anspringt
  7923. (mit RTS), die anstelle ihrer eigenen im Programmstack eingetragen wurde,
  7924. und dabei D6 unverändert läßt.
  7925.  
  7926. Handler-Frames
  7927. --------------
  7928. Sie werden erzeugt vom Macro HANDLER-BIND. Ihr Aufbau ist wie folgt:
  7929.   Offset  Stack-Inhalt
  7930.    16
  7931.    12       Cons (#(type1 label1 ... typem labelm) . SPdepth)
  7932.    8        Closure
  7933.    4        SP
  7934.    0        Frame-Info; Pointer über Frame
  7935. SP ist ein Pointer in den Programmstack. Wenn eine Condition vom Typ typei
  7936. auftritt, wird als Handler die Closure ab Byte labeli abinterpretiert, wobei
  7937. zuerst ein Stück Programmstack der Länge SPdepth dupliziert wird.
  7938.  
  7939. Driver-Frames
  7940. -------------
  7941. Sie werden erzeut beim Eintritt in eine Top-Level-Schleife (meist eine
  7942. READ-EVAL-PRINT-Schleife) und dienen dazu, nach Fehlermeldungen die
  7943. vorherige Top-Level-Schleife fortzusetzen. Der Aufbau ist einfach:
  7944.   Offset  Stack-Inhalt
  7945.    8
  7946.    4        SP
  7947.    0        Frame-Info; Pointer über Frame
  7948. SP ist ein Pointer in den Programmstack. (SP).L ist eine Routine, die
  7949. wieder in die zugehörige Top-Level-Schleife einsteigt.
  7950.  
  7951. */
  7952.  
  7953. # STACK:
  7954. # STACK ist der LISP-Stack.
  7955. # STACK_0 ist das erste Objekt auf dem STACK.
  7956. # STACK_1 ist das zweite Objekt auf dem STACK.
  7957. # etc., allgemein STACK_(n) = (n+1)tes Objekt auf dem STACK.
  7958. # pushSTACK(object)  legt ein Objekt auf dem STACK ab. Synonym: -(STACK).
  7959. # popSTACK()  liefert STACK_0 und nimmt es dabei vom STACK herunter.
  7960. # skipSTACK(n);  nimmt n Objekte vom STACK herunter.
  7961. # Will man den Wert des STACK retten, so geht das so:
  7962. #   var object* temp = STACK; ... (kein Zugriff über temp !) ... setSTACK(STACK = temp);
  7963. #   jedoch: Zugriff über  STACKpointable(temp)  möglich.
  7964. # Will man einen Pointer, der durch den Stack laufen kann, so geht das so:
  7965. #   var object* ptr = &STACK_0;  oder  = STACKpointable(STACK);
  7966. #   assert( *(ptr STACKop 0) == STACK_0 );
  7967. #   assert( *(ptr STACKop 1) == STACK_1 );
  7968. #   ...
  7969. #   ptr skipSTACKop n;
  7970. #   assert( *(ptr STACKop 0) == STACK_(n) );
  7971. #   ...
  7972. #   Dieser Pointer darf nicht wieder dem STACK zugewiesen werden!
  7973. # Bringt man im STACK Blöcke von Objekten unter und will den (n+1)-ten Block,
  7974. #   so geht das so:  STACKblock_(type,n). Dabei sollte type ein
  7975. #   struct-Typ sein mit sizeof(type) ein Vielfaches  von sizeof(object).
  7976.  
  7977.   #ifdef STACK_DOWN
  7978.     #define STACK_(n)  (STACK[(sintP)(n)])
  7979.     #define STACKpointable(STACKvar)  ((object*)(STACKvar))
  7980.     #define skipSTACKop  +=
  7981.     #define STACKop      +
  7982.     #define cmpSTACKop   <
  7983.     #define STACKblock_(type,n)  (((type*)STACK)[(sintP)(n)])
  7984.   #endif
  7985.   #ifdef STACK_UP
  7986.     #define STACK_(n)  (STACK[-1-(sintP)(n)])
  7987.     #define STACKpointable(STACKvar)  ((object*)(STACKvar)-1)
  7988.     #define skipSTACKop  -=
  7989.     #define STACKop      -
  7990.     #define cmpSTACKop   >
  7991.     #define STACKblock_(type,n)  (((type*)STACK)[-1-(sintP)(n)])
  7992.   #endif
  7993.   #define pushSTACK(obj)  (STACK_(-1) = (obj), STACK skipSTACKop -1)
  7994.     # Fast äquivalent zu  *--STACK = obj  bzw.  *STACK++ = obj  , jedoch
  7995.     # Vorsicht: erst Objekt in STACK_(-1) eintragen, dann erst STACK verändern!
  7996.   #define popSTACK()  (STACK skipSTACKop 1, STACK_(-1))
  7997.   #define skipSTACK(n)  (STACK skipSTACKop (sintP)(n))
  7998.  
  7999.   #if defined(GNU) && defined(MC680X0) && !defined(NO_ASM) && !defined(WIDE)
  8000.     # Mit GNU auf einem 680X0 liegt STACK in einem Register. Zugriff und
  8001.     # Veränderung von STACK bilden daher eine ununterbrechbare Einheit.
  8002.     #undef pushSTACK
  8003.     #undef popSTACK
  8004.     #ifdef STACK_DOWN
  8005.       # define pushSTACK(obj)  (*--STACK = (obj))
  8006.       #define pushSTACK(obj)  \
  8007.         ({ __asm__ __volatile__ ("movel %0,"REGISTER_PREFIX""STACK_register"@-" : : "g" ((object)(obj)) : STACK_register ); })
  8008.       # define popSTACK()  (*STACK++)
  8009.       #define popSTACK()  \
  8010.         ({var object __result;                                                                                         \
  8011.           __asm__ __volatile__ ("movel "REGISTER_PREFIX""STACK_register"@+,%0" : "=g" (__result) : : STACK_register ); \
  8012.           __result;                                                                                                    \
  8013.          })
  8014.     #endif
  8015.     #ifdef STACK_UP
  8016.       # define pushSTACK(obj)  (*STACK++ = (obj))
  8017.       #define pushSTACK(obj)  \
  8018.         ({ __asm__ __volatile__ ("movel %0,"REGISTER_PREFIX""STACK_register"@+" : : "g" ((object)(obj)) : STACK_register ); })
  8019.       # define popSTACK()  (*--STACK)
  8020.       #define popSTACK()  \
  8021.         ({var object __result;                                                                                         \
  8022.           __asm__ __volatile__ ("movel "REGISTER_PREFIX""STACK_register"@-,%0" : "=g" (__result) : : STACK_register ); \
  8023.           __result;                                                                                                    \
  8024.          })
  8025.     #endif
  8026.   #endif
  8027.   #if defined(SPARC) && !defined(GNU) && !defined(__SUNPRO_C) && (SAFETY < 2)
  8028.     #undef pushSTACK
  8029.     #undef popSTACK
  8030.     #undef skipSTACK
  8031.     #define pushSTACK(obj)  (STACK_(-1) = (obj), _setSTACK(STACK STACKop -1))
  8032.     #define popSTACK()  (_setSTACK(STACK STACKop 1), STACK_(-1))
  8033.     #define skipSTACK(n)  (_setSTACK(STACK STACKop (sintP)(n)))
  8034.   #endif
  8035.  
  8036.   #define STACK_0  (STACK_(0))
  8037.   #define STACK_1  (STACK_(1))
  8038.   #define STACK_2  (STACK_(2))
  8039.   #define STACK_3  (STACK_(3))
  8040.   #define STACK_4  (STACK_(4))
  8041.   #define STACK_5  (STACK_(5))
  8042.   #define STACK_6  (STACK_(6))
  8043.   #define STACK_7  (STACK_(7))
  8044.   #define STACK_8  (STACK_(8))
  8045.   #define STACK_9  (STACK_(9))
  8046.   #define STACK_10  (STACK_(10))
  8047.   # usw.
  8048.  
  8049.  
  8050. # Werte:
  8051.  
  8052. # Maximalzahl multiple values + 1
  8053.   #define mv_limit  128
  8054. # Werte werden immer im MULTIPLE_VALUE_SPACE mv_space übergeben:
  8055.   # uintC mv_count : Anzahl der Werte, >=0, <mv_limit
  8056.   # object mv_space [mv_limit-1] : die Werte.
  8057.   #   Bei mv_count>0 sind genau die ersten mv_count Elemente belegt.
  8058.   #   Bei mv_count=0 ist der erste Wert = NIL.
  8059.   #   Die Werte in mv_space unterliegen nicht der Garbage Collection!
  8060.   #if defined(GNU) && (SAFETY < 2)
  8061.     #if defined(SPARC)
  8062.       #define mv_count_register  "%g6"
  8063.     #endif
  8064.     #if defined(HPPA)
  8065.       #define mv_count_register  "%r11"  # eines der allgemeinen Register %r5..%r18
  8066.       #define NEED_temp_mv_count
  8067.     #endif
  8068.     #if defined(M88000)
  8069.       #define mv_count_register  "%r15"  # eines der allgemeinen Register %r14..%r25
  8070.       #define NEED_temp_mv_count
  8071.     #endif
  8072.     #if defined(DECALPHA)
  8073.       #define mv_count_register  "$10"  # eines der allgemeinen Register $9..$14
  8074.       #define NEED_temp_mv_count
  8075.     #endif
  8076.     #if defined(CONVEX)
  8077.       #define mv_count_register  "s5"
  8078.     #endif
  8079.   #endif
  8080.   #if !defined(mv_count_register)
  8081.     # eine globale Variable
  8082.     extern uintC mv_count;
  8083.   #else
  8084.     # ein globales Register
  8085.     register uintC mv_count __asm__(mv_count_register);
  8086.     #ifdef HAVE_SAVED_REGISTERS
  8087.       register long mv_count_reg __asm__(mv_count_register);
  8088.     #endif
  8089.   #endif
  8090.   extern object mv_space [mv_limit-1];
  8091.   # Synonyme:
  8092.   #if defined(GNU) && !defined(WIDE_SOFT) && (SAFETY < 2)
  8093.     #if defined(SPARC)
  8094.       #define value1_register  "%g7"
  8095.     #endif
  8096.     #if defined(HPPA)
  8097.       #define value1_register  "%r12"  # eines der allgemeinen Register %r5..%r18
  8098.       #define NEED_temp_value1
  8099.     #endif
  8100.     #if defined(M88000)
  8101.       #define value1_register  "%r16"  # eines der allgemeinen Register %r14..%r25
  8102.       #define NEED_temp_value1
  8103.     #endif
  8104.     #if defined(DECALPHA)
  8105.       #define value1_register  "$11"  # eines der allgemeinen Register $9..$14
  8106.       #define NEED_temp_value1
  8107.     #endif
  8108.     #if defined(CONVEX)
  8109.       #define value1_register  "s6"
  8110.     #endif
  8111.   #endif
  8112.   #if !defined(value1_register)
  8113.     #define value1  mv_space[0]
  8114.   #else
  8115.     # Der erste Wert mv_space[0] wird permanent in einem Register gelagert:
  8116.     register object value1 __asm__(value1_register);
  8117.     #ifdef HAVE_SAVED_REGISTERS
  8118.       register long value1_reg __asm__(value1_register);
  8119.     #endif
  8120.     #define VALUE1_EXTRA # und muß deswegen immer extra behandelt werden...
  8121.   #endif
  8122.   #define value2  mv_space[1]
  8123.   #define value3  mv_space[2]
  8124. # Zur Übergabe mit setjmp/longjmp braucht man evtl. noch globale Variablen:
  8125.   #ifdef NEED_temp_mv_count
  8126.     extern uintC temp_mv_count;
  8127.     #define SAVE_mv_count()  temp_mv_count = mv_count
  8128.     #define RESTORE_mv_count()  mv_count = temp_mv_count
  8129.   #else
  8130.     #define SAVE_mv_count()
  8131.     #define RESTORE_mv_count()
  8132.   #endif
  8133.   #ifdef NEED_temp_value1
  8134.     extern object temp_value1;
  8135.     #define SAVE_value1()  temp_value1 = value1
  8136.     #define RESTORE_value1()  value1 = temp_value1
  8137.   #else
  8138.     #define SAVE_value1()
  8139.     #define RESTORE_value1()
  8140.   #endif
  8141. # wird verwendet von EVAL, CONTROL,
  8142. #                    Macros LIST_TO_MV, MV_TO_LIST, STACK_TO_MV, MV_TO_STACK
  8143.  
  8144. # Liefert die untersten count Objekte vom STACK als Multiple Values.
  8145. # STACK_to_mv(count)
  8146. # count: Anzahl der Objekte, < mv_limit.
  8147.   #if !defined(VALUE1_EXTRA)
  8148.     #define STACK_to_mv(countx)  \
  8149.       { var reg2 uintC count = (countx);                       \
  8150.         mv_count = count;                                      \
  8151.         if (count == 0)                                        \
  8152.           { value1 = NIL; }                                    \
  8153.           else                                                 \
  8154.           { object* mvp = &mv_space[count]; # Zeiger hinter Platz für letzten Wert \
  8155.             dotimespC(count,count, { *--mvp = popSTACK(); } ); \
  8156.       }   }
  8157.   #else
  8158.     #define STACK_to_mv(countx)  \
  8159.       { var reg2 uintC count = (countx);                           \
  8160.         mv_count = count;                                          \
  8161.         if (count == 0)                                            \
  8162.           { value1 = NIL; }                                        \
  8163.           else                                                     \
  8164.           { count--;                                               \
  8165.             if (count > 0)                                         \
  8166.               { object* mvp = &mv_space[1+count]; # Zeiger hinter Platz für letzten Wert \
  8167.                 dotimespC(count,count, { *--mvp = popSTACK(); } ); \
  8168.               }                                                    \
  8169.             value1 = popSTACK();                                   \
  8170.       }   }
  8171.   #endif
  8172. # wird verwendet von EVAL, CONTROL
  8173.  
  8174. # Legt alle Werte auf dem STACK ab.
  8175. # mv_to_STACK()
  8176. # > mv_count/mv_space : Werte
  8177. # < Werte auf dem Stack (erster Wert zuoberst)
  8178. # STACK-Overflow wird abgeprüft.
  8179. # verändert STACK
  8180.   #if !defined(VALUE1_EXTRA)
  8181.     #define mv_to_STACK()  \
  8182.       { var reg2 uintC count = mv_count;                      \
  8183.         if (count==0) ; # keine Werte -> nichts auf den STACK \
  8184.           else                                                \
  8185.           { var reg1 object* mvp = &mv_space[0];              \
  8186.             dotimespC(count,count, { pushSTACK(*mvp++); } );  \
  8187.             check_STACK();                                    \
  8188.       }   }
  8189.   #else
  8190.     #define mv_to_STACK()  \
  8191.       { var reg2 uintC count = mv_count;                         \
  8192.         if (count==0) ; # keine Werte -> nichts auf den STACK    \
  8193.           else                                                   \
  8194.           { pushSTACK(value1);                                   \
  8195.             count--;                                             \
  8196.             if (count > 0)                                       \
  8197.               { var reg1 object* mvp = &mv_space[1];             \
  8198.                 dotimespC(count,count, { pushSTACK(*mvp++); } ); \
  8199.               }                                                  \
  8200.             check_STACK();                                       \
  8201.       }   }
  8202.   #endif
  8203. # wird verwendet von EVAL, CONTROL
  8204.  
  8205. # Liefert die Elemente einer Liste als Multiple Values.
  8206. # list_to_mv(list,fehler_statement)
  8207. # fehler_statement: im Fehlerfall (zuviele Werte).
  8208.   #if !defined(VALUE1_EXTRA)
  8209.     #define list_to_mv(lst,fehler_statement)  \
  8210.       {var reg1 object l = (lst);                                              \
  8211.        var reg3 uintC count = 0;                                               \
  8212.        if (atomp(l))                                                           \
  8213.          value1 = NIL;                                                         \
  8214.          else                                                                  \
  8215.          { var reg2 object* mvp = &mv_space[0];                                \
  8216.            *mvp++ = Car(l); l = Cdr(l); count++; if (atomp(l)) goto mv_fertig; \
  8217.            *mvp++ = Car(l); l = Cdr(l); count++; if (atomp(l)) goto mv_fertig; \
  8218.            *mvp++ = Car(l); l = Cdr(l); count++; if (atomp(l)) goto mv_fertig; \
  8219.            do { *mvp++ = Car(l); l = Cdr(l);                                   \
  8220.                 count++; if (count==mv_limit) { fehler_statement; }            \
  8221.               }                                                                \
  8222.               while (consp(l));                                                \
  8223.            mv_fertig: mv_count = count;                                        \
  8224.       }  }
  8225.   #else
  8226.     #define list_to_mv(lst,fehler_statement)  \
  8227.       {var reg1 object l = (lst);                                              \
  8228.        var reg3 uintC count = 0;                                               \
  8229.        if (atomp(l))                                                           \
  8230.          value1 = NIL;                                                         \
  8231.          else                                                                  \
  8232.          { value1 = Car(l); l = Cdr(l); count++; if (atomp(l)) goto mv_fertig; \
  8233.           {var reg2 object* mvp = &mv_space[1];                                \
  8234.            *mvp++ = Car(l); l = Cdr(l); count++; if (atomp(l)) goto mv_fertig; \
  8235.            *mvp++ = Car(l); l = Cdr(l); count++; if (atomp(l)) goto mv_fertig; \
  8236.            do { *mvp++ = Car(l); l = Cdr(l);                                   \
  8237.                 count++; if (count==mv_limit) { fehler_statement; }            \
  8238.               }                                                                \
  8239.               while (consp(l));                                                \
  8240.            mv_fertig: mv_count = count;                                        \
  8241.       }  }}
  8242.   #endif
  8243. # wird verwendet von EVAL, CONTROL
  8244.  
  8245. # Liefert die Liste der Multiple Values auf -(STACK).
  8246. # mv_to_list()
  8247. # kann GC auslösen
  8248.   #define mv_to_list()  \
  8249.     { mv_to_STACK(); # erst alle Werte auf den Stack               \
  8250.       pushSTACK(NIL); # Listenanfang                               \
  8251.       { var reg2 uintC count;                                      \
  8252.         dotimesC(count,mv_count, # bis alle Werte verbraucht sind: \
  8253.           { var reg1 object l = allocate_cons(); # neue Zelle      \
  8254.             Cdr(l) = popSTACK(); # Liste bisher                    \
  8255.             Car(l) = STACK_0; # nächster Wert                      \
  8256.             STACK_0 = l; # neues Cons sichern                      \
  8257.           });                                                      \
  8258.     } }
  8259. # wird verwendet von EVAL, CONTROL, DEBUG
  8260.  
  8261. # Fehlermeldung bei zu vielen Werten
  8262. # fehler_mv_zuviel(caller);
  8263. # > caller: Aufrufer, ein Symbol
  8264.   nonreturning_function(extern, fehler_mv_zuviel, (object caller));
  8265. # wird verwendet von EVAL, CONTROL, LISPARIT
  8266.  
  8267. # Während der Ausführung eines SUBR, FSUBR: das aktuelle SUBR bzw. FSUBR.
  8268. # subr_self
  8269. # (Nur solange gültig, bis ein anderes SUBR oder eine andere Lisp-Funktion
  8270. # aufgerufen wird.)
  8271.   #if defined(GNU) && (SAFETY < 2)
  8272.     #if defined(SPARC) && !defined(WIDE)
  8273.       #define subr_self_register  "%g4"  # ein globales Register
  8274.       # Neuerdings - bei gcc 2.3 - ist %g4 offenbar ein Scratch-Register.
  8275.       # Ab libc.so.1.6.1 (in getwd()) macht das Probleme.
  8276.       # Deswegen ist oben HAVE_SAVED_SUBR_SELF definiert.
  8277.     #endif
  8278.     #if defined(HPPA) && !defined(WIDE)
  8279.       #define subr_self_register  "%r13"  # eines der allgemeinen Register %r5..%r18
  8280.     #endif
  8281.     #if defined(CONVEX)
  8282.       #define subr_self_register  "s7"
  8283.     #endif
  8284.   #endif
  8285.   #if !defined(subr_self_register)
  8286.     extern object subr_self;
  8287.   #else
  8288.     register object subr_self __asm__(subr_self_register);
  8289.     #ifdef HAVE_SAVED_REGISTERS
  8290.       register long subr_self_reg __asm__(subr_self_register);
  8291.     #endif
  8292.   #endif
  8293.  
  8294. # Innerhalb des Body eines SUBR: Zugriff auf die Argumente.
  8295. # Ein SUBR mit fester Argumentezahl kann über den STACK auf die Argumente
  8296. #   zugreifen: STACK_0 = letztes Argument, STACK_1 = vorletztes Argument etc.
  8297. #   STACK aufräumen: mit skipSTACK(Argumentezahl) .
  8298. # Ein SUBR mit beliebig vielen Argumenten (&REST-Parameter) bekommt übergeben:
  8299. #     uintC argcount              die Anzahl der restlichen Argumente
  8300. #     object* rest_args_pointer   Pointer über die restlichen Argumente
  8301. #   Zusätzlich:
  8302. #     object* args_end_pointer    Pointer unter alle Argumente, von STACK abhängig
  8303. #   Zusätzlich möglich:
  8304. #     object* args_pointer = rest_args_pointer STACKop (feste Argumentezahl);
  8305. #                                 Pointer über das erste Argument
  8306. #   Typische Abarbeitungsschleifen:
  8307. #     von vorne:
  8308. #       until (argcount==0)
  8309. #         { var object arg = NEXT(rest_args_pointer); ...; argcount--; }
  8310. #       until (rest_args_pointer==args_end_pointer)
  8311. #         { var object arg = NEXT(rest_args_pointer); ...; }
  8312. #     von hinten:
  8313. #       until (argcount==0)
  8314. #         { var object arg = BEFORE(args_end_pointer); ...; argcount--; }
  8315. #       until (rest_args_pointer==args_end_pointer)
  8316. #         { var object arg = BEFORE(args_end_pointer); ...; }
  8317. #   Die Macros NEXT und BEFORE verändern ihr Argument!
  8318. #   STACK aufräumen: mit set_args_end_pointer(args_pointer)
  8319. #     oder skipSTACK((feste Argumentezahl) + (uintL) (restliche Argumentezahl)) .
  8320.   #define args_end_pointer  STACK
  8321.   #define set_args_end_pointer(new_args_end_pointer)  \
  8322.     setSTACK(STACK = (new_args_end_pointer))
  8323.   #ifdef STACK_DOWN
  8324.     #define NEXT(argpointer)  (*(--(argpointer)))
  8325.     #define BEFORE(argpointer)  (*((argpointer)++))
  8326.   #endif
  8327.   #ifdef STACK_UP
  8328.     #define NEXT(argpointer)  (*((argpointer)++))
  8329.     #define BEFORE(argpointer)  (*(--(argpointer)))
  8330.   #endif
  8331. # Next(pointer) liefert denselben Wert wie NEXT(pointer),
  8332. # ohne dabei jedoch den Wert von pointer zu verändern.
  8333. # Before(pointer) liefert denselben Wert wie BEFORE(pointer),
  8334. # ohne dabei jedoch den Wert von pointer zu verändern.
  8335.   #define Next(pointer)  (*(STACKpointable(pointer) STACKop -1))
  8336.   #define Before(pointer)  (*(STACKpointable(pointer) STACKop 0))
  8337.  
  8338. # Environments:
  8339.  
  8340. typedef struct { object var_env;   # Variablenbindungs-Environment
  8341.                  object fun_env;   # Funktionsbindungs-Environment
  8342.                  object block_env; # Block-Environment
  8343.                  object go_env;    # Tagbody/Go-Environment
  8344.                  object decl_env;  # Deklarations-Environment
  8345.                }
  8346.         environment;
  8347.  
  8348. # Das aktuelle Environment:
  8349.   # extern environment aktenv;
  8350. # ist ein Teil der Objekttabelle:
  8351. # O(akt_var_env), O(akt_fun_env), O(akt_block_env), O(akt_go_env), O(akt_decl_env).
  8352.   #define aktenv  (*(environment*)(&O(akt_var_env)))
  8353.  
  8354. # Frameinfobits in Frames:
  8355. # im Frame-Info-Byte (tint):
  8356. #if (oint_type_len>=7) && 0 # vorläufig??
  8357. # Bitnummern im Frame-Info-Byte:
  8358. # belegen Bits 6..0 (bzw. Bits 7,5..0 falls garcol_bit_t=7).
  8359.   #define FB7  garcol_bit_t
  8360.   #define FB6  (garcol_bit_t>TB5 ? TB5 : TB6)
  8361.   #define FB5  (garcol_bit_t>TB4 ? TB4 : TB5)
  8362.   #define FB4  (garcol_bit_t>TB3 ? TB3 : TB4)
  8363.   #define FB3  (garcol_bit_t>TB2 ? TB2 : TB3)
  8364.   #define FB2  (garcol_bit_t>TB1 ? TB1 : TB2)
  8365.   #define FB1  (garcol_bit_t>TB0 ? TB0 : TB1)
  8366. # davon abhängig:
  8367.   #define frame_bit_t    FB7  # garcol_bit als FRAME-Kennzeichen
  8368.   #define skip2_bit_t    FB6  # gelöscht wenn GC zwei Langworte überspringen muß
  8369.   #define unwind_bit_t   FB5  # gesetzt, wenn beim Auflösen (UNWIND) des Frames
  8370.                               # etwas zu tun ist
  8371.   # skip2-Bit=1 ==> unwind-Bit=1.
  8372.   # zur näheren Information innerhalb der Frames mit skip2-Bit=1:
  8373.     #define envbind_bit_t  FB4  # Bit ist gesetzt bei ENV-Frames.
  8374.                                 # Bit ist gelöscht bei DYNBIND-Frames.
  8375.     # zur näheren Identifikation innerhalb der ENV-Frames:
  8376.       #define envbind_case_mask_t  (bit(FB3)|bit(FB2)|bit(FB1))
  8377.   # zur näheren Unterscheidung innerhalb der Frames mit skip2-Bit=0:
  8378.     #define entrypoint_bit_t  FB4  # Bit ist gesetzt, wenn FRAME einen
  8379.                                    # nicht-lokalen Einsprung enthält, mit Offset SP_ ist SP im STACK.
  8380.                                    # Bit ist gelöscht bei VAR-Frame und FUN-Frame.
  8381.     # zur näheren Unterscheidung in BLOCK/TAGBODY/APPLY/EVAL/CATCH/UNWIND_PROTECT/HANDLER/DRIVER:
  8382.       #define blockgo_bit_t    FB3  # Bit gesetzt bei BLOCK- und TAGBODY-FRAME
  8383.       # zur näheren Unterscheidung in BLOCK/TAGBODY:
  8384.         # Bit FB2 gesetzt bei TAGBODY, gelöscht bei BLOCK,
  8385.         #define cframe_bit_t     FB1  # gesetzt bei compilierten, gelöscht bei
  8386.                                     # interpretierten BLOCK/TAGBODY-Frames
  8387.         #define nested_bit_t unwind_bit_t # für IBLOCK und ITAGBODY, gesetzt,
  8388.                                     # wenn Exitpoint bzw. Tags genestet wurden
  8389.       # zur näheren Unterscheidung in APPLY/EVAL/CATCH/UNWIND_PROTECT/HANDLER/DRIVER:
  8390.         #define dynjump_bit_t  FB2    # gelöscht bei APPLY und EVAL, gesetzt
  8391.                                       # bei CATCH/UNWIND_PROTECT/DRIVER-Frames
  8392.         #define trapped_bit_t unwind_bit_t # für APPLY und EVAL, gesetzt, wenn
  8393.                                     # beim Auflösen des Frames unterbrochen wird
  8394.         # unwind-Bit gesetzt bei UNWIND_PROTECT/DRIVER/TRAPPED_APPLY/TRAPPED_EVAL,
  8395.         # gelöscht sonst.
  8396.         #define eval_bit_t     FB1    # gesetzt bei EVAL-Frames,
  8397.                                       # gelöscht bei APPLY-Frames
  8398.         #define driver_bit_t   FB1    # gesetzt bei DRIVER-Frames,
  8399.                                       # gelöscht bei UNWIND_PROTECT-Frames
  8400.         #define handler_bit_t  FB1    # gesetzt bei HANDLER-Frames,
  8401.                                       # gelöscht bei CATCH-Frames
  8402.     # zur näheren Unterscheidung in VAR/FUN:
  8403.       #define fun_bit_t        FB3  # gesetzt bei FUNCTION-FRAME, gelöscht bei VAR-FRAME
  8404. # in Objekten auf dem STACK (oint):
  8405.   #define frame_bit_o  (frame_bit_t+oint_type_shift)
  8406.   #define skip2_bit_o  (skip2_bit_t+oint_type_shift)
  8407.   #define unwind_bit_o  (unwind_bit_t+oint_type_shift)
  8408.     #define envbind_bit_o  (envbind_bit_t+oint_type_shift)
  8409.     #define entrypoint_bit_o  (entrypoint_bit_t+oint_type_shift)
  8410.       #define blockgo_bit_o  (blockgo_bit_t+oint_type_shift)
  8411.         #define cframe_bit_o  (cframe_bit_t+oint_type_shift)
  8412.         #define nested_bit_o  (nested_bit_t+oint_type_shift)
  8413.         #define dynjump_bit_o  (dynjump_bit_t+oint_type_shift)
  8414.         #define trapped_bit_o  (trapped_bit_t+oint_type_shift)
  8415.         #define eval_bit_o  (eval_bit_t+oint_type_shift)
  8416.         #define driver_bit_o  (driver_bit_t+oint_type_shift)
  8417.         #define handler_bit_o  (handler_bit_t+oint_type_shift)
  8418.       #define fun_bit_o  (fun_bit_t+oint_type_shift)
  8419. # einzelne Frame-Info-Bytes:
  8420.   #define DYNBIND_frame_info          /* %1110... */ (bit(FB7)|bit(FB6)|bit(FB5))
  8421.   #define ENV1V_frame_info            /* %1111000 */ (bit(FB7)|bit(FB6)|bit(FB5)|bit(FB4))
  8422.   #define ENV1F_frame_info            /* %1111001 */ (bit(FB7)|bit(FB6)|bit(FB5)|bit(FB4)|bit(FB1))
  8423.   #define ENV1B_frame_info            /* %1111010 */ (bit(FB7)|bit(FB6)|bit(FB5)|bit(FB4)|bit(FB2))
  8424.   #define ENV1G_frame_info            /* %1111011 */ (bit(FB7)|bit(FB6)|bit(FB5)|bit(FB4)|bit(FB2)|bit(FB1))
  8425.   #define ENV1D_frame_info            /* %1111100 */ (bit(FB7)|bit(FB6)|bit(FB5)|bit(FB4)|bit(FB3))
  8426.   #define ENV2VD_frame_info           /* %1111101 */ (bit(FB7)|bit(FB6)|bit(FB5)|bit(FB4)|bit(FB3)|bit(FB1))
  8427.   #define ENV5_frame_info             /* %1111110 */ (bit(FB7)|bit(FB6)|bit(FB5)|bit(FB4)|bit(FB3)|bit(FB2))
  8428.   #define VAR_frame_info              /* %10100.. */ (bit(FB7)|bit(FB5))
  8429.   #define FUN_frame_info              /* %10101.. */ (bit(FB7)|bit(FB5)|bit(FB3))
  8430.   #define IBLOCK_frame_info           /* %1001100 */ (bit(FB7)|bit(FB4)|bit(FB3))
  8431.   #define NESTED_IBLOCK_frame_info    /* %1011100 */ (bit(FB7)|bit(FB5)|bit(FB4)|bit(FB3))
  8432.   #define CBLOCK_frame_info           /* %1011101 */ (bit(FB7)|bit(FB5)|bit(FB4)|bit(FB3)|bit(FB1))
  8433.   #define ITAGBODY_frame_info         /* %1001110 */ (bit(FB7)|bit(FB4)|bit(FB3)|bit(FB2))
  8434.   #define NESTED_ITAGBODY_frame_info  /* %1011110 */ (bit(FB7)|bit(FB5)|bit(FB4)|bit(FB3)|bit(FB2))
  8435.   #define CTAGBODY_frame_info         /* %1011111 */ (bit(FB7)|bit(FB5)|bit(FB4)|bit(FB3)|bit(FB2)|bit(FB1))
  8436.   #define APPLY_frame_info            /* %1001000 */ (bit(FB7)|bit(FB4))
  8437.   #define TRAPPED_APPLY_frame_info    /* %1011000 */ (bit(FB7)|bit(FB5)|bit(FB4))
  8438.   #define EVAL_frame_info             /* %1001001 */ (bit(FB7)|bit(FB4)|bit(FB1))
  8439.   #define TRAPPED_EVAL_frame_info     /* %1011001 */ (bit(FB7)|bit(FB5)|bit(FB4)|bit(FB1))
  8440.   #define CATCH_frame_info            /* %1001010 */ (bit(FB7)|bit(FB4)|bit(FB2))
  8441.   #define HANDLER_frame_info          /* %1001011 */ (bit(FB7)|bit(FB4)|bit(FB2)|bit(FB1))
  8442.   #define UNWIND_PROTECT_frame_info   /* %1011010 */ (bit(FB7)|bit(FB5)|bit(FB4)|bit(FB2))
  8443.   #define DRIVER_frame_info           /* %1011011 */ (bit(FB7)|bit(FB5)|bit(FB4)|bit(FB2)|bit(FB1))
  8444. #endif
  8445. #if (oint_type_len==6) || 1 # vorläufig??
  8446. # Bitnummern im Frame-Info-Byte:
  8447. # belegen Bits 5..0 (bzw. Bits 7,4..0 falls garcol_bit_t=7).
  8448.   #define FB6  garcol_bit_t
  8449.   #define FB5  (garcol_bit_t>TB4 ? TB4 : TB5)
  8450.   #define FB4  (garcol_bit_t>TB3 ? TB3 : TB4)
  8451.   #define FB3  (garcol_bit_t>TB2 ? TB2 : TB3)
  8452.   #define FB2  (garcol_bit_t>TB1 ? TB1 : TB2)
  8453.   #define FB1  (garcol_bit_t>TB0 ? TB0 : TB1)
  8454. # davon abhängig:
  8455.   #define frame_bit_t    FB6  # garcol_bit als FRAME-Kennzeichen
  8456.   #define skip2_bit_t    FB5  # gelöscht wenn GC zwei Langworte überspringen muß
  8457.   # define unwind_limit_t  ...  # darüber:
  8458.                               # ist beim Auflösen (UNWIND) des Frames etwas zu tun
  8459.   # skip2-Bit=1 ==> >= unwind-limit.
  8460.   # zur näheren Information innerhalb der Frames mit skip2-Bit=1:
  8461.     #define envbind_bit_t  FB4  # Bit ist gesetzt bei ENV-Frames.
  8462.                                 # Bit ist gelöscht bei DYNBIND-Frames.
  8463.     # zur näheren Identifikation innerhalb der ENV-Frames:
  8464.       #define envbind_case_mask_t  (bit(FB3)|bit(FB2)|bit(FB1))
  8465.   # zur näheren Unterscheidung innerhalb der Frames mit skip2-Bit=0:
  8466.     # define entrypoint_limit_t  ...  # darunter:
  8467.                                    # wenn FRAME einen nicht-lokalen Einsprung enthält,
  8468.                                    # mit Offset SP_ ist SP im STACK.
  8469.                                    # darüber: bei VAR-Frame und FUN-Frame.
  8470.     # zur näheren Unterscheidung in BLOCK/TAGBODY/APPLY/EVAL/CATCH/UNWIND_PROTECT/HANDLER/DRIVER:
  8471.       #define blockgo_bit_t    FB3  # Bit gesetzt bei BLOCK- und TAGBODY-FRAME
  8472.       # zur näheren Unterscheidung in BLOCK/TAGBODY:
  8473.         # Bit FB1 gesetzt bei TAGBODY, gelöscht bei BLOCK,
  8474.         #define cframe_bit_t   FB2  # gesetzt bei compilierten, gelöscht bei
  8475.                                     # interpretierten BLOCK/TAGBODY-Frames
  8476.         #define nested_bit_t   FB4  # für IBLOCK und ITAGBODY, gesetzt,
  8477.                                     # wenn Exitpoint bzw. Tags genestet wurden
  8478.       # zur näheren Unterscheidung in APPLY/EVAL/CATCH/UNWIND_PROTECT/HANDLER/DRIVER:
  8479.         #define dynjump_bit_t  FB2  # gelöscht bei APPLY und EVAL, gesetzt
  8480.                                     # bei CATCH/UNWIND_PROTECT/HANDLER/DRIVER-Frames
  8481.         #define trapped_bit_t  FB4  # für APPLY und EVAL, gesetzt, wenn
  8482.                                     # beim Auflösen des Frames unterbrochen wird
  8483.         # >= unwind_limit_t bei UNWIND_PROTECT/DRIVER/TRAPPED_APPLY/TRAPPED_EVAL,
  8484.         # < unwind_limit_t sonst.
  8485.         #define eval_bit_t     FB1  # gesetzt bei EVAL-Frames,
  8486.                                     # gelöscht bei APPLY-Frames
  8487.         #define driver_bit_t   FB1  # gesetzt bei DRIVER-Frames,
  8488.                                     # gelöscht bei UNWIND_PROTECT-Frames
  8489.         #define handler_bit_t  FB1  # gesetzt bei HANDLER-Frames,
  8490.                                     # gelöscht bei CATCH-Frames
  8491.     # zur näheren Unterscheidung in VAR/FUN:
  8492.       #define fun_bit_t        FB1  # gesetzt bei FUNCTION-FRAME, gelöscht bei VAR-FRAME
  8493. # in Objekten auf dem STACK (oint):
  8494.   #define frame_bit_o  (frame_bit_t+oint_type_shift)
  8495.   #define skip2_bit_o  (skip2_bit_t+oint_type_shift)
  8496.     #define envbind_bit_o  (envbind_bit_t+oint_type_shift)
  8497.       #define blockgo_bit_o  (blockgo_bit_t+oint_type_shift)
  8498.         #define cframe_bit_o  (cframe_bit_t+oint_type_shift)
  8499.         #define nested_bit_o  (nested_bit_t+oint_type_shift)
  8500.         #define dynjump_bit_o  (dynjump_bit_t+oint_type_shift)
  8501.         #define trapped_bit_o  (trapped_bit_t+oint_type_shift)
  8502.         #define eval_bit_o  (eval_bit_t+oint_type_shift)
  8503.         #define driver_bit_o  (driver_bit_t+oint_type_shift)
  8504.         #define handler_bit_o  (handler_bit_t+oint_type_shift)
  8505.       #define fun_bit_o  (fun_bit_t+oint_type_shift)
  8506. # einzelne Frame-Info-Bytes:
  8507.   #define APPLY_frame_info            /* %100000 */ (bit(FB6))
  8508.   #define EVAL_frame_info             /* %100001 */ (bit(FB6)|bit(FB1))
  8509.   #define CATCH_frame_info            /* %100010 */ (bit(FB6)|bit(FB2))
  8510.   #define HANDLER_frame_info          /* %100011 */ (bit(FB6)|bit(FB2)|bit(FB1))
  8511.   #define IBLOCK_frame_info           /* %100100 */ (bit(FB6)|bit(FB3))
  8512.   #define ITAGBODY_frame_info         /* %100101 */ (bit(FB6)|bit(FB3)|bit(FB1))
  8513.   #define unwind_limit_t                            (bit(FB6)|bit(FB3)|bit(FB2))
  8514.   #define CBLOCK_frame_info           /* %100110 */ (bit(FB6)|bit(FB3)|bit(FB2))
  8515.   #define CTAGBODY_frame_info         /* %100111 */ (bit(FB6)|bit(FB3)|bit(FB2)|bit(FB1))
  8516.   #define TRAPPED_APPLY_frame_info    /* %101000 */ (bit(FB6)|bit(FB4))
  8517.   #define TRAPPED_EVAL_frame_info     /* %101001 */ (bit(FB6)|bit(FB4)|bit(FB1))
  8518.   #define UNWIND_PROTECT_frame_info   /* %101010 */ (bit(FB6)|bit(FB4)|bit(FB2))
  8519.   #define DRIVER_frame_info           /* %101011 */ (bit(FB6)|bit(FB4)|bit(FB2)|bit(FB1))
  8520.   #define NESTED_IBLOCK_frame_info    /* %101100 */ (bit(FB6)|bit(FB4)|bit(FB3))
  8521.   #define NESTED_ITAGBODY_frame_info  /* %101101 */ (bit(FB6)|bit(FB4)|bit(FB3)|bit(FB1))
  8522.   #define entrypoint_limit_t                        (bit(FB6)|bit(FB4)|bit(FB3)|bit(FB2))
  8523.   #define VAR_frame_info              /* %101110 */ (bit(FB6)|bit(FB4)|bit(FB3)|bit(FB2))
  8524.   #define FUN_frame_info              /* %101111 */ (bit(FB6)|bit(FB4)|bit(FB3)|bit(FB2)|bit(FB1))
  8525.   #define DYNBIND_frame_info          /* %110... */ (bit(FB6)|bit(FB5))
  8526.   #define ENV1V_frame_info            /* %111000 */ (bit(FB6)|bit(FB5)|bit(FB4))
  8527.   #define ENV1F_frame_info            /* %111001 */ (bit(FB6)|bit(FB5)|bit(FB4)|bit(FB1))
  8528.   #define ENV1B_frame_info            /* %111010 */ (bit(FB6)|bit(FB5)|bit(FB4)|bit(FB2))
  8529.   #define ENV1G_frame_info            /* %111011 */ (bit(FB6)|bit(FB5)|bit(FB4)|bit(FB2)|bit(FB1))
  8530.   #define ENV1D_frame_info            /* %111100 */ (bit(FB6)|bit(FB5)|bit(FB4)|bit(FB3))
  8531.   #define ENV2VD_frame_info           /* %111101 */ (bit(FB6)|bit(FB5)|bit(FB4)|bit(FB3)|bit(FB1))
  8532.   #define ENV5_frame_info             /* %111110 */ (bit(FB6)|bit(FB5)|bit(FB4)|bit(FB3)|bit(FB2))
  8533. #endif
  8534.  
  8535. # Bits für Symbole in VAR-Frames:
  8536.   # bit(active_bit),bit(dynam_bit),bit(svar_bit) müssen in ein uintB passen:
  8537.   #if !((active_bit<intBsize) && (dynam_bit<intBsize) && (svar_bit<intBsize))
  8538.     #error "Symbol bits don't fit in a single byte -- Symbol-Bits passen nicht in ein Byte!"
  8539.   #endif
  8540.   #ifdef NO_symbolflags
  8541.     # Bits werden im Stack separat als Fixnums abgelegt.
  8542.     #undef oint_symbolflags_shift
  8543.     #define oint_symbolflags_shift  oint_addr_shift
  8544.   #else
  8545.     #if (oint_symbolflags_shift==oint_addr_shift)
  8546.       # bit(active_bit),bit(dynam_bit),bit(svar_bit) müssen echte Teiler
  8547.       # von varobject_alignment sein:
  8548.       #if (varobject_alignment % bit(active_bit+1)) || (varobject_alignment % bit(dynam_bit+1)) || (varobject_alignment % bit(svar_bit+1))
  8549.         #error "No more room for three bits in a symbol -- Kein Platz für drei Bits in der Adresse eines Symbols!"
  8550.       #endif
  8551.     #endif
  8552.   #endif
  8553.   #define active_bit_o  (active_bit+oint_symbolflags_shift)  # gesetzt: Bindung ist aktiv
  8554.   #define dynam_bit_o   (dynam_bit+oint_symbolflags_shift)   # gesetzt: Bindung ist dynamisch
  8555.   #define svar_bit_o    (svar_bit+oint_symbolflags_shift)    # gesetzt: nächster Parameter ist supplied-p-Parameter für diesen
  8556.  
  8557. # Offsets für Daten in Frames, über STACK_(Offset) zu adressieren:
  8558.   #define frame_form      2  # EVAL
  8559.   #define frame_closure   2  # APPLY, HANDLER
  8560.   #define frame_anz       1  # VAR, FUN
  8561.   #define frame_SP        1  # IBLOCK, CBLOCK, ITAGBODY, CTAGBODY,
  8562.                              # EVAL, CATCH, UNWIND-PROTECT, HANDLER, DRIVER
  8563.   #define frame_next_env  2  # VAR, FUN, IBLOCK, ITAGBODY
  8564.   #define frame_ctag      2  # CBLOCK, CTAGBODY
  8565.   #define frame_tag       2  # CATCH
  8566.   #define frame_handlers  3  # HANDLER
  8567.   #define frame_name      3  # IBLOCK
  8568.   #define frame_args      3  # APPLY
  8569.   #define frame_bindings  3  # VAR, FUN, ITAGBODY
  8570. # Aufbau einzelner Bindungen in VAR-Frames:
  8571.   #ifdef NO_symbolflags
  8572.     #define varframe_binding_size  3
  8573.     #define varframe_binding_mark   0
  8574.     #define varframe_binding_sym    1
  8575.     #define varframe_binding_value  2
  8576.     #define pushSTACK_symbolwithflags(symbol,flags)  \
  8577.       pushSTACK(symbol); pushSTACK(as_object(as_oint(Fixnum_0) | (oint)(flags)))
  8578.   #else
  8579.     #define varframe_binding_size  2
  8580.     #define varframe_binding_mark   0
  8581.     #define varframe_binding_sym    0
  8582.     #define varframe_binding_value  1
  8583.     #define pushSTACK_symbolwithflags(symbol,flags)  \
  8584.       pushSTACK(as_object(as_oint(symbol) | (oint)(flags)))
  8585.   #endif
  8586.  
  8587. # Spezieller Wert zur Markierung nicht mehr "lebender" BLOCK- und TAGBODY-
  8588. # Referenzen (ersetzt den Frame-Pointer im CDR des entsprechenden Cons)
  8589.   #define disabled  make_system(0xDDDDDDUL)
  8590.  
  8591. # Wert zur Markierung als special deklarierter Referenzen
  8592.   #define specdecl  make_system(0xECDECDUL)
  8593.  
  8594. # Hantieren mit Frames:
  8595. # Eine lokale Variable FRAME enthalte den Wert von STACK nach Aufbau
  8596. # eines Frames. Dann kann man mit FRAME_(n) genauso wie mit STACK_(n)
  8597. # zugreifen:
  8598.   #ifdef STACK_DOWN
  8599.     #define FRAME_(n)  (FRAME[(sintP)(n)])
  8600.   #endif
  8601.   #ifdef STACK_UP
  8602.     #define FRAME_(n)  (FRAME[-1-(sintP)(n)])
  8603.   #endif
  8604. # make_framepointer(FRAME) ist der Frame-Pointer als Lisp-Objekt.
  8605. # mtypecode(FRAME_(0)) ist das Frame-Info-Byte,
  8606. # topofframe(FRAME_(0)) ist ein Pointer über den Frame.
  8607. # FRAME = uTheFramepointer(obj) ist ein Frame-Pointer als Pointer in den Stack.
  8608. #         [uTheFramepointer ist das genaue Gegenteil von make_framepointer.]
  8609. # FRAME = TheFramepointer(obj) ebenfalls, aber evtl. doch noch mit Typinfo!
  8610. #         [Eine Abschwächung von uTheFramepointer, die zum Zugreifen ausreicht.]
  8611.   #if !defined(SINGLEMAP_MEMORY_STACK)
  8612.     #define make_framepointer(stack_ptr)  type_pointer_object(system_type,stack_ptr)
  8613.     #define topofframe(bottomword)  (object*)upointer(bottomword)
  8614.     #define uTheFramepointer(obj)  (object*)upointer(obj)
  8615.   #else
  8616.     #define make_framepointer(stack_ptr)  (as_object((oint)(stack_ptr)))
  8617.     #define topofframe(bottomword)  (object*)as_oint(type_pointer_object(system_type,upointer(bottomword)))
  8618.     #define uTheFramepointer(obj)  TheFramepointer(obj) # = (object*)(obj)
  8619.   #endif
  8620. # wird verwendet von EVAL, CONTROL, DEBUG
  8621.  
  8622. # Zur Bestimmung der Größe eines Frames:
  8623. # STACK_item_count(new_STACK_ptr,old_STACK_ptr)
  8624. # berechnet die Anzahl der STACK-Elemente zwischen einem älteren Stackpointer
  8625. # old_STACK_ptr und einem neueren new_STACK_ptr.
  8626. # (Also count mit  old_STACK_ptr = new_STACK_ptr STACKop count .)
  8627.   #ifdef STACK_DOWN
  8628.     #define STACK_item_count(new_STACK_ptr,old_STACK_ptr)  \
  8629.       (uintL)((old_STACK_ptr) - (new_STACK_ptr))
  8630.   #endif
  8631.   #ifdef STACK_UP
  8632.     #define STACK_item_count(new_STACK_ptr,old_STACK_ptr)  \
  8633.       (uintL)((new_STACK_ptr) - (old_STACK_ptr))
  8634.   #endif
  8635.  
  8636. # Beendet einen Frame.
  8637. # finish_frame(frametype);
  8638. # > object* top_of_frame: Pointer übern Frame
  8639. # erniedrigt STACK um 1
  8640.   #if !defined(SINGLEMAP_MEMORY_STACK)
  8641.     #define framebottomword(type,top_of_frame)  \
  8642.       type_pointer_object(type,top_of_frame)
  8643.   #else # top_of_frame hat selber schon Typinfo system_type
  8644.     #define framebottomword(type,top_of_frame)  \
  8645.       as_object(type_zero_oint(type)-type_zero_oint(system_type)+(oint)(top_of_frame))
  8646.   #endif
  8647.   #define finish_frame(frametype)  \
  8648.     pushSTACK(framebottomword(frametype##_frame_info,top_of_frame))
  8649. # wird verwendet von EVAL, CONTROL
  8650.  
  8651. # Baut einen Frame für alle 5 Environments
  8652. # make_ENV5_frame();
  8653. # erniedrigt STACK um 5
  8654.   #define make_ENV5_frame()  \
  8655.     {var reg1 object* top_of_frame = STACK; \
  8656.      pushSTACK(aktenv.decl_env);            \
  8657.      pushSTACK(aktenv.go_env);              \
  8658.      pushSTACK(aktenv.block_env);           \
  8659.      pushSTACK(aktenv.fun_env);             \
  8660.      pushSTACK(aktenv.var_env);             \
  8661.      finish_frame(ENV5);                    \
  8662.     }
  8663. # wird verwendet von EVAL, CONTROL, DEBUG
  8664.  
  8665. # Beendet einen Frame mit Entrypoint und setzt den Einsprungpunkt hierher.
  8666. # finish_entry_frame(frametype,returner,retval_zuweisung,reentry_statement);
  8667. # > object* top_of_frame: Pointer übern Frame
  8668. # > jmp_buf* returner: longjmp-Buffer für Wiedereintritt
  8669. # > retval_zuweisung: Zuweisung des setjmp()-Wertes an eine Variable
  8670. # > reentry_statement: Was sofort nach Wiedereintritt zu tun ist.
  8671. # erniedrigt STACK um 1
  8672.   #define finish_entry_frame(frametype,returner,retval_zuweisung,reentry_statement)  \
  8673.     { pushSTACK(as_object((aint)(returner))); # SP in den Stack                 \
  8674.       pushSTACK(nullobj); # Dummy in den Stack, bis Wiedereintritt erlaubt ist  \
  8675.       if (!((retval_zuweisung setjmpl(returner))==0)) # Wiedereinspungpunkt herstellen \
  8676.         { RESTORE_mv_count(); RESTORE_value1(); reentry_statement } # nach dem Wiedereintritt \
  8677.         else                                                                    \
  8678.         { STACK_0 = framebottomword(frametype##_frame_info,top_of_frame); }     \
  8679.     }
  8680. # wird verwendet von EVAL, CONTROL, DEBUG
  8681.  
  8682. # Springt einen Frame mit Entrypoint an, der bei STACK beginnt.
  8683. # (Wichtig: Beim Einsprung muß der STACK denselben Wert haben wie beim Aufbau
  8684. # des Frames, da der STACK bei setjmp/longjmp vielleicht gerettet wird!)
  8685. # Kehrt nie zurück und räumt den SP auf!!
  8686. # Die multiple values werden übergeben.
  8687. # enter_frame_at_STACK();
  8688.   #define enter_frame_at_STACK()  \
  8689.     { var reg1 jmp_buf* returner = (void*)(aint)as_oint(STACK_(frame_SP)); # der returner von finish_entry_frame \
  8690.       SAVE_value1(); SAVE_mv_count();                                                                            \
  8691.       longjmpl(&!*returner,(aint)returner); # dorthin springen, eigene Adresse (/=0) übergeben                   \
  8692.       NOTREACHED                                                                                                 \
  8693.     }
  8694. # wird verwendet von EVAL
  8695.  
  8696. # Bei Driver-Frames ist evtl. auch noch der Wert
  8697. # von NUM_STACK_normal vor Aufbau des Frames enthalten:
  8698.   typedef struct { jmp_buf returner; # zuerst - wie bei allen - der jmp_buf
  8699.                    #ifdef HAVE_NUM_STACK
  8700.                    uintD* old_NUM_STACK_normal;
  8701.                    #endif
  8702.                  }
  8703.           DRIVER_frame_data;
  8704.  
  8705. # UP: Wendet eine Funktion auf ihre Argumente an.
  8706. # apply(function,args_on_stack,other_args);
  8707. # > function: Funktion
  8708. # > Argumente: args_on_stack Argumente auf dem STACK,
  8709. #              restliche Argumentliste in other_args
  8710. # < STACK: aufgeräumt (d.h. STACK wird um args_on_stack erhöht)
  8711. # < mv_count/mv_space: Werte
  8712. # verändert STACK, kann GC auslösen
  8713.   extern Values apply (object fun, uintC args_on_stack, object other_args);
  8714. # wird verwendet von EVAL, CONTROL, IO, PATHNAME, ERROR
  8715.  
  8716. # UP: Wendet eine Funktion auf ihre Argumente an.
  8717. # funcall(function,argcount);
  8718. # > function: Funktion
  8719. # > Argumente: argcount Argumente auf dem STACK
  8720. # < STACK: aufgeräumt (d.h. STACK wird um argcount erhöht)
  8721. # < mv_count/mv_space: Werte
  8722. # verändert STACK, kann GC auslösen
  8723.   extern Values funcall (object fun, uintC argcount);
  8724. # wird verwendet von allen Modulen
  8725.  
  8726. # UP: Wertet eine Form im aktuellen Environment aus.
  8727. # eval(form);
  8728. # > form: Form
  8729. # < mv_count/mv_space: Werte
  8730. # kann GC auslösen
  8731.   extern Values eval (object form);
  8732. # wird verwendet von CONTROL, DEBUG
  8733.  
  8734. # UP: Wertet eine Form in einem gegebenen Environment aus.
  8735. # eval_5env(form,var,fun,block,go,decl);
  8736. # > var_env: Wert für VAR_ENV
  8737. # > fun_env: Wert für FUN_ENV
  8738. # > block_env: Wert für BLOCK_ENV
  8739. # > go_env: Wert für GO_ENV
  8740. # > decl_env: Wert für DECL_ENV
  8741. # > form: Form
  8742. # < mv_count/mv_space: Werte
  8743. # kann GC auslösen
  8744.   extern Values eval_5env (object form, object var_env, object fun_env, object block_env, object go_env, object decl_env);
  8745. # wird verwendet von
  8746.  
  8747. # UP: Wertet eine Form in einem leeren Environment aus.
  8748. # eval_noenv(form);
  8749. # > form: Form
  8750. # < mv_count/mv_space: Werte
  8751. # kann GC auslösen
  8752.   extern Values eval_noenv (object form);
  8753. # wird verwendet von CONTROL, IO, DEBUG, SPVW
  8754.  
  8755. # UP: Wertet eine Form im aktuellen Environment aus. Nimmt dabei auf
  8756. # *EVALHOOK* und *APPLYHOOK* keine Rücksicht.
  8757. # eval_no_hooks(form);
  8758. # > form: Form
  8759. # < mv_count/mv_space: Werte
  8760. # kann GC auslösen
  8761.   extern Values eval_no_hooks (object form);
  8762. # wird verwendet von CONTROL
  8763.  
  8764. # UP: bindet *EVALHOOK* und *APPLYHOOK* dynamisch an die gegebenen Werte.
  8765. # bindhooks(evalhook_value,applyhook_value);
  8766. # > evalhook_value: Wert für *EVALHOOK*
  8767. # > applyhook_value: Wert für *APPLYHOOK*
  8768. # verändert STACK
  8769.   extern void bindhooks (object evalhook_value, object applyhook_value);
  8770. # wird verwendet von CONTROL
  8771.  
  8772. # UP: Löst einen Frame auf, auf den STACK zeigt.
  8773. # unwind();
  8774. # Die Werte mv_count/mv_space bleiben dieselben.
  8775. # Falls es kein Unwind-Protect-Frame ist: kehrt normal zurück.
  8776. # Falls es ein Unwind-Protect-Frame ist:
  8777. #   rettet die Werte, klettert STACK und SP hoch
  8778. #   und springt dann unwind_protect_to_save.fun an.
  8779. # verändert STACK
  8780. # kann GC auslösen
  8781.   typedef /* nonreturning */ void (*restart)(object* upto_frame);
  8782.   typedef struct { restart fun; object* upto_frame; } unwind_protect_caller;
  8783.   extern unwind_protect_caller unwind_protect_to_save;
  8784.   extern void unwind (void);
  8785. # wird verwendet von CONTROL, DEBUG, SPVW
  8786.  
  8787. # UP: "unwindet" den STACK bis zum nächsten DRIVER_FRAME und
  8788. # springt in die entsprechende Top-Level-Schleife.
  8789. # reset();
  8790.   nonreturning_function(extern, reset, (void));
  8791. # wird verwendet von SPVW, CONTROL
  8792.  
  8793. # UP: bindet dynamisch die Symbole der Liste symlist
  8794. # an die Werte aus der Liste vallist.
  8795. # progv(symlist,vallist);
  8796. # > symlist, vallist: zwei Listen
  8797. # Es wird genau ein Variablenbindungsframe aufgebaut.
  8798. # verändert STACK
  8799.   extern void progv (object symlist, object vallist);
  8800. # wird verwendet von CONTROL
  8801.  
  8802. # UP: Löst die dynamische Schachtelung im STACK auf bis zu dem Frame
  8803. # (ausschließlich), auf den upto zeigt, und springt diesen dann an.
  8804. # unwind_upto(upto);
  8805. # > upto: Pointer auf einen Frame (in den Stack, ohne Typinfo).
  8806. # Rettet die Werte mv_count/mv_space.
  8807. # verändert STACK,SP
  8808. # kann GC auslösen
  8809. # Springt dann den gefundenen Frame an.
  8810.   nonreturning_function(extern, unwind_upto, (object* upto_frame));
  8811. # wird verwendet von CONTROL, DEBUG
  8812.  
  8813. # UP: throwt zum Tag tag und übergibt dabei die Werte mv_count/mv_space.
  8814. # Kommt nur dann zurück, wenn es keinen CATCH-Frame dieses Tags gibt.
  8815. # throw(tag);
  8816.   extern void throw (object tag);
  8817. # wird verwendet von CONTROL
  8818.  
  8819. # UP: Ruft alle Handler zur Condition cond auf. Kommt nur zurück, wenn keiner
  8820. # dieser Handler sich zuständig fühlt (d.h. wenn jeder Handler zurückkehrt).
  8821. # invoke_handlers(cond);
  8822. # kann GC auslösen
  8823.   extern void invoke_handlers (object cond);
  8824. # wird verwendet von ERROR
  8825.  
  8826. # UP: Stellt fest, ob ein Objekt ein Funktionsname, d.h. ein Symbol oder
  8827. # eine Liste der Form (SETF symbol), ist.
  8828. # funnamep(obj)
  8829. # > obj: Objekt
  8830. # < ergebnis: TRUE falls Funktionsname
  8831.   extern boolean funnamep (object obj);
  8832. # wird verwendet von CONTROL
  8833.  
  8834. # UP: Stellt fest, ob ein Symbol im aktuellen Environment einen Macro darstellt.
  8835. # sym_macrop(symbol)
  8836. # > symbol: Symbol
  8837. # < ergebnis: TRUE falls sym einen Symbol-Macro darstellt
  8838.   extern boolean sym_macrop (object sym);
  8839. # wird verwendet von CONTROL
  8840.  
  8841. # UP: Setzt den Wert eines Symbols im aktuellen Environment.
  8842. # setq(symbol,value);
  8843. # > symbol: Symbol, keine Konstante
  8844. # > value: gewünschter Wert des Symbols im aktuellen Environment
  8845.   extern void setq (object sym, object value);
  8846. # wird verwendet von CONTROL
  8847.  
  8848. # UP: Liefert zu einem Symbol seine Funktionsdefinition in einem Environment
  8849. # sym_function(sym,fenv)
  8850. # > sym: Funktionsname (z.B. Symbol)
  8851. # > fenv: ein Funktions- und Macrobindungs-Environment
  8852. # < ergebnis: Funktionsdefinition, entweder unbound (falls undefinierte Funktion)
  8853. #             oder Closure/SUBR/FSUBR oder ein Cons (SYS::MACRO . expander).
  8854.   extern object sym_function (object sym, object fenv);
  8855. # wird verwendet von CONTROL
  8856.  
  8857. # UP: "nestet" ein FUN-Environment, d.h. schreibt alle aktiven Bindungen
  8858. # aus dem Stack in neu allozierte Vektoren.
  8859. # nest_fun(env)
  8860. # > env: FUN-Env
  8861. # < ergebnis: selbes Environment, kein Pointer in den Stack
  8862. # kann GC auslösen
  8863.   extern object nest_fun (object env);
  8864. # wird verwendet von CONTROL
  8865.  
  8866. # UP: Nestet die Environments in *env (d.h. schreibt alle Informationen in
  8867. # Stack-unabhängige Strukturen) und schiebt sie auf den STACK.
  8868. # nest_env(env)
  8869. # > environment* env: Pointer auf fünf einzelne Environments
  8870. # < environment* ergebnis: Pointer auf die Environments im STACK
  8871. # verändert STACK, kann GC auslösen
  8872.   extern environment* nest_env (environment* env);
  8873. # wird verwendet von Macro nest_aktenv
  8874.  
  8875. # UP: Nestet die aktuellen Environments (d.h. schreibt alle Informationen in
  8876. # Stack-unabhängige Strukturen) und schiebt sie auf den STACK.
  8877. # (Die Werte VAR_ENV, FUN_ENV, BLOCK_ENV, GO_ENV, DECL_ENV werden nicht
  8878. # verändert, da evtl. noch inaktive Bindungen in Frames sitzen, die ohne
  8879. # Veränderung von VAR_ENV aktiviert werden können müssen.)
  8880. # nest_aktenv()
  8881. # < environment* ergebnis: Pointer auf die Environments im STACK
  8882. # verändert STACK, kann GC auslösen
  8883.   # extern environment* nest_aktenv (void);
  8884.   #define nest_aktenv()  nest_env(&aktenv)
  8885. # wird verwendet von CONTROL
  8886.  
  8887. # UP: Ergänzt ein Deklarations-Environment um ein decl-spec.
  8888. # augment_decl_env(declspec,env)
  8889. # > declspec: Deklarations-Specifier, ein Cons
  8890. # > env: Deklarations-Environment
  8891. # < ergebnis: neues (evtl. augmentiertes) Deklarations-Environment
  8892. # kann GC auslösen
  8893.   extern object augment_decl_env (object new_declspec, object env);
  8894. # wird verwendet von CONTROL
  8895.  
  8896. # UP: expandiert eine Form, falls möglich, (nicht jedoch, wenn FSUBR-Aufruf
  8897. # oder Symbol) in einem Environment
  8898. # macroexp(form,venv,fenv);
  8899. # > form: Form
  8900. # > venv: ein Variablen- und Symbolmacro-Environment
  8901. # > fenv: ein Funktions- und Macrobindungs-Environment
  8902. # < value1: die Expansion
  8903. # < value2: NIL, wenn nicht expandiert,
  8904. #           T, wenn expandiert wurde
  8905. # kann GC auslösen
  8906.   extern void macroexp (object form, object venv, object fenv);
  8907. # wird verwendet von CONTROL
  8908.  
  8909. # UP: expandiert eine Form, falls möglich, (auch, wenn FSUBR-Aufruf)
  8910. # in einem Environment
  8911. # macroexp0(form,env);
  8912. # > form: Form
  8913. # > env: ein Macroexpansions-Environment
  8914. # < value1: die Expansion
  8915. # < value2: NIL, wenn nicht expandiert,
  8916. #           T, wenn expandiert wurde
  8917. # kann GC auslösen
  8918.   extern void macroexp0 (object form, object env);
  8919. # wird verwendet von CONTROL
  8920.  
  8921. # UP: Parse-Declarations-Docstring. Trennt von einer Formenliste diejenigen
  8922. # ab, die als Deklarationen bzw. Dokumentationsstring angesehen werden
  8923. # müssen.
  8924. # parse_dd(formlist,venv,fenv)
  8925. # > formlist: ( {decl|doc-string} . body )
  8926. # > venv: ein Variablen- und Symbolmacro-Environment (für die Macroexpansionen)
  8927. # > fenv: Funktions- und Macrobindungs-Environment (für die Macroexpansionen)
  8928. # < value1: body
  8929. # < value2: Liste der decl-specs
  8930. # < value3: Doc-String oder NIL
  8931. # < ergebnis: TRUE falls eine (COMPILE)-Deklaration vorkam, FALSE sonst
  8932. # kann GC auslösen
  8933.   extern boolean parse_dd (object formlist, object venv, object fenv);
  8934. # wird verwendet von CONTROL
  8935.  
  8936. # UP: Erzeugt zu einem Lambdabody die entsprechende Closure durch Zerlegen
  8937. # der Lambdaliste und eventuelles Macroexpandieren aller Formen.
  8938. # get_closure(lambdabody,name,env)
  8939. # > lambdabody: (lambda-list {decl|doc} {form})
  8940. # > name: Name, ein Symbol oder (SETF symbol)
  8941. # > env: Pointer auf die fünf einzelnen Environments:
  8942. #        env->var_env = VENV, env->fun_env = FENV,
  8943. #        env->block_env = BENV, env->go_env = GENV,
  8944. #        end->decl_env = DENV.
  8945. # < ergebnis: Closure
  8946. # kann GC auslösen
  8947.   extern object get_closure (object lambdabody, object name, environment* env);
  8948. # wird verwendet von CONTROL, SYMBOL, PREDTYPE
  8949.  
  8950. # UP: Wandelt ein Argument in eine Funktion um.
  8951. # coerce_function(obj)
  8952. # > obj: Objekt
  8953. # > subr_self: Aufrufer (ein SUBR)
  8954. # < ergebnis: Objekt als Funktion (SUBR oder Closure)
  8955. # kann GC auslösen
  8956.   extern object coerce_function (object obj);
  8957. # wird verwendet von IO, FOREIGN
  8958.  
  8959.  
  8960. #define DYNBIND_SIZE 3
  8961.  
  8962. # Bindet ein Symbol dynamisch an einen Wert.
  8963. # Baut hierzu einen dynamischen Variablenbindungsframe für 1 Variable auf.
  8964. # dynamic_bind(var,val)
  8965. # > var: ein Symbol
  8966. # > val: der neue Wert
  8967. # verringert STACK um 3 Einträge
  8968. # verändert STACK
  8969.  
  8970. # kann GC auslösen
  8971. #define dynamic_bind__(variable,val_to_use)                      \
  8972.   { var reg2 object* top_of_frame = STACK;                       \
  8973.     var reg1 object sym_to_bind = (variable);                    \
  8974.     # Frame aufbauen:                                            \
  8975.     pushSTACK(Symbol_symvalue(sym_to_bind));                     \
  8976.     pushSTACK(sym_to_bind);                                      \
  8977.     pushSTACK(framebottomword(DYNBIND_frame_info,top_of_frame)); \
  8978.     # Wert modifizieren:                                         \
  8979.     set_Symbol_symvalue(sym_to_bind,(val_to_use));               \
  8980.   }
  8981. #ifndef DYNBIND_LIST
  8982.   # kann GC auslösen
  8983.   #define dynamic_bind dynamic_bind__
  8984. #else
  8985.   # kann GC auslösen
  8986.   #define dynamic_bind(variable,val_to_use)  \
  8987.     { var reg1 object value = (val_to_use);  \
  8988.       dynamic_bind__(variable,value);        \
  8989.       add_frame_to_binding_list(&STACK_0);   \
  8990.     }
  8991. #endif
  8992.  
  8993. # wird verwendet von IO, EVAL, DEBUG, ERROR
  8994.  
  8995. # Löst einen dynamischen Variablenbindungsframe für 1 Variable auf.
  8996. # dynamic_unbind()
  8997. # erhöht STACK um 3 Einträge
  8998. # verändert STACK
  8999. #define dynamic_unbind__()                         \
  9000.   { # Wert zurückschreiben:                        \
  9001.     set_Symbol_symvalue(STACK_(1),STACK_(2));      \
  9002.      # Frame abbauen:                              \
  9003.   }
  9004.  
  9005. #ifndef DYNBIND_LIST
  9006.   #define dynamic_unbind()                         \
  9007.     { dynamic_unbind__();                          \
  9008.       skipSTACK(3);                                \
  9009.     }
  9010. #else
  9011.   #define dynamic_unbind()                         \
  9012.     { dynamic_unbind__();                          \
  9013.       delete_frame_from_binding_list(&STACK_0);    \
  9014.       skipSTACK(3);                                \
  9015.     }
  9016. #endif
  9017.  
  9018. # wird verwendet von IO, DEBUG
  9019.  
  9020. # Führt "implizites PROGN" aus.
  9021. # implicit_progn(body,default)
  9022. # Führt body als implizites PROGN aus. Falls body leer, ist default der Wert.
  9023. # kann GC auslösen
  9024.   #define implicit_progn(body,default)  \
  9025.     { var reg1 object rest = (body);                                     \
  9026.       if atomp(rest)                                                     \
  9027.         { value1 = (default); mv_count=1; } # default als Wert           \
  9028.         else                                                             \
  9029.           do { pushSTACK(Cdr(rest)); eval(Car(rest)); rest=popSTACK(); } \
  9030.              while (consp(rest));                                        \
  9031.     }
  9032. # wird verwendet von EVAL, CONTROL
  9033.  
  9034. # Maximalzahl von Parametern in einer Lambdaliste
  9035. # (= Wert von LAMBDA-PARAMETERS-LIMIT - 1)
  9036.   #define lp_limit_1  ((uintL)(bitm(intCsize)-1))
  9037.  
  9038. # Maximalzahl von Argumenten bei einem Funktionsaufruf
  9039. # (= Wert von CALL-ARGUMENTS-LIMIT - 1)
  9040.   #define ca_limit_1  ((uintL)(bitm(intCsize)-1))
  9041.  
  9042. # Der Macro LISPSPECFORM leitet eine LISP-Special-Form-Deklaration ein.
  9043. # LISPSPECFORM(name,req_anz,opt_anz,body_flag)
  9044. # > name: C-Name der Funktion und des Symbols.
  9045. # > req_anz: Anzahl der required Parameter
  9046. # > opt_anz: Anzahl der optionalen Parameter
  9047. # > body_flag: body oder nobody, zeigt an, ob &BODY vorhanden
  9048. # Siehe FSUBR.D
  9049.   #define LISPSPECFORM  LISPSPECFORM_B
  9050. # wird verwendet von CONTROL
  9051.  
  9052. # Der Macro LISPFUN leitet eine LISP-Funktions-Deklaration ein.
  9053. # LISPFUN(name,req_anz,opt_anz,rest_flag,key_flag,key_anz,allow_flag,keywords)
  9054. # > name: der Funktionsname (ein C-Identifier)
  9055. # > req_anz: die Anzahl der required-Parameter (eine Zahl)
  9056. # > opt_anz: die Anzahl der optional-Parameter (eine Zahl)
  9057. # > rest_flag: entweder norest oder rest, zeigt an, ob &REST vorhanden
  9058. # > key_flag: entweder nokey oder key, zeigt an, ob &KEY vorhanden
  9059. # > key_anz: Anzahl der Keyword-Parameter, eine Zahl (0 falls nokey)
  9060. # > allow_flag: entweder noallow oder allow, zeigt an, on &ALLOW-OTHER-KEYS
  9061. #               nach &KEY vorhanden (noallow falls nokey)
  9062. # > keywords: entweder NIL oder ein Ausdruck der Form v(kw(keyword1),...,kw(keywordn))
  9063. #             (NIL falls nokey)
  9064. # Siehe SUBR.D
  9065.   #define LISPFUN  LISPFUN_B
  9066. # wird verwendet von allen Modulen
  9067.  
  9068. # Der Macro LISPFUNN leitet eine einfache LISP-Funktions-Deklaration ein.
  9069. # LISPFUNN(name,req_anz)
  9070. # > name: der Funktionsname (ein C-Identifier)
  9071. # > req_anz: die (feste) Anzahl der Argumente (eine Zahl)
  9072. # Siehe SUBR.D
  9073. # wird verwendet von allen Modulen
  9074.  
  9075.  
  9076. # ##################### CTRLBIBL zu CONTROL.D ############################# #
  9077.  
  9078. # Fehler, wenn ein Block bereits verlassen wurde.
  9079. # fehler_block_left(name);
  9080. # > name: Block-Name
  9081.   nonreturning_function(extern, fehler_block_left, (object name));
  9082. # wird verwendet von EVAL
  9083.  
  9084. # Fehlermeldung wegen undefinierter Funktion.
  9085. # fehler_undef_function(caller,symbol);
  9086. # > caller: Aufrufer (ein Symbol)
  9087. # > symbol: Symbol oder (SETF symbol)
  9088.   nonreturning_function(extern, fehler_undef_function, (object caller, object symbol));
  9089. # wird verwendet von PREDTYPE
  9090.  
  9091. # ####################### ARRBIBL zu ARRAY.D ############################## #
  9092.  
  9093. # ARRAY-TOTAL-SIZE-LIMIT wird so groß gewählt, daß die Total-Size eines
  9094. # jeden Arrays ein Fixnum (>=0, <2^oint_data_len) ist:
  9095.   #define arraysize_limit_1  ((uintL)(bitm(oint_data_len)-1))
  9096.  
  9097. # ARRAY-RANK-LIMIT wird so groß gewählt, daß der Rang eines jeden Arrays
  9098. # ein uintC ist:
  9099.   #define arrayrank_limit_1  ((uintL)(bitm(intCsize)-1))
  9100.  
  9101. # UP: Kopiert einen Simple-Vector
  9102. # copy_svector(vector)
  9103. # > vector : Simple-Vector
  9104. # < ergebnis : neuer Simple-Vector desselben Inhalts
  9105. # kann GC auslösen
  9106.   extern object copy_svector (object vector);
  9107. # wird verwendet von IO, REXX
  9108.  
  9109. # UP: Bestimmt die aktive Länge eines Vektors (wie in LENGTH)
  9110. # vector_length(vector)
  9111. # > vector: ein Vektor
  9112. # < ergebnis: seine Länge als uintL
  9113.   extern uintL vector_length (object vector);
  9114. # wird verwendet von SEQUENCE, CHARSTRG, PREDTYPE, IO, HASHTABL, SPVW
  9115.  
  9116. # Wandelt element-type in einen der Standard-Typen um
  9117. # und liefert seinen Elementtyp-Code.
  9118. # eltype_code(element_type)
  9119. # > element_type: Type-Specifier
  9120. # < ergebnis: Elementtyp-Code Atype_xxx
  9121. # Standard-Typen sind die möglichen Ergebnisse von ARRAY-ELEMENT-TYPE
  9122. # (Symbole T, BIT, STRING-CHAR und Listen (UNSIGNED-BYTE n)).
  9123. # Das Ergebnis ist ein Obertyp von element-type.
  9124. # kann GC auslösen
  9125.   extern uintB eltype_code (object element_type);
  9126. # wird verwendet von SEQUENCE
  9127.  
  9128. # UP: Liefert zu einem Array gegebener Größe den Datenvektor und den Offset.
  9129. # Überprüft auch, ob alle Elemente des Arrays physikalisch vorhanden sind.
  9130. # array1_displace_check(array,size,&index)
  9131. # > object array: (echter) Array
  9132. # > uintL size: Größe
  9133. # < ergebnis: Datenvektor
  9134. # < index: wird um den Offset in den Datenvektor erhöht.
  9135.   extern object array1_displace_check (object array, uintL size, uintL* index);
  9136. # wird verwendet von IO, CHARSTRG, PREDTYPE, STREAM, SEQUENCE
  9137.  
  9138. # UP: Liefert zu einem Array gegebener Größe den Datenvektor und den Offset.
  9139. # Überprüft auch, ob alle Elemente des Arrays physikalisch vorhanden sind.
  9140. # array_displace_check(array,size,&index)
  9141. # > object array: Array
  9142. # > uintL size: Größe
  9143. # < ergebnis: Datenvektor
  9144. # < index: wird um den Offset in den Datenvektor erhöht.
  9145.   extern object array_displace_check (object array, uintL size, uintL* index);
  9146. # wird verwendet von PATHNAME, HASHTABL, PREDTYPE, IO
  9147.  
  9148. # Führt einen AREF-Zugriff aus.
  9149. # datenvektor_aref(datenvektor,index)
  9150. # > datenvektor : ein Datenvektor (simpler Vektor oder semi-simpler Byte-Vektor)
  9151. # > index : (geprüfter) Index in den Datenvektor
  9152. # < ergebnis : (AREF datenvektor index)
  9153. # kann GC auslösen
  9154.   extern object datenvektor_aref (object datenvektor, uintL index);
  9155. # wird verwendet von IO
  9156.  
  9157. # UP: fragt ein Bit in einem Simple-Bit-Vector ab
  9158. # if (sbvector_btst(sbvector,index)) ...
  9159. # > sbvector: ein Simple-Bit-Vector
  9160. # > index: Index (Variable, sollte < (length sbvector) sein)
  9161.   #define sbvector_btst(sbvector_from_sbvector_btst,index_from_sbvector_btst)  \
  9162.     ( # im Byte (index div 8) das Bit 7 - (index mod 8) : \
  9163.      TheSbvector(sbvector_from_sbvector_btst)->data[(uintL)(index_from_sbvector_btst)/8] \
  9164.        & bit((~(uintL)(index_from_sbvector_btst)) % 8)    \
  9165.     )
  9166. # wird verwendet von ARRAY, SEQUENCE, IO
  9167.  
  9168. # UP: löscht ein Bit in einem Simple-Bit-Vector
  9169. # sbvector_bclr(sbvector,index);
  9170. # > sbvector: ein Simple-Bit-Vector
  9171. # > index: Index (Variable, sollte < (length sbvector) sein)
  9172.   #define sbvector_bclr(sbvector_from_sbvector_bclr,index_from_sbvector_bclr)  \
  9173.     ( # im Byte (index div 8) das Bit 7 - (index mod 8) löschen: \
  9174.       TheSbvector(sbvector_from_sbvector_bclr)->data[(uintL)(index_from_sbvector_bclr)/8] \
  9175.         &= ~bit((~(uintL)(index_from_sbvector_bclr)) % 8)        \
  9176.     )
  9177. # wird verwendet von IO
  9178.  
  9179. # UP: setzt ein Bit in einem Simple-Bit-Vector
  9180. # sbvector_bset(sbvector,index);
  9181. # > sbvector: ein Simple-Bit-Vector
  9182. # > index: Index (Variable, sollte < (length sbvector) sein)
  9183.   #define sbvector_bset(sbvector_from_sbvector_bset,index_from_sbvector_bset)  \
  9184.     ( # im Byte (index div 8) das Bit 7 - (index mod 8) setzen: \
  9185.       TheSbvector(sbvector_from_sbvector_bset)->data[(uintL)(index_from_sbvector_bset)/8] \
  9186.         |= bit((~(uintL)(index_from_sbvector_bset)) % 8)        \
  9187.     )
  9188. # wird verwendet von SEQUENCE, IO
  9189.  
  9190. # UP, liefert den Element-Typ eines Arrays
  9191. # array_element_type(array)
  9192. # > array : ein Array (simple oder nicht)
  9193. # < ergebnis : Element-Typ, eines der Symbole T, BIT, STRING-CHAR, oder eine Liste
  9194. # kann GC auslösen
  9195.   extern object array_element_type (object array);
  9196. # wird verwendet von PREDTYPE, IO
  9197.  
  9198. # UP, bildet Liste der Dimensionen eines Arrays
  9199. # array_dimensions(array)
  9200. # > array: ein Array (simple oder nicht)
  9201. # < ergebnis: Liste seiner Dimensionen
  9202. # kann GC auslösen
  9203.   extern object array_dimensions (object array);
  9204. # wird verwendet von PREDTYPE, IO
  9205.  
  9206. # UP, liefert Dimensionen eines Arrays und ihre Teilprodukte
  9207. # array_dims_sizes(array,&dims_sizes);
  9208. # > array: (echter) Array vom Rang r
  9209. # > struct { uintL dim; uintL dimprod; } dims_sizes[r]: Platz fürs Ergebnis
  9210. # < für i=1,...r:  dims_sizes[r-i] = { Dim_i, Dim_i * ... * Dim_r }
  9211.   typedef struct { uintL dim; uintL dimprod; }  array_dim_size;
  9212.   extern void array_dims_sizes (object array, array_dim_size* dims_sizes);
  9213. # wird verwendet von IO
  9214.  
  9215. # Liefert die Gesamtgröße eines Arrays
  9216. # array_total_size(array)
  9217. # > array: ein Array (simple oder nicht)
  9218. # < uintL ergebnis: seine Gesamtgröße
  9219.   #define array_total_size(array)  \
  9220.     (array_simplep(array)                                                   \
  9221.       ? TheSarray(array)->length # simpler Vektor: Länge                    \
  9222.       : TheArray(array)->totalsize # nicht-simpler Array enthält Total-Size \
  9223.     )
  9224. # wird verwendet von ARRAY, PREDTYPE, IO, SEQUENCE
  9225.  
  9226. # Unterprogramm für Bitvektor-Vergleich:
  9227. # bit_compare(array1,index1,array2,index2,count)
  9228. # > array1: erster Bit-Array,
  9229. # > index1: absoluter Index in array1
  9230. # > array2: zweiter Bit-Array,
  9231. # > index2: absoluter Index in array2
  9232. # > count: Anzahl der zu vergleichenden Bits
  9233. # < ergebnis: TRUE, wenn die Ausschnitte bitweise gleich sind, FALSE sonst.
  9234.   extern boolean bit_compare (object array1, uintL index1,
  9235.                               object array2, uintL index2,
  9236.                               uintL bitcount);
  9237. # wird verwendet von PREDTYPE
  9238.  
  9239. # UP: Testet, ob ein Array einen Fill-Pointer hat.
  9240. # array_has_fill_pointer_p(array)
  9241. # > array: ein Array
  9242. # < TRUE, falls ja; FALSE falls nein.
  9243.   extern boolean array_has_fill_pointer_p (object array);
  9244. # wird verwendet von SEQUENCE, STREAM, IO
  9245.  
  9246. # UP: erzeugt einen mit Nullen gefüllten Bitvektor
  9247. # allocate_bit_vector_0(len)
  9248. # > uintL len: Länge des Bitvektors (in Bits)
  9249. # < ergebnis: neuer Bitvektor, mit Nullen gefüllt
  9250. # kann GC auslösen
  9251.   extern object allocate_bit_vector_0 (uintL len);
  9252. # wird verwendet von SEQUENCE
  9253.  
  9254. # Folgende beide Funktionen arbeiten auf "Semi-Simple String"s.
  9255. # Das sind STRING-CHAR-Arrays mit FILL-POINTER, die aber nicht adjustierbar
  9256. # und nicht displaced sind und deren Datenvektor ein Simple-String ist.
  9257. # Beim Überschreiten der Länge wird ihre Länge verdoppelt
  9258. # (so daß der Aufwand fürs Erweitern nicht sehr ins Gewicht fällt).
  9259.  
  9260. # UP: Liefert einen Semi-Simple String gegebener Länge, Fill-Pointer =0.
  9261. # make_ssstring(len)
  9262. # > uintL len: Länge >0
  9263. # < ergebnis: neuer Semi-Simple String dieser Länge
  9264. # kann GC auslösen
  9265.   extern object make_ssstring (uintL len);
  9266. # wird verwendet von STREAM, IO
  9267.  
  9268. # UP: Schiebt ein String-Char in einen Semi-Simple String und erweitert ihn
  9269. # dabei eventuell.
  9270. # ssstring_push_extend(ssstring,ch)
  9271. # > ssstring: Semi-Simple String
  9272. # > ch: Character
  9273. # < ergebnis: derselbe Semi-Simple String
  9274. # kann GC auslösen
  9275.   extern object ssstring_push_extend (object ssstring, uintB ch);
  9276. # wird verwendet von STREAM, IO
  9277.  
  9278. #ifdef STRM_WR_SS
  9279. # UP: Stellt sicher, daß ein Semi-Simple String eine bestimmte Länge hat
  9280. # und erweitert ihn dazu eventuell.
  9281. # ssstring_extend(ssstring,size)
  9282. # > ssstring: Semi-Simple String
  9283. # > size: gewünschte Mindestgröße
  9284. # < ergebnis: derselbe Semi-Simple String
  9285. # kann GC auslösen
  9286.   extern object ssstring_extend (object ssstring, uintL needed_len);
  9287. # wird verwendet von STREAM
  9288. #endif
  9289.  
  9290. # ##################### CHARBIBL zu CHARSTRG.D ############################ #
  9291.  
  9292. # Spezielle Characters: (siehe auch oben)
  9293. # #define BEL   7  #  #\Bell
  9294. # #define BS    8  #  #\Backspace
  9295. # #define TAB   9  #  #\Tab
  9296. # #define LF   10  #  #\Linefeed
  9297. # #define CR   13  #  #\Return
  9298. # #define PG   12  #  #\Page
  9299.   #define NL   10  #  #\Newline
  9300.   #define NLstring  "\n"  # C-String, der #\Newline enthält
  9301.   #define ESC  27  #  #\Escape
  9302.   #define ESCstring  "\033"  # C-String, der #\Escape enthält
  9303.  
  9304. # Wandelt Byte ch in einen Großbuchstaben
  9305. # up_case(ch)
  9306.   extern uintB up_case (uintB ch);
  9307. # wird verwendet von IO, PREDTYPE, PATHNAME
  9308.  
  9309. # Wandelt Byte ch in einen Kleinbuchstaben
  9310. # down_case(ch)
  9311.   extern uintB down_case (uintB ch);
  9312. # wird verwendet von IO, PATHNAME
  9313.  
  9314. # Stellt fest, ob ein Character alphanumerisch ist.
  9315. # alphanumericp(ch)
  9316. # > ch: Character-Code
  9317. # < ergebnis: TRUE falls alphanumerisch, FALSE sonst.
  9318.   extern boolean alphanumericp (uintB ch);
  9319. # wird verwendet von IO, PATHNAME
  9320.  
  9321. # Stellt fest, ob ein Character ein Graphic-Character ("druckend") ist.
  9322. # graphic_char_p(ch)
  9323. # > ch: Character-Code
  9324. # < ergebnis: TRUE falls druckend, FALSE sonst.
  9325.   extern boolean graphic_char_p (uintB ch);
  9326. # wird verwendet von STREAM, PATHNAME
  9327.  
  9328. # UP: verfolgt einen String.
  9329. # unpack_string(string,&len)
  9330. # > object string: ein String.
  9331. # < uintL len: Anzahl der Zeichen des Strings.
  9332. # < uintB* ergebnis: Anfangsadresse der Bytes
  9333.   extern uintB* unpack_string (object string, uintL* len);
  9334. # wird verwendet von STREAM, HASHTABL, PACKAGE, SPVW, STDWIN, GRAPH
  9335.  
  9336. # UP: vergleicht zwei Strings auf Gleichheit
  9337. # string_gleich(string1,string2)
  9338. # > string1: String
  9339. # > string2: simple-string
  9340. # < ergebnis: /=0, wenn gleich
  9341.   extern boolean string_gleich (object string1, object string2);
  9342. # wird verwendet von PACKAGE, STREAM, IO
  9343.  
  9344. # UP: vergleicht zwei Strings auf Gleichheit, case-insensitive
  9345. # string_equal(string1,string2)
  9346. # > string1: String
  9347. # > string2: simple-string
  9348. # < ergebnis: /=0, wenn gleich
  9349.   extern boolean string_equal (object string1, object string2);
  9350. # wird verwendet von IO, PATHNAME
  9351.  
  9352. # UP: kopiert einen String und macht dabei einen Simple-String draus.
  9353. # copy_string(string)
  9354. # > string: String
  9355. # < ergebnis: Simple-String mit denselben Zeichen
  9356. # kann GC auslösen
  9357.   extern object copy_string (object string);
  9358. # wird verwendet von IO, PATHNAME
  9359.  
  9360. # UP: wandelt einen String in einen Simple-String um.
  9361. # coerce_ss(obj)
  9362. # > obj: Lisp-Objekt, sollte ein String sein.
  9363. # < ergebnis: Simple-String mit denselben Zeichen
  9364. # kann GC auslösen
  9365.   extern object coerce_ss (object obj);
  9366. # wird verwendet von STREAM, PATHNAME, Macro coerce_imm_ss
  9367.  
  9368. # UP: wandelt einen String in einen immutablen Simple-String um.
  9369. # coerce_imm_ss(obj)
  9370. # > obj: Lisp-Objekt, sollte ein String sein.
  9371. # < ergebnis: immutabler Simple-String mit denselben Zeichen
  9372. # kann GC auslösen
  9373.   #ifdef IMMUTABLE_ARRAY
  9374.     #define coerce_imm_ss(obj)  make_imm_array(copy_string(obj))
  9375.   #else
  9376.     #define coerce_imm_ss(obj)  coerce_ss(obj)
  9377.   #endif
  9378. # wird verwendet von PACKAGE
  9379.  
  9380. # UP: Konversion eines Objekts zu einem Character
  9381. # coerce_char(obj)
  9382. # > obj: Lisp-Objekt
  9383. # < ergebnis: Character oder NIL
  9384.   extern object coerce_char (object obj);
  9385. # wird verwendet von PREDTYPE
  9386.  
  9387. # UP: Liefert den Namen eines Zeichens.
  9388. # char_name(code)
  9389. # > uintB code: Ascii-Code eines Zeichens
  9390. # < ergebnis: Simple-String (Name dieses Zeichens) oder NIL
  9391.   extern object char_name (uintB code);
  9392. # wird verwendet von IO
  9393.  
  9394. # UP: Bestimmt das Character mit einem gegebenen Namen
  9395. # name_char(string)
  9396. # > string: String
  9397. # < ergebnis: Character mit diesem Namen, oder NIL falls keins existiert
  9398.   extern object name_char (object string);
  9399. # wird verwendet von IO
  9400.  
  9401. # UP: Überprüft die Grenzen für ein String-Argument
  9402. # test_string_limits(&string,&start,&len)
  9403. # > STACK_2: String-Argument
  9404. # > STACK_1: optionales :start-Argument
  9405. # > STACK_0: optionales :end-Argument
  9406. # > subr_self: Aufrufer (ein SUBR)
  9407. # < object string: String
  9408. # < uintL start: Wert des :start-Arguments
  9409. # < uintL len: Anzahl der angesprochenen Characters
  9410. # < uintB* ergebnis: Ab hier kommen die angesprochenen Characters
  9411. # erhöht STACK um 3
  9412.   extern uintB* test_string_limits (object* string_, uintL* start_, uintL* len_);
  9413. # wird verwendet von STREAM, PATHNAME, IO
  9414.  
  9415. # UP: wandelt die Characters eines Stringstücks in Großbuchstaben
  9416. # nstring_upcase(charptr,len);
  9417. # > uintB* charptr: Ab hier kommen die angesprochenen Characters
  9418. # > uintL len: Anzahl der angesprochenen Characters
  9419.   extern void nstring_upcase (uintB* charptr, uintL len);
  9420. # wird verwendet von
  9421.  
  9422. # UP: wandelt die Characters eines Stringstücks in Kleinbuchstaben
  9423. # nstring_downcase(charptr,len);
  9424. # > uintB* charptr: Ab hier kommen die angesprochenen Characters
  9425. # > uintL len: Anzahl der angesprochenen Characters
  9426.   extern void nstring_downcase (uintB* charptr, uintL len);
  9427. # wird verwendet von PATHNAME
  9428.  
  9429. # UP: wandelt die Worte eines Stringstücks in solche, die
  9430. # mit Großbuchstaben anfangen und mit Kleinbuchstaben weitergehen.
  9431. # nstring_capitalize(charptr,len);
  9432. # > uintB* charptr: Ab hier kommen die angesprochenen Characters
  9433. # > uintL len: Anzahl der angesprochenen Characters
  9434.   extern void nstring_capitalize (uintB* charptr, uintL len);
  9435. # wird verwendet von PATHNAME
  9436.  
  9437. # UP: wandelt einen String in Großbuchstaben
  9438. # string_upcase(string)
  9439. # > string: String
  9440. # < ergebnis: neuer Simple-String, in Großbuchstaben
  9441. # kann GC auslösen
  9442.   extern object string_upcase (object string);
  9443. # wird verwendet von MISC, PATHNAME
  9444.  
  9445. # UP: wandelt einen String in Kleinbuchstaben
  9446. # string_downcase(string)
  9447. # > string: String
  9448. # < ergebnis: neuer Simple-String, in Kleinbuchstaben
  9449. # kann GC auslösen
  9450.   extern object string_downcase (object string);
  9451. # wird verwendet von PATHNAME
  9452.  
  9453. # UP: bildet einen aus mehreren Strings zusammengehängten String.
  9454. # string_concat(argcount)
  9455. # > uintC argcount: Anzahl der Argumente
  9456. # > auf dem STACK: die Argumente (sollten Strings sein)
  9457. # > subr_self: Aufrufer (ein SUBR) (unnötig, falls alle Argumente Strings sind)
  9458. # < ergebnis: Gesamtstring, neu erzeugt
  9459. # < STACK: aufgeräumt
  9460. # kann GC auslösen
  9461.   extern object string_concat (uintC argcount);
  9462. # wird verwendet von PACKAGE, PATHNAME, DEBUG, SYMBOL
  9463.  
  9464. # ###################### DEBUGBIB zu DEBUG.D ############################ #
  9465.  
  9466. # Startet den normalen Driver (Read-Eval-Print-Loop)
  9467. # driver();
  9468.   extern void driver (void);
  9469. # wird verwendet von SPVW
  9470.  
  9471. # Startet einen untergeordneten Driver (Read-Eval-Print-Loop)
  9472. # break_driver(continuable);
  9473. # > continuable: Flag, ob nach Beendigung des Drivers fortgefahren werden kann.
  9474. # kann GC auslösen
  9475.   extern void break_driver (object continuable);
  9476. # wird verwendet von ERROR, EVAL
  9477.  
  9478. # ##################### HASHBIBL zu HASHTABL.D ########################## #
  9479.  
  9480. # UP: Sucht ein Objekt in einer Hash-Tabelle.
  9481. # gethash(obj,ht)
  9482. # > obj: Objekt, als Key
  9483. # > ht: Hash-Tabelle
  9484. # < ergebnis: zugehöriger Value, falls gefunden, nullobj sonst
  9485.   extern object gethash (object obj, object ht);
  9486. # wird verwendet von EVAL, RECORD, PATHNAME, FOREIGN
  9487.  
  9488. # UP: Sucht ein Key in einer Hash-Tabelle und liefert den vorigen Wert.
  9489. # shifthash(ht,obj,value) == (SHIFTF (GETHASH obj ht) value)
  9490. # > ht: Hash-Tabelle
  9491. # > obj: Objekt
  9492. # > value: neuer Wert
  9493. # < ergebnis: alter Wert
  9494. # kann GC auslösen
  9495.   extern object shifthash (object ht, object obj, object value);
  9496. # wird verwendet von SEQUENCE, PATHNAME, FOREIGN
  9497.  
  9498. # ######################### IOBIBL zu IO.D ############################## #
  9499.  
  9500. # spezielles Objekt, das EOF anzeigt
  9501.   #define eof_value  make_system(0xE0FE0FUL)
  9502. # wird verwendet von IO, STREAM, DEBUG, SPVW
  9503.  
  9504. # Hilfswert zum Erkennen einzelner Dots
  9505.   #define dot_value  make_system(0xD0DD0DUL)
  9506. # wird verwendet von IO, SPVW
  9507.  
  9508. # UP: Initialisiert den Reader.
  9509. # init_reader();
  9510. # kann GC auslösen
  9511.   extern void init_reader (void);
  9512. # wird verwendet von SPVW
  9513.  
  9514. # UP: Liest ein Objekt ein.
  9515. # read(&stream,recursive-p,whitespace-p)
  9516. # > recursive-p: gibt an, ob rekursiver Aufruf von READ, mit Error bei EOF
  9517. # > whitespace-p: gibt an, ob danach whitespace zu verbrauchen ist
  9518. # > stream: Stream
  9519. # < stream: Stream
  9520. # < ergebnis: gelesenes Objekt (eof_value bei EOF, dot_value bei einzelnem Punkt)
  9521. # kann GC auslösen
  9522.   extern object read (object* stream_, object recursive_p, object whitespace_p);
  9523. # wird verwendet von SPVW, DEBUG
  9524.  
  9525. # UP: Gibt einen Simple-String elementweise auf einen Stream aus.
  9526. # write_sstring(&stream,string);
  9527. # > string: Simple-String
  9528. # > stream: Stream
  9529. # < stream: Stream
  9530. # kann GC auslösen
  9531.   extern void write_sstring (object* stream_, object string);
  9532. # wird verwendet von EVAL, DEBUG, ERROR, PACKAGE, SPVW
  9533.  
  9534. # UP: Gibt einen String elementweise auf einen Stream aus.
  9535. # write_string(&stream,string);
  9536. # > string: String
  9537. # > stream: Stream
  9538. # < stream: Stream
  9539. # kann GC auslösen
  9540.   extern void write_string (object* stream_, object string);
  9541. # wird verwendet von PACKAGE, DEBUG
  9542.  
  9543. # UP: Gibt ein Objekt auf einen Stream aus.
  9544. # prin1(&stream,obj);
  9545. # > obj: Objekt
  9546. # > stream: Stream
  9547. # < stream: Stream
  9548. # kann GC auslösen
  9549.   extern void prin1 (object* stream_, object obj);
  9550. # wird verwendet von EVAL, DEBUG, PACKAGE, ERROR, SPVW
  9551.  
  9552. # UP: Gibt ein Newline auf einen Stream aus.
  9553. # terpri(&stream);
  9554. # > stream: Stream
  9555. # < stream: Stream
  9556. # kann GC auslösen
  9557.   # extern void terpri (object* stream_);
  9558.   #define terpri(stream_)  write_schar(stream_,NL)
  9559. # wird verwendet von IO, DEBUG, PACKAGE, ERROR, SPVW
  9560.  
  9561. # ####################### LISTBIBL zu LIST.D ############################## #
  9562.  
  9563. # UP: Kopiert eine Liste
  9564. # copy_list(list)
  9565. # > list: Liste
  9566. # < ergebnis: Kopie der Liste
  9567. # kann GC auslösen
  9568.   extern object copy_list (object list);
  9569. # wird verwendet von PACKAGE
  9570.  
  9571. # UP: Dreht eine Liste konstruktiv um.
  9572. # reverse(list)
  9573. # > list: Liste (x1 ... xm)
  9574. # < ergebnis: umgedrehte Liste (xm ... x1)
  9575. # kann GC auslösen
  9576.   extern object reverse (object list);
  9577. # wird verwendet von SEQUENCE, PACKAGE, PATHNAME
  9578.  
  9579. # UP: Bestimmt die Länge einer Liste
  9580. # llength(obj)
  9581. # > obj: Objekt
  9582. # < uintL ergebnis: Länge von obj, als Liste aufgefaßt
  9583. # Testet nicht auf zyklische Listen.
  9584.   extern uintL llength (object obj);
  9585. # wird verwendet von CONTROL, EVAL, SEQUENCE, RECORD, IO, PACKAGE, HASHTABL, STREAM
  9586.  
  9587. # UP: Bildet eine Liste mit genau len Elementen
  9588. # make_list(len)
  9589. # > (STACK): Initialisierungswert für die Elemente
  9590. # > uintL len: gewünschte Listenlänge
  9591. # < ergebnis: Liste mit D1.L Elementen
  9592. # kann GC auslösen
  9593.   extern object make_list (uintL len);
  9594. # wird verwendet von
  9595.  
  9596. # UP: Dreht eine Liste destruktiv um.
  9597. # nreverse(list)
  9598. # > list: Liste (x1 ... xm)
  9599. # < ergebnis: Liste (xm ... x1), EQ zur alten
  9600.   extern object nreverse (object list);
  9601. # wird verwendet von SEQUENCE, EVAL, CONTROL, IO, PATHNAME, ERROR, DEBUG, PACKAGE
  9602.  
  9603. # UP: A0 := (nreconc A0 A1)
  9604. # nreconc(list,obj)
  9605. # > list: Liste
  9606. # > obj: Objekt
  9607. # < ergebnis: (nreconc A0 A1)
  9608.   extern object nreconc (object list, object obj);
  9609. # wird verwendet von SEQUENCE, IO, PATHNAME, CONTROL, DEBUG
  9610.  
  9611. # UP: Bilde (delete obj (the list list) :test #'EQ)
  9612. # deleteq(list,obj)
  9613. # Entferne aus der Liste list alle Elemente, die EQ zu obj sind.
  9614. # > obj: zu streichendes Element
  9615. # > list: Liste
  9616. # < ergebnis: modifizierte Liste
  9617.   extern object deleteq (object list, object obj);
  9618. # wird verwendet von PACKAGE, STREAM
  9619.  
  9620. # UP: Bildet eine Liste mit gegebenen Elementen.
  9621. # listof(len)
  9622. # > uintC len: gewünschte Listenlänge
  9623. # > auf STACK: len Objekte, erstes zuoberst
  9624. # < ergebnis: Liste dieser Objekte
  9625. # Erhöht STACK
  9626. # verändert STACK, kann GC auslösen
  9627.   extern object listof (uintC len);
  9628. # wird verwendet von STREAM, PATHNAME, PACKAGE, ARRAY, EVAL, PREDTYPE, REXX, ERROR, SPVW
  9629.  
  9630. # ####################### MISCBIBL zu MISC.D ############################## #
  9631.  
  9632. # ####################### ERRBIBL zu ERROR.D ############################## #
  9633.  
  9634. # Klassifikation der bekannten Condition-Typen:
  9635. # (Genauer gesagt, handelt es sich hier immer um die SIMPLE-... Typen.)
  9636.   typedef enum
  9637.   {
  9638.     # all kinds of conditions
  9639.     condition,
  9640.       # conditions that require interactive intervention
  9641.       serious_condition,
  9642.         # serious conditions that occur deterministically
  9643.         error,
  9644.           # statically detectable errors of a program
  9645.           program_error,
  9646.           # not statically detectable errors in program control
  9647.           control_error,
  9648.           # errors that occur while doing arithmetic operations
  9649.           arithmetic_error,
  9650.             # trying to evaluate a mathematical function at a singularity
  9651.             division_by_zero,
  9652.             # trying to get too close to infinity in the floating point domain
  9653.             floating_point_overflow,
  9654.             # trying to get too close to zero in the floating point domain
  9655.             floating_point_underflow,
  9656.           # trying to access a location which contains #<UNBOUND>
  9657.           cell_error,
  9658.             # trying to get the value of an unbound variable
  9659.             unbound_variable,
  9660.             # trying to get the global function definition of an undefined function
  9661.             undefined_function,
  9662.           # when some datum does not belong to the expected type
  9663.           type_error,
  9664.           # errors during operation on packages
  9665.           package_error,
  9666.           # attempted violation of *PRINT-READABLY*
  9667.           print_not_readable,
  9668.           # errors while doing stream I/O
  9669.           stream_error,
  9670.             # unexpected end of stream
  9671.             end_of_file,
  9672.           # errors with pathnames, OS level errors with streams
  9673.           file_error,
  9674.         # "Virtual memory exhausted"
  9675.         storage_condition,
  9676.       # conditions for which user notification is appropriate
  9677.       warning,
  9678.     # junk
  9679.     condition_for_broken_compilers_that_dont_like_trailing_commas
  9680.   }
  9681.   conditiontype;
  9682.  
  9683. # Fehlermeldung mit Errorstring. Kehrt nicht zurück.
  9684. # fehler(errortype,errorstring);
  9685. # > errortype: Condition-Typ
  9686. # > errorstring: Konstanter ASCIZ-String.
  9687. #   Bei jeder Tilde wird ein LISP-Objekt vom STACK genommen und statt der
  9688. #   Tilde ausgegeben.
  9689. # > auf dem STACK: Initialisierungswerte für die Condition, je nach errortype
  9690.   nonreturning_function(extern, fehler, (conditiontype errortype, const char * errorstring));
  9691.   nonreturning_function(extern, fehler3, (conditiontype errortype, const char *arg1, const char *arg2, const char *arg3));
  9692.   nonreturning_function(extern, fehler4, (conditiontype errortype, const char *arg1, const char *arg2, const char *arg3, const char *arg4));
  9693.   nonreturning_function(extern, fehler5, (conditiontype errortype, const char *arg1, const char *arg2, const char *arg3, const char *arg4, const char *arg5));
  9694. # wird von allen Modulen verwendet
  9695.  
  9696.   nonreturning_function(extern, OS_error_debug, (const char *,int));
  9697.   # #define OS_error() OS_error_debug(__FILE__,__LINE__)
  9698.   #define OS_error() OS_error_()
  9699.  
  9700. #ifdef AMIGAOS
  9701.   # Behandlung von AMIGAOS-Fehlern
  9702.   # OS_error_();
  9703.   # > IoErr(): Fehlercode
  9704.     nonreturning_function(extern, OS_error_, (void));
  9705.   # wird verwendet von SPVW, STREAM, PATHNAME
  9706. #endif
  9707. #if defined(UNIX) || defined(DJUNIX) || defined(EMUNIX) || defined(WATCOM) || defined(RISCOS) || defined(WIN32_UNIX) || defined(WIN32_DOS)
  9708.   # Behandlung von UNIX-Fehlern
  9709.   # OS_error_();
  9710.   # > int errno: Fehlercode
  9711.     nonreturning_function(extern, OS_error_, (void));
  9712.   # wird verwendet von SPVW, STREAM, PATHNAME, GRAPH
  9713. #endif
  9714. #if defined(UNIX) || defined(EMUNIX) || defined(AMIGAOS) || defined(WATCOM) || defined(RISCOS) || defined(WIN32_UNIX) || defined(WIN32_DOS)
  9715.   # Initialisierung der Fehlertabelle:
  9716.     extern int init_errormsg_table (void);
  9717. #else
  9718.   # Nichts zu initialisieren.
  9719.     #define init_errormsg_table()  0
  9720. #endif
  9721.  
  9722. #if defined(UNIX) || defined(DJUNIX) || defined(EMUNIX) || defined(WATCOM) || defined(RISCOS) || defined(WIN32_UNIX) || defined(WIN32_DOS)
  9723.   # Ausgabe eines Fehlers, direkt übers Betriebssystem
  9724.   # errno_out(errorcode);
  9725.   # > int errorcode: Fehlercode
  9726.     extern void errno_out (int errorcode);
  9727. #endif
  9728.  
  9729. # UP: Führt eine Break-Schleife wegen Tastaturunterbrechung aus.
  9730. # > -(STACK) : aufrufende Funktion
  9731. # verändert STACK, kann GC auslösen
  9732.   extern void tast_break (void);
  9733. # wird verwendet von EVAL, IO, SPVW, STREAM
  9734.  
  9735. # Fehlermeldung, wenn ein Objekt keine Liste ist.
  9736. # fehler_list(obj);
  9737. # > arg: Nicht-Liste
  9738. # > subr_self: Aufrufer (ein SUBR)
  9739.   nonreturning_function(extern, fehler_list, (object obj));
  9740. # wird verwendet von LIST, EVAL
  9741.  
  9742. # Fehlermeldung, wenn ein Objekt kein Symbol ist.
  9743. # fehler_kein_symbol(caller,obj);
  9744. # > caller: Aufrufer (ein Symbol)
  9745. # > obj: Nicht-Symbol
  9746.   nonreturning_function(extern, fehler_kein_symbol, (object caller, object obj));
  9747. # wird verwendet von EVAL, CONTROL
  9748.  
  9749. # Fehlermeldung, wenn ein Objekt kein Symbol ist.
  9750. # fehler_symbol(obj);
  9751. # > subr_self: Aufrufer (ein SUBR oder FSUBR)
  9752. # > obj: Nicht-Symbol
  9753.   nonreturning_function(extern, fehler_symbol, (object obj));
  9754. # wird verwendet von SYMBOL, CONTROL
  9755.  
  9756. # Fehlermeldung, wenn ein Objekt kein Simple-Vector ist.
  9757. # fehler_kein_svector(caller,obj);
  9758. # > caller: Aufrufer (ein Symbol)
  9759. # > obj: Nicht-Svector
  9760.   nonreturning_function(extern, fehler_kein_svector, (object caller, object obj));
  9761. # wird verwendet von ARRAY, EVAL
  9762.  
  9763. # Fehlermeldung, wenn ein Objekt kein Vektor ist.
  9764. # fehler_vector(obj);
  9765. # > subr_self: Aufrufer (ein SUBR)
  9766. # > obj: Nicht-Vektor
  9767.   nonreturning_function(extern, fehler_vector, (object obj));
  9768. # wird verwendet von ARRAY
  9769.  
  9770. # Fehlermeldung, falls ein Argument kein Character ist:
  9771. # fehler_char(obj);
  9772. # > obj: Das fehlerhafte Argument
  9773. # > subr_self: Aufrufer (ein SUBR)
  9774.   nonreturning_function(extern, fehler_char, (object obj));
  9775. # wird verwendet von CHARSTRG
  9776.  
  9777. # Fehler, wenn Argument kein String-Char ist.
  9778. # fehler_string_char(obj);
  9779. # > obj: fehlerhaftes Argument
  9780. # > subr_self: Aufrufer (ein SUBR)
  9781.   nonreturning_function(extern, fehler_string_char, (object obj));
  9782. # wird verwendet von IO, STDWIN
  9783.  
  9784. # Fehlermeldung, falls ein Argument kein String ist:
  9785. # fehler_string(obj);
  9786. # > obj: Das fehlerhafte Argument
  9787. # > subr_self: Aufrufer (ein SUBR)
  9788.   nonreturning_function(extern, fehler_string, (object obj));
  9789. # wird verwendet von CHARSTRG, FOREIGN, STDWIN
  9790.  
  9791. # Fehlermeldung, falls ein Argument kein Simple-String ist:
  9792. # fehler_sstring(obj);
  9793. # > obj: Das fehlerhafte Argument
  9794. # > subr_self: Aufrufer (ein SUBR)
  9795.   nonreturning_function(extern, fehler_sstring, (object obj));
  9796. # wird verwendet von CHARSTRG
  9797.  
  9798. # Fehlermeldung, wenn ein Argument kein Stream ist:
  9799. # fehler_stream(obj);
  9800. # > obj: Das fehlerhafte Argument
  9801. # > subr_self: Aufrufer (ein SUBR)
  9802.   nonreturning_function(extern, fehler_stream, (object obj));
  9803. # wird verwendet von IO, STREAM, DEBUG
  9804.  
  9805. # Fehlermeldung, wenn ein Argument kein Stream vom geforderten Stream-Typ ist:
  9806. # fehler_streamtype(obj,type);
  9807. # > obj: Das fehlerhafte Argument
  9808. # > type: geforderter Stream-Typ
  9809. # > subr_self: Aufrufer (ein SUBR)
  9810.   nonreturning_function(extern, fehler_streamtype, (object obj, object type));
  9811. # wird verwendet von STREAM
  9812.  
  9813. #ifdef HAVE_FFI
  9814. # Überprüfung eines Arguments
  9815. # check_...(obj);
  9816. # > obj: Argument
  9817. # > subr_self: Aufrufer (ein SUBR)
  9818. # obj sollte eine Variable sein
  9819.   #define check_string_char(obj)  \
  9820.     if (!string_char_p(obj)) { fehler_string_char(obj); }
  9821.   #define check_uint8(obj)  \
  9822.     if (!uint8_p(obj)) { fehler_uint8(obj); }
  9823.   #define check_sint8(obj)  \
  9824.     if (!sint8_p(obj)) { fehler_sint8(obj); }
  9825.   #define check_uint16(obj)  \
  9826.     if (!uint16_p(obj)) { fehler_uint16(obj); }
  9827.   #define check_sint16(obj)  \
  9828.     if (!sint16_p(obj)) { fehler_sint16(obj); }
  9829.   #define check_uint32(obj)  \
  9830.     if (!uint32_p(obj)) { fehler_uint32(obj); }
  9831.   #define check_sint32(obj)  \
  9832.     if (!sint32_p(obj)) { fehler_sint32(obj); }
  9833.   #define check_uint64(obj)  \
  9834.     if (!uint64_p(obj)) { fehler_uint64(obj); }
  9835.   #define check_sint64(obj)  \
  9836.     if (!sint64_p(obj)) { fehler_sint64(obj); }
  9837.   #define check_uint(obj)  \
  9838.     if (!uint_p(obj)) { fehler_uint(obj); }
  9839.   #define check_sint(obj)  \
  9840.     if (!sint_p(obj)) { fehler_sint(obj); }
  9841.   #define check_ulong(obj)  \
  9842.     if (!ulong_p(obj)) { fehler_ulong(obj); }
  9843.   #define check_slong(obj)  \
  9844.     if (!slong_p(obj)) { fehler_slong(obj); }
  9845.   #define check_ffloat(obj)  \
  9846.     if (!single_float_p(obj)) { fehler_ffloat(obj); }
  9847.   #define check_dfloat(obj)  \
  9848.     if (!double_float_p(obj)) { fehler_dfloat(obj); }
  9849.   nonreturning_function(extern, fehler_uint8, (object obj));
  9850.   nonreturning_function(extern, fehler_sint8, (object obj));
  9851.   nonreturning_function(extern, fehler_uint16, (object obj));
  9852.   nonreturning_function(extern, fehler_sint16, (object obj));
  9853.   nonreturning_function(extern, fehler_uint32, (object obj));
  9854.   nonreturning_function(extern, fehler_sint32, (object obj));
  9855.   nonreturning_function(extern, fehler_uint64, (object obj));
  9856.   nonreturning_function(extern, fehler_sint64, (object obj));
  9857.   nonreturning_function(extern, fehler_uint, (object obj));
  9858.   nonreturning_function(extern, fehler_sint, (object obj));
  9859.   nonreturning_function(extern, fehler_ulong, (object obj));
  9860.   nonreturning_function(extern, fehler_slong, (object obj));
  9861.   nonreturning_function(extern, fehler_ffloat, (object obj));
  9862.   nonreturning_function(extern, fehler_dfloat, (object obj));
  9863. # wird verwendet vom FFI
  9864. #endif
  9865.  
  9866. # ##################### PACKBIBL zu PACKAGE.D ############################# #
  9867.  
  9868. # UP: testet, ob ein Symbol in einer Package accessible ist und dabei nicht
  9869. # von einem anderen Symbol desselben Namens verdeckt wird.
  9870. # accessiblep(sym,pack)
  9871. # > sym: Symbol
  9872. # > pack: Package
  9873. # < ergebnis: TRUE falls sym in pack accessible und nicht verdeckt ist,
  9874. #             FALSE sonst
  9875.   extern boolean accessiblep (object sym, object pack);
  9876. # wird verwendet von IO
  9877.  
  9878. # UP: testet, ob ein Symbol in einer Package als externes Symbol accessible
  9879. # ist.
  9880. # externalp(sym,pack)
  9881. # > sym: Symbol
  9882. # > pack: Package
  9883. # < ergebnis: TRUE falls sym in pack als externes Symbol accessible ist,
  9884. #             FALSE sonst
  9885.   extern boolean externalp (object sym, object pack);
  9886. # wird verwendet von IO
  9887.  
  9888. # UP: sucht ein externes Symbol gegebenen Printnamens in einer Package.
  9889. # find_external_symbol(string,pack,&sym)
  9890. # > string: String
  9891. # > pack: Package
  9892. # < ergebnis: TRUE, falls ein externes Symbol dieses Printnamens in pack gefunden.
  9893. # < sym: dieses Symbol, falls gefunden.
  9894.   extern boolean find_external_symbol (object string, object pack, object* sym_);
  9895. # wird verwendet von IO
  9896.  
  9897. # UP: sucht eine Package mit gegebenem Namen oder Nickname
  9898. # find_package(string)
  9899. # > string: String
  9900. # < ergebnis: Package mit diesem Namen oder NIL
  9901.   extern object find_package (object string);
  9902. # wird verwendet von IO
  9903.  
  9904. # UP: Interniert ein Symbol gegebenen Printnamens in einer Package.
  9905. # intern(string,pack,&sym)
  9906. # > string: String
  9907. # > pack: Package
  9908. # < sym: Symbol
  9909. # < ergebnis: 0, wenn nicht gefunden, sondern neu erzeugt
  9910. #             1, wenn als externes Symbol vorhanden
  9911. #             2, wenn vererbt über use-list
  9912. #             3, wenn als internes Symbol vorhanden
  9913. # kann GC auslösen
  9914.   extern uintBWL intern (object string, object pack, object* sym_);
  9915. # wird verwendet von IO, SPVW
  9916.  
  9917. # UP: Interniert ein Symbol gegebenen Printnamens in der Keyword-Package.
  9918. # intern_keyword(string)
  9919. # > string: String
  9920. # < ergebnis: Symbol, ein Keyword
  9921. # kann GC auslösen
  9922.   extern object intern_keyword (object string);
  9923. # wird verwendet von IO, EVAL, GRAPH
  9924.  
  9925. # UP: Importiert ein Symbol in eine Package
  9926. # import(&sym,&pack);
  9927. # > sym: Symbol (im STACK)
  9928. # > pack: Package (im STACK)
  9929. # < sym: Symbol, EQ zum alten
  9930. # < pack: Package, EQ zur alten
  9931. # kann GC auslösen
  9932.   extern void import (object* sym_, object* pack_);
  9933. # wird verwendet von SPVW
  9934.  
  9935. # UP: Exportiert ein Symbol aus einer Package
  9936. # export(&sym,&pack);
  9937. # > sym: Symbol (im STACK)
  9938. # > pack: Package (im STACK)
  9939. # < sym: Symbol, EQ zum alten
  9940. # < pack: Package, EQ zur alten
  9941. # kann GC auslösen
  9942.   extern void export (object* sym_, object* pack_);
  9943. # wird verwendet von SPVW
  9944.  
  9945. # UP: liefert die aktuelle Package
  9946. # get_current_package()
  9947. # < ergebnis: aktuelle Package
  9948.   extern object get_current_package (void);
  9949. # wird verwendet von IO
  9950.  
  9951. # UP: Initialisiert die Packageverwaltung
  9952. # init_packages();
  9953.   extern void init_packages (void);
  9954. # wird verwendet von SPVW
  9955.  
  9956. # ##################### PATHBIBL zu PATHNAME.D ############################ #
  9957.  
  9958. # UP: Liefert den Directory-Namestring eines halbwegs überprüften Pathname
  9959. #     unter der Annahme, daß das Directory dieses Pathname existiert,
  9960. #     im Betriebssystem-Format.
  9961. # assume_dir_exists()
  9962. # > STACK_0: absoluter Pathname, halbwegs überprüft
  9963. # < STACK_0: (evtl. derselbe) Pathname, noch besser aufgelöst
  9964. # < ergebnis:
  9965. #     falls Name=NIL: Directory-Namestring (fürs BS)
  9966. #     falls Name/=NIL: Namestring (für BS, mit Nullbyte am Schluß)
  9967. # kann GC auslösen
  9968.   extern object assume_dir_exists (void);
  9969. # wird verwendet von STREAM
  9970.  
  9971. # UP: Initialisiert das Pathname-System.
  9972. # init_pathnames();
  9973. # kann GC auslösen
  9974.   extern void init_pathnames (void);
  9975. # wird verwendet von SPVW
  9976.  
  9977. # Sucht das ausführbare Programm sofort nach Programmstart zu lokalisieren.
  9978. # find_executable(argv[0])
  9979.   extern int find_executable (const char * program_name);
  9980. # wird verwendet von SPVW
  9981.  
  9982. # ##################### PREDBIBL zu PREDTYPE.D ############################ #
  9983.  
  9984. # UP: testet auf Atomgleichheit EQL
  9985. # eql(obj1,obj2)
  9986. # > obj1,obj2: Lisp-Objekte
  9987. # < ergebnis: TRUE, falls Objekte gleich
  9988.   extern boolean eql (object obj1, object obj2);
  9989. # wird verwendet von CONTROL, EVAL, HASHTABL, LISPARIT
  9990.  
  9991. # UP: testet auf Gleichheit EQUAL
  9992. # equal(obj1,obj2)
  9993. # > obj1,obj2: Lisp-Objekte
  9994. # < ergebnis: TRUE, falls Objekte gleich
  9995.   extern boolean equal (object obj1, object obj2);
  9996. # wird verwendet von EVAL, PATHNAME, HASHTABL, MISC
  9997.  
  9998. # UP: testet auf laschere Gleichheit EQUALP
  9999. # equalp(obj1,obj2)
  10000. # > obj1,obj2: Lisp-Objekte
  10001. # < ergebnis: TRUE, falls Objekte gleich
  10002. # kann GC auslösen
  10003.   extern boolean equalp (object obj1, object obj2);
  10004. # wird verwendet von
  10005.  
  10006. # ###################### SEQBIBL zu SEQUENCE.D ############################ #
  10007.  
  10008. # UP: Wandelt ein Objekt in eine Sequence gegebenen Typs um.
  10009. # coerce_sequence(obj,result_type)
  10010. # > obj: Objekt, sollte eine Sequence sein
  10011. # > result_type: Bezeichner (Symbol) des Sequence-Typs
  10012. # < Wert: Sequence vom Typ result_type
  10013. # kann GC auslösen
  10014.   extern Values coerce_sequence (object sequence, object result_type);
  10015. # wird verwendet von PREDTYPE, EVAL
  10016.  
  10017. # Fehler, wenn beide :TEST, :TEST-NOT - Argumente angegeben wurden.
  10018. # fehler_both_tests();
  10019. # > subr_self: Aufrufer (ein SUBR)
  10020.   nonreturning_function(extern, fehler_both_tests, (void));
  10021. # wird verwendet von LIST
  10022.  
  10023. # ###################### STRMBIBL zu STREAM.D ############################# #
  10024.  
  10025. # UP: Initialisiert die Stream-Variablen.
  10026. # init_streamvars();
  10027. # kann GC auslösen
  10028.   extern void init_streamvars (void);
  10029. # wird verwendet von SPVW
  10030.  
  10031. # Fehlermeldung, wenn eine Stream-Operation auf einem Stream nicht erlaubt ist.
  10032. # fehler_illegal_streamop(caller,stream);
  10033. # > caller: Aufrufer (ein Symbol)
  10034. # > stream: Stream
  10035.   nonreturning_function(extern, fehler_illegal_streamop, (object caller, object stream));
  10036. # wird verwendet von IO
  10037.  
  10038. # Liest ein Byte von einem Stream.
  10039. # read_byte(stream)
  10040. # > stream: Stream
  10041. # < ergebnis: gelesener Integer (eof_value bei EOF)
  10042. # kann GC auslösen
  10043.   extern object read_byte (object stream);
  10044. # wird verwendet von PATHNAME, SEQUENCE
  10045.  
  10046. # Schreibt ein Byte auf einen Stream.
  10047. # write_byte(stream,byte);
  10048. # > stream: Stream
  10049. # > byte: auszugebender Integer
  10050. # kann GC auslösen
  10051.   extern void write_byte(object stream, object byte);
  10052. # wird verwendet von SEQUENCE
  10053.  
  10054. # Liest ein Character von einem Stream.
  10055. # read_char(&stream)
  10056. # > stream: Stream
  10057. # < stream: Stream
  10058. # < ergebnis: gelesenes Character (eof_value bei EOF)
  10059. # kann GC auslösen
  10060.   extern object read_char (object* stream_);
  10061. # wird verwendet von IO, DEBUG, SEQUENCE
  10062.  
  10063. # Schiebt das letzte gelesene Character auf einen Stream zurück.
  10064. # unread_char(&stream,ch);
  10065. # > ch: letztes gelesenes Character
  10066. # > stream: Stream
  10067. # < stream: Stream
  10068.   extern void unread_char (object* stream_, object ch);
  10069. # wird verwendet von IO, DEBUG
  10070.  
  10071. # Liest ein Character von einem Stream, ohne es zu verbrauchen.
  10072. # peek_char(&stream)
  10073. # > stream: Stream
  10074. # < stream: Stream
  10075. # < ergebnis: gelesenes Character (eof_value bei EOF)
  10076. # kann GC auslösen
  10077.   extern object peek_char (object* stream_);
  10078. # wird verwendet von IO
  10079.  
  10080. # Schreibt ein Character auf einen Stream.
  10081. # write_char(&stream,ch);
  10082. # > ch: auszugebendes Character
  10083. # > stream: Stream
  10084. # < stream: Stream
  10085. # kann GC auslösen
  10086.   extern void write_char (object* stream_, object ch);
  10087. # wird verwendet von LISPARIT, IO, ERROR, SEQUENCE
  10088.  
  10089. # Schreibt ein festes Standard-Char auf einen Stream.
  10090. # write_schar(&stream,ch);
  10091. # > stream: Stream
  10092. # < stream: Stream
  10093. # kann GC auslösen
  10094.   # extern void write_schar (object* stream_, uintB ch);
  10095.   #define write_schar(stream_,ch)  write_char(stream_,code_char(ch))
  10096. # wird verwendet von LISPARIT, IO, DEBUG, Macro TERPRI
  10097.  
  10098. # UP: Schließt einen Stream.
  10099. # stream_close(&stream);
  10100. # > stream: Stream
  10101. # < stream: Stream
  10102. # kann GC auslösen
  10103.   extern void stream_close (object* stream_);
  10104. # wird verwendet von PATHNAME, SPVW, DEBUG, MISC
  10105.  
  10106. # UP: Schließt eine Liste offener Files.
  10107. # close_some_files(list);
  10108. # > list: Liste von offenen Streams
  10109. # kann GC auslösen
  10110.   extern void close_some_files (object list);
  10111. # wird verwendet von SPVW
  10112.  
  10113. # UP: Schließt alle offenen Files.
  10114. # close_all_files();
  10115. # kann GC auslösen
  10116.   extern void close_all_files (void);
  10117. # wird verwendet von SPVW
  10118.  
  10119. # UP: Erklärt alle offenen File-Streams für geschlossen.
  10120. # closed_all_files();
  10121.   extern void closed_all_files (void);
  10122. # wird verwendet von SPVW
  10123.  
  10124. # UP: Stellt fest, ob im Stream stream ein Zeichen sofort verfügbar ist.
  10125. # stream_listen(stream)
  10126. # > stream: Stream
  10127. # < ergebnis:  0 falls Zeichen verfügbar,
  10128. #             -1 falls bei EOF angelangt,
  10129. #             +1 falls kein Zeichen verfügbar, aber nicht wegen EOF
  10130. # kann GC auslösen
  10131.   extern signean stream_listen (object stream);
  10132. # wird verwendet von IO, DEBUG
  10133.  
  10134. # UP: Löscht bereits eingegebenen interaktiven Input von einem Stream stream.
  10135. # clear_input(stream)
  10136. # > stream: Stream
  10137. # < ergebnis: TRUE falls Input gelöscht wurde
  10138. # kann GC auslösen
  10139.   extern boolean clear_input (object stream);
  10140. # wird verwendet von IO, DEBUG
  10141.  
  10142. # UP: Wartenden Output eines Stream stream ans Ziel bringen.
  10143. # finish_output(stream);
  10144. # > stream: Stream
  10145. # kann GC auslösen
  10146.   extern void finish_output (object stream);
  10147. # wird verwendet von IO
  10148.  
  10149. # UP: Wartenden Output eines Stream stream ans Ziel bringen.
  10150. # force_output(stream);
  10151. # > stream: Stream
  10152. # kann GC auslösen
  10153.   extern void force_output (object stream);
  10154. # wird verwendet von IO
  10155.  
  10156. # UP: Wartenden Output eines Stream stream löschen.
  10157. # clear_output(stream);
  10158. # > stream: Stream
  10159. # kann GC auslösen
  10160.   extern void clear_output (object stream);
  10161. # wird verwendet von IO
  10162.  
  10163. # UP: Liefert die Line-Position eines Streams.
  10164. # get_line_position(stream)
  10165. # > stream: Stream
  10166. # < ergebnis: Line-Position (Fixnum >=0)
  10167.   extern object get_line_position (object stream);
  10168. # wird verwendet von IO, DEBUG
  10169.  
  10170. # UP: Liest mehrere Bytes von einem Stream.
  10171. # read_byte_array(stream,byteptr,len)
  10172. # > stream: Stream
  10173. # > uintB* byteptr: Adresse der zu füllenden Bytefolge
  10174. # > uintL len: Länge der zu füllenden Bytefolge
  10175. # < uintB* ergebnis: Pointer ans Ende des gefüllten Bereiches oder NULL
  10176.   extern uintB* read_byte_array (object stream, uintB* byteptr, uintL len);
  10177. # wird verwendet von SEQUENCE
  10178.  
  10179. # UP: Schreibt mehrere Bytes auf einen Stream.
  10180. # write_byte_array(stream,byteptr,len)
  10181. # > stream: Stream
  10182. # > uintB* byteptr: Adresse der zu schreibenden Bytefolge
  10183. # > uintL len: Länge der zu schreibenden Bytefolge
  10184. # < uintB* ergebnis: Pointer ans Ende des geschriebenen Bereiches oder NULL
  10185.   extern uintB* write_byte_array (object stream, uintB* byteptr, uintL len);
  10186. # wird verwendet von SEQUENCE
  10187.  
  10188. # UP: Liest mehrere String-Characters von einem Stream.
  10189. # read_schar_array(stream,charptr,len)
  10190. # > stream: Stream
  10191. # > uintB* charptr: Adresse der zu füllenden Zeichenfolge
  10192. # > uintL len: Länge der zu füllenden Zeichenfolge
  10193. # < uintB* ergebnis: Pointer ans Ende des gefüllten Bereiches oder NULL
  10194.   extern uintB* read_schar_array (object stream, uintB* charptr, uintL len);
  10195. # wird verwendet von SEQUENCE
  10196.  
  10197. # UP: Schreibt mehrere String-Characters auf einen Stream.
  10198. # write_schar_array(stream,charptr,len)
  10199. # > stream: Stream
  10200. # > uintB* charptr: Adresse der zu schreibenden Zeichenfolge
  10201. # > uintL len: Länge der zu schreibenden Zeichenfolge
  10202. # < uintB* ergebnis: Pointer ans Ende des geschriebenen Bereiches oder NULL
  10203.   extern uintB* write_schar_array (object stream, uintB* charptr, uintL len);
  10204. # wird verwendet von SEQUENCE
  10205.  
  10206. # UP: Liefert den Stream, der der Wert einer Variablen ist.
  10207. # var_stream(sym,strmflags)
  10208. # > sym: Variable (Symbol)
  10209. # > strmflags: Menge von Operationen, die auf dem Stream möglich sein sollen
  10210. # < ergebnis: Stream
  10211.   extern object var_stream (object sym, uintB strmflags);
  10212. # wird verwendet von IO, PACKAGE, ERROR, DEBUG, SPVW
  10213.  
  10214. # UP: erzeugt ein File-Stream
  10215. # make_file_stream(handle,direction,type,eltype_size,append_flag)
  10216. # > handle: Handle des geöffneten Files
  10217. # > STACK_1: Filename, ein Pathname
  10218. # > STACK_0: Truename, ein Pathname
  10219. # > direction: Modus (0 = :PROBE, 1 = :INPUT, 4 = :OUTPUT, 5 = :IO, 3 = :INPUT-IMMUTABLE)
  10220. # > type: nähere Typinfo
  10221. #         (STRMTYPE_SCH_FILE oder STRMTYPE_CH_FILE oder
  10222. #          STRMTYPE_IU_FILE oder STRMTYPE_IS_FILE)
  10223. # > eltype_size: (bei Integer-Streams) Größe der Elemente in Bits,
  10224. #         ein Fixnum >0 und <intDsize*uintC_max
  10225. # > append_flag: TRUE falls der Stream gleich ans Ende positioniert werden
  10226. #         soll, FALSE sonst
  10227. # < ergebnis: File-Stream (oder evtl. File-Handle-Stream)
  10228. # < STACK: aufgeräumt
  10229. # kann GC auslösen
  10230.   extern object make_file_stream (object handle, uintB direction, uintB type, object eltype_size, boolean append_flag);
  10231. # wird verwendet von PATHNAME
  10232.  
  10233. # Liefert einen Broadcast-Stream zum Stream stream.
  10234. # make_broadcast1_stream(stream)
  10235. # kann GC auslösen
  10236.   extern object make_broadcast1_stream (object stream);
  10237. # wird verwendet von IO
  10238.  
  10239. # Liefert einen Two-Way-Stream zu einem Input-Stream und einem Output-Stream.
  10240. # make_twoway_stream(input_stream,output_stream)
  10241. # > input_stream : Input-Stream
  10242. # > output_stream : Output-Stream
  10243. # < ergebnis : Two-Way-Stream
  10244. # kann GC auslösen
  10245.   extern object make_twoway_stream (object input_stream, object output_stream);
  10246. # wird verwendet von SPVW
  10247.  
  10248. # Liefert einen String-Output-Stream.
  10249. # make_string_output_stream()
  10250. # kann GC auslösen
  10251.   extern object make_string_output_stream (void);
  10252. # wird verwendet von IO, EVAL, DEBUG, ERROR
  10253.  
  10254. # UP: Liefert das von einem String-Output-Stream Angesammelte.
  10255. # get_output_stream_string(&stream)
  10256. # > stream: String-Output-Stream
  10257. # < stream: geleerter Stream
  10258. # < ergebnis: Angesammeltes, ein Simple-String
  10259. # kann GC auslösen
  10260.   extern object get_output_stream_string (object* stream_);
  10261. # wird verwendet von IO, EVAL, DEBUG, ERROR
  10262.  
  10263. # UP: Liefert einen Pretty-Printer-Hilfs-Stream.
  10264. # make_pphelp_stream()
  10265. # kann GC auslösen
  10266.   extern object make_pphelp_stream (void);
  10267. # wird verwendet von IO
  10268.  
  10269. #if (defined(UNIX) && !defined(NEXTAPP)) || defined(AMIGAOS) || defined(RISCOS)
  10270. # UP: Terminal wieder in Normalzustand schalten
  10271. # terminal_sane();
  10272.   extern void terminal_sane (void);
  10273. # wird verwendet von SPVW
  10274. #endif
  10275.  
  10276. # ####################### SYMBIBL zu SYMBOL.D ############################# #
  10277.  
  10278. # UP: Liefert die globale Funktionsdefinition eines Symbols,
  10279. # mit Test, ob das Symbol eine globale Funktion darstellt.
  10280. # Symbol_function_checked(symbol)
  10281. # > symbol: Symbol
  10282. # < ergebnis: seine globale Funktionsdefinition
  10283.   extern object Symbol_function_checked (object symbol);
  10284. # wird verwendet von
  10285.  
  10286. # UP: Holt eine Property aus der Property-Liste eines Symbols.
  10287. # get(symbol,key)
  10288. # > symbol: ein Symbol
  10289. # > key: ein mit EQ zu vergleichender Key
  10290. # < value: dazugehöriger Wert aus der Property-Liste von symbol, oder unbound.
  10291.   extern object get (object symbol, object key);
  10292. # wird verwendet von IO, CONTROL, EVAL, PREDTYPE, SEQUENCE
  10293.  
  10294. # ##################### ARITBIBL zu LISTARIT.D ############################ #
  10295.  
  10296. # UP: Initialisiert die Arithmetik.
  10297. # init_arith();
  10298. # kann GC auslösen
  10299.   extern void init_arith (void);
  10300. # wird verwendet von SPVW
  10301.  
  10302. # Wandelt Longword in Integer um.
  10303. # L_to_I(wert)
  10304. # > wert: Wert des Integers, ein signed 32-Bit-Integer.
  10305. # < ergebnis: Integer mit diesem Wert.
  10306. # kann GC auslösen
  10307.   extern object L_to_I (sint32 wert);
  10308. # wird verwendet von TIME, REXX
  10309.  
  10310. # Wandelt Unsigned Longword in Integer >=0 um.
  10311. # UL_to_I(wert)
  10312. # > wert: Wert des Integers, ein unsigned 32-Bit-Integer.
  10313. # < ergebnis: Integer mit diesem Wert.
  10314. # kann GC auslösen
  10315.   #if (intLsize<=oint_data_len)
  10316.     #define UL_to_I(wert)  fixnum((uintL)(wert))
  10317.   #else
  10318.     extern object UL_to_I (uintL wert);
  10319.   #endif
  10320. # wird verwendet von MISC, TIME, STREAM, PATHNAME, HASHTABL, SPVW, ARRAY
  10321.  
  10322. # Wandelt Doppel-Longword in Integer um.
  10323. # L2_to_I(wert_hi,wert_lo)
  10324. # > wert_hi|wert_lo: Wert des Integers, ein signed 64-Bit-Integer.
  10325. # < ergebnis: Integer mit diesem Wert.
  10326. # kann GC auslösen
  10327.   extern object L2_to_I (sint32 wert_hi, uint32 wert_lo);
  10328. # wird verwendet von TIME, FOREIGN
  10329.  
  10330. #ifdef HAVE_FFI
  10331. # Wandelt Unsigned Doppel-Longword in Integer um.
  10332. # UL2_to_I(wert_hi,wert_lo)
  10333. # > wert_hi|wert_lo: Wert des Integers, ein unsigned 64-Bit-Integer.
  10334. # < ergebnis: Integer mit diesem Wert.
  10335. # kann GC auslösen
  10336.   extern object UL2_to_I (uint32 wert_hi, uint32 wert_lo);
  10337. # wird verwendet von FOREIGN, vom FFI
  10338. #endif
  10339.  
  10340. #ifdef intQsize
  10341. # Wandelt Quadword in Integer um.
  10342. # Q_to_I(wert)
  10343. # > wert: Wert des Integers, ein signed 64-Bit-Integer.
  10344. # < ergebnis: Integer mit diesem Wert.
  10345. # kann GC auslösen
  10346.   extern object Q_to_I (sint64 wert);
  10347. # wird verwendet vom FFI
  10348. #endif
  10349.  
  10350. #if defined(intQsize) || defined(WIDE_HARD)
  10351. # Wandelt Unsigned Quadword in Integer >=0 um.
  10352. # UQ_to_I(wert)
  10353. # > wert: Wert des Integers, ein unsigned 64-Bit-Integer.
  10354. # < ergebnis: Integer mit diesem Wert.
  10355. # kann GC auslösen
  10356.   extern object UQ_to_I (uint64 wert);
  10357. # wird verwendet von MISC, TIME, FFI
  10358. #endif
  10359.  
  10360. # Wandelt ein C-Integer gegebenen Typs in ein Integer um.
  10361. # val sollte eine Variable sein.
  10362.   #define uint8_to_I(val)  fixnum((uint8)(val))
  10363.   #define sint8_to_I(val)  L_to_I((sint32)(sint8)(val))
  10364.   #define uint16_to_I(val)  fixnum((uint16)(val))
  10365.   #define sint16_to_I(val)  L_to_I((sint32)(sint16)(val))
  10366.   #define uint32_to_I(val)  UL_to_I((uint32)(val))
  10367.   #define sint32_to_I(val)  L_to_I((sint32)(val))
  10368.   #ifdef intQsize
  10369.     #define uint64_to_I(val)  UQ_to_I((uint64)(val))
  10370.     #define sint64_to_I(val)  Q_to_I((sint64)(val))
  10371.   #elif defined(HAVE_FFI)
  10372.     #define uint64_to_I(val)  UL2_to_I((uint32)((val)>>32),(uint32)(val))
  10373.     #define sint64_to_I(val)  L2_to_I((sint32)((val)>>32),(uint32)(val))
  10374.   #endif
  10375.   #if (int_bitsize==16)
  10376.     #define uint_to_I(val)  uint16_to_I(val)
  10377.     #define sint_to_I(val)  sint16_to_I(val)
  10378.   #else # (int_bitsize==32)
  10379.     #define uint_to_I(val)  uint32_to_I(val)
  10380.     #define sint_to_I(val)  sint32_to_I(val)
  10381.   #endif
  10382.   #if (long_bitsize==32)
  10383.     #define ulong_to_I(val)  uint32_to_I(val)
  10384.     #define slong_to_I(val)  sint32_to_I(val)
  10385.   #else # (long_bitsize==64)
  10386.     #define ulong_to_I(val)  uint64_to_I(val)
  10387.     #define slong_to_I(val)  sint64_to_I(val)
  10388.   #endif
  10389. # wird verwendet von MISC, vom FFI
  10390.  
  10391. # Wandelt Integer >=0 in Unsigned Longword um.
  10392. # I_to_UL(obj)
  10393. # > obj: ein Objekt, sollte ein Integer >=0, <2^32 sein
  10394. # < ergebnis: der Wert des Integer als Unsigned Longword.
  10395.   extern uintL I_to_UL (object obj);
  10396. # wird verwendet von TIME, ARRAY
  10397.  
  10398. # Wandelt Integer in Signed Longword um.
  10399. # I_to_L(obj)
  10400. # > obj: ein Objekt, sollte ein Integer >=-2^31, <2^31 sein
  10401. # < ergebnis: der Wert des Integer als Longword.
  10402.   extern sintL I_to_L (object obj);
  10403. # wird verwendet von STDWIN
  10404.  
  10405. #if (defined(HAVE_FFI) || defined(HAVE_AFFI)) && defined(HAVE_LONGLONG)
  10406.  
  10407. # Wandelt Integer >=0 in Unsigned Quadword um.
  10408. # I_to_UQ(obj)
  10409. # > obj: ein Objekt, sollte ein Integer >=0, <2^64 sein
  10410. # < ergebnis: der Wert des Integer als Unsigned Quadword.
  10411.   extern uint64 I_to_UQ (object obj);
  10412. # wird verwendet von AFFI, FOREIGN, vom FFI
  10413.  
  10414. #endif
  10415. #if defined(HAVE_FFI) && defined(HAVE_LONGLONG)
  10416.  
  10417. # Wandelt Integer in Signed Quadword um.
  10418. # I_to_Q(obj)
  10419. # > obj: ein Objekt, sollte ein Integer >=-2^63, <2^63 sein
  10420. # < ergebnis: der Wert des Integer als Quadword.
  10421.   extern sint64 I_to_Q (object obj);
  10422. # wird verwendet von FOREIGN, vom FFI
  10423.  
  10424. #endif
  10425.  
  10426. #if defined(HAVE_FFI) || defined(HAVE_AFFI)
  10427. # Wandelt ein Integer in ein C-Integer gegebenen Typs um.
  10428. # I_to_xintyy(obj) setzt voraus, daß xintyy_p(obj) schon abgeprüft wurde.
  10429.   #define I_to_uint8(obj)  (uint8)(as_oint(obj) >> oint_data_shift)
  10430.   #define I_to_sint8(obj)  (sint8)(as_oint(obj) >> oint_data_shift)
  10431.   #define I_to_uint16(obj)  (uint16)(as_oint(obj) >> oint_data_shift)
  10432.   #define I_to_sint16(obj)  (sint16)(as_oint(obj) >> oint_data_shift)
  10433.   #if (oint_data_len>=32)
  10434.     #define I_to_uint32(obj)  (uint32)(as_oint(obj) >> oint_data_shift)
  10435.   #else
  10436.     #define I_to_uint32(obj)  I_to_UL(obj)
  10437.   #endif
  10438.   #if (oint_data_len>=31)
  10439.     #define I_to_sint32(obj)  (sint32)(as_oint(obj) >> oint_data_shift)
  10440.   #else
  10441.     #define I_to_sint32(obj)  I_to_L(obj)
  10442.   #endif
  10443.   #define I_to_uint64(obj)  I_to_UQ(obj)
  10444.   #define I_to_sint64(obj)  I_to_Q(obj)
  10445.   #if (int_bitsize==16)
  10446.     #define I_to_uint  I_to_uint16
  10447.     #define I_to_sint  I_to_sint16
  10448.   #else # (int_bitsize==32)
  10449.     #define I_to_uint  I_to_uint32
  10450.     #define I_to_sint  I_to_sint32
  10451.   #endif
  10452.   #if (long_bitsize==32)
  10453.     #define I_to_ulong  I_to_uint32
  10454.     #define I_to_slong  I_to_sint32
  10455.   #else # (long_bitsize==64)
  10456.     #define I_to_ulong  I_to_uint64
  10457.     #define I_to_slong  I_to_sint64
  10458.   #endif
  10459. # wird verwendet von AFFI, vom FFI
  10460. #endif
  10461.  
  10462. # I_I_comp(x,y) vergleicht zwei Integers x und y.
  10463. # Ergebnis: 0 falls x=y, +1 falls x>y, -1 falls x<y.
  10464.   extern signean I_I_comp (object x, object y);
  10465. # wird verwendet von SEQUENCE
  10466.  
  10467. # (1+ x), wo x ein Integer ist. Ergebnis Integer.
  10468. # I_1_plus_I(x)
  10469. # kann GC auslösen
  10470.   extern object I_1_plus_I (object x);
  10471. # wird verwendet von SEQUENCE, SPVW, SYMBOL
  10472.  
  10473. # (1- x), wo x ein Integer ist. Ergebnis Integer.
  10474. # I_minus1_plus_I(x)
  10475. # kann GC auslösen
  10476.   extern object I_minus1_plus_I (object x);
  10477. # wird verwendet von SEQUENCE
  10478.  
  10479. # (+ x y), wo x und y Integers sind. Ergebnis Integer.
  10480. # I_I_plus_I(x,y)
  10481. # kann GC auslösen
  10482.   extern object I_I_plus_I (object x, object y);
  10483. # wird verwendet von SEQUENCE
  10484.  
  10485. # (- x y), wo x und y Integers sind. Ergebnis Integer.
  10486. # I_I_minus_I(x,y)
  10487. # kann GC auslösen
  10488.   extern object I_I_minus_I (object x, object y);
  10489. # wird verwendet von SEQUENCE
  10490.  
  10491. # (ASH x y), wo x und y Integers sind. Ergebnis Integer.
  10492. # I_I_ash_I(x,y)
  10493. # kann GC auslösen
  10494.   extern object I_I_ash_I (object x, object y);
  10495. # wird verwendet von SEQUENCE
  10496.  
  10497. # (INTEGER-LENGTH x), wo x ein Integer ist. Ergebnis uintL.
  10498. # I_integer_length(x)
  10499.   extern uintL I_integer_length (object x);
  10500. # wird verwendet von ARRAY
  10501.  
  10502. #ifdef HAVE_FFI
  10503.  
  10504. # c_float_to_FF(&val) wandelt ein IEEE-Single-Float val in ein Single-Float um.
  10505. # kann GC auslösen
  10506.   extern object c_float_to_FF (ffloatjanus* val_);
  10507.  
  10508. # FF_to_c_float(obj,&val);
  10509. # wandelt ein Single-Float obj in ein IEEE-Single-Float val um.
  10510.   extern void FF_to_c_float (object obj, ffloatjanus* val_);
  10511.  
  10512. # c_double_to_DF(&val) wandelt ein IEEE-Double-Float val in ein Double-Float um.
  10513. # kann GC auslösen
  10514.   extern object c_double_to_DF (dfloatjanus* val_);
  10515.  
  10516. # DF_to_c_double(obj,&val);
  10517. # wandelt ein Double-Float obj in ein IEEE-Double-Float val um.
  10518.   extern void DF_to_c_double (object obj, dfloatjanus* val_);
  10519.  
  10520. #endif
  10521.  
  10522. # UP: Wandelt eine Zeichenkette mit Integer-Syntax in ein Integer um.
  10523. # Punkte werden überlesen.
  10524. # read_integer(base,sign,string,index1,index2)
  10525. # > base: Lesebasis (>=2, <=36)
  10526. # > sign: Vorzeichen (/=0 falls negativ)
  10527. # > string: Simple-String (enthält Ziffern mit Wert <base und evtl. Punkt)
  10528. # > index1: Index der ersten Ziffer
  10529. # > index2: Index nach der letzten Ziffer
  10530. #   (also index2-index1 Ziffern, incl. evtl. Dezimalpunkt am Schluß)
  10531. # < ergebnis: Integer
  10532. # kann GC auslösen
  10533.   extern object read_integer (uintWL base,
  10534.          signean sign, object string, uintL index1, uintL index2);
  10535. # wird verwendet von IO
  10536.  
  10537. # UP: Wandelt eine Zeichenkette mit Rational-Syntax in eine rationale Zahl um.
  10538. # read_rational(base,sign,string,index1,index3,index2)
  10539. # > base: Lesebasis (>=2, <=36)
  10540. # > sign: Vorzeichen (/=0 falls negativ)
  10541. # > string: Simple-String (enthält Ziffern mit Wert <base und Bruchstrich)
  10542. # > index1: Index der ersten Ziffer
  10543. # > index3: Index von '/'
  10544. # > index2: Index nach der letzten Ziffer
  10545. #   (also index3-index1 Zähler-Ziffern, index2-index3-1 Nenner-Ziffern)
  10546. # < ergebnis: rationale Zahl
  10547. # kann GC auslösen
  10548.   extern object read_rational (uintWL base,
  10549.          signean sign, object string, uintL index1, uintL index3, uintL index2);
  10550. # wird verwendet von IO
  10551.  
  10552. # UP: Wandelt eine Zeichenkette mit Float-Syntax in ein Float um.
  10553. # read_float(base,sign,string,index1,index4,index2,index3)
  10554. # > base: Lesebasis (=10)
  10555. # > sign: Vorzeichen (/=0 falls negativ)
  10556. # > string: Simple-String (enthält Ziffern und evtl. Punkt und Exponentmarker)
  10557. # > index1: Index vom Mantissenanfang (excl. Vorzeichen)
  10558. # > index4: Index nach dem Mantissenende
  10559. # > index2: Index beim Ende der Characters
  10560. # > index3: Index nach dem Dezimalpunkt (=index4 falls keiner da)
  10561. #   (also Mantisse mit index4-index1 Characters: Ziffern und max. 1 '.')
  10562. #   (also index4-index3 Nachkommaziffern)
  10563. #   (also bei index4<index2: index4 = Index des Exponent-Markers,
  10564. #    index4+1 = Index des Exponenten-Vorzeichens oder der ersten
  10565. #    Exponenten-Ziffer)
  10566. # < ergebnis: Float
  10567. # kann GC auslösen
  10568.   extern object read_float (uintWL base,
  10569.          signean sign, object string, uintL index1, uintL index4, uintL index2, uintL index3);
  10570. # wird verwendet von IO
  10571.  
  10572. # UP: Gibt ein Integer aus.
  10573. # print_integer(z,base,&stream);
  10574. # > z: Integer
  10575. # > base: Basis (>=2, <=36)
  10576. # > stream: Stream
  10577. # < stream: Stream
  10578. # kann GC auslösen
  10579.   extern void print_integer (object z, uintWL base, object* stream_);
  10580. # wird verwendet von IO
  10581.  
  10582. # UP: Gibt ein Float aus.
  10583. # print_float(z,&stream);
  10584. # > z: Float
  10585. # > stream: Stream
  10586. # < stream: Stream
  10587. # kann GC auslösen
  10588.   extern void print_float (object z, object* stream_);
  10589. # wird verwendet von IO
  10590.  
  10591. # UP: Multipliziert ein Integer mit 10 und addiert eine weitere Ziffer.
  10592. # mal_10_plus_x(y,x)
  10593. # > y: Integer Y (>=0)
  10594. # > x: Ziffernwert X (>=0,<10)
  10595. # < ergebnis: Integer Y*10+X (>=0)
  10596. # kann GC auslösen
  10597.   extern object mal_10_plus_x (object y, uintB x);
  10598. # wird verwendet von IO
  10599.  
  10600. # UP: entscheidet auf Zahlgleichheit
  10601. # number_gleich(x,y)
  10602. # > x,y: zwei Zahlen
  10603. # < ergebnis: TRUE, falls (= x y) gilt
  10604. # kann GC auslösen
  10605.   extern boolean number_gleich (object x, object y);
  10606. # wird verwendet von PREDTYPE
  10607.  
  10608. # UP: Wandelt ein Objekt in ein Float von gegebenem Typ um.
  10609. # coerce_float(obj,type)
  10610. # > obj: Objekt
  10611. # > type: Eines der Symbole
  10612. #         FLOAT, SHORT-FLOAT, SINGLE-FLOAT, DOUBLE-FLOAT, LONG-FLOAT
  10613. # > subr_self: Aufrufer (ein SUBR)
  10614. # < ergebnis: (coerce obj type)
  10615. # kann GC auslösen
  10616.   extern object coerce_float (object obj, object type);
  10617. # wird verwendet von PREDTYPE
  10618.  
  10619. # ###################### FRGNIBL zu FOREIGN.D ############################# #
  10620.  
  10621. #ifdef DYNAMIC_FFI
  10622.  
  10623. # Return the pointer encoded by a Foreign-Pointer. obj a variable
  10624.   #define Fpointer_value(obj)  \
  10625.     (fp_validp(TheFpointer(obj)) ? 0 : (validate_fpointer(obj), 0), \
  10626.      TheFpointer(obj)->fp_pointer                                   \
  10627.     )
  10628.   extern void validate_fpointer (object obj);
  10629.  
  10630. # Return the pointer encoded by a Foreign-Address. obj a variable
  10631.   #define Faddress_value(obj)  \
  10632.     ((void*)((uintP)Fpointer_value(TheFaddress(obj)->fa_base) + TheFaddress(obj)->fa_offset))
  10633.  
  10634. # Registers a foreign variable.
  10635. # register_foreign_variable(address,name,flags,size);
  10636. # > address: address of a variable in memory
  10637. # > name: its name
  10638. # > flags: fv_readonly for read-only variables
  10639. # > size: its size in bytes
  10640. # kann GC auslösen
  10641.   extern void register_foreign_variable (void* address, const char * name, uintBWL flags, uintL size);
  10642. # Specifies that the variable will not be written to.
  10643. #define fv_readonly  bit(0)
  10644. # Specifies that when the value is replaced and the variable contains pointers,
  10645. # the old storage will be free()d and new storage will be allocated via malloc().
  10646. #define fv_malloc    bit(1)
  10647.  
  10648. # Registers a foreign function.
  10649. # register_foreign_function(address,name,flags);
  10650. # > address: address of the function in memory
  10651. # > name: its name
  10652. # > flags: its language and parameter passing convention
  10653. # kann GC auslösen
  10654.   extern void register_foreign_function (void* address, const char * name, uintWL flags);
  10655. # Flags for language:
  10656. #define ff_lang_asm       bit(8)  # no argument passing conventions
  10657. #define ff_lang_c         bit(9)  # K&R C, with argument type promotions
  10658. #define ff_lang_ansi_c    bit(10) # ANSI C, without argument type promotions
  10659. # define ff_lang_pascal   bit(11) # not yet supported
  10660. # Varargs functions are not supported.
  10661. # Set this if pointers within the arg should point to alloca()ed data, i.e.
  10662. # have dynamic extent: are valid for this call only.
  10663. #define ff_alloca         bit(0)
  10664. # Set this if pointers within the arg should point to malloc()ed data. The
  10665. # function takes over responsibility for that storage. For return values,
  10666. # set this if free() shall be called for pointers within the resulting value.
  10667. #define ff_malloc         bit(1)
  10668. # Set this if the arg should point to a place where a return value can be
  10669. # stored.
  10670. #define ff_out            bit(4)
  10671. # Set this if the arg is also treated as a return value.
  10672. #define ff_inout          bit(5)
  10673.  
  10674. # Convert foreign data to Lisp data.
  10675. # kann GC auslösen
  10676.   extern object convert_from_foreign (object fvd, void* data);
  10677.  
  10678. # Convert Lisp data to foreign data.
  10679. # The foreign data is allocated through malloc() and has more than dynamic
  10680. # extent. (Not exactly indefinite extent: It is deallocated the next time
  10681. # free_foreign() is called on it.)
  10682.   extern void convert_to_foreign_mallocing (object fvd, object obj, void* data);
  10683.  
  10684. # Convert Lisp data to foreign data.
  10685. # The foreign data storage is reused.
  10686. # DANGEROUS, especially for type C-STRING !!
  10687. # Also beware against NULL pointers! They are not treated specially.
  10688.   extern void convert_to_foreign_nomalloc (object fvd, object obj, void* data);
  10689.  
  10690. # Initialize the FFI.
  10691.   extern void init_ffi (void);
  10692. # wird verwendet von SPVW
  10693.  
  10694. # De-Initialize the FFI.
  10695.   extern void exit_ffi (void);
  10696. # wird verwendet von SPVW
  10697.  
  10698. #endif
  10699.  
  10700. # ####################### REXXBIBL zu REXX.D ############################## #
  10701.  
  10702. #ifdef REXX
  10703.  
  10704. # Initialisiert die Rexx-Schnittstelle.
  10705. # init_rexx();
  10706. # < ergebnis: Flag, ob erfolgreich initialisiert.
  10707.   extern boolean init_rexx (void);
  10708. # wird verwendet von SPVW
  10709.  
  10710. # Schließt die Rexx-Schnittstelle.
  10711. # close_rexx();
  10712.   extern void close_rexx (void);
  10713. # wird verwendet von SPVW
  10714.  
  10715. #endif
  10716.  
  10717. # ######################## GRAPHBIBL zu GRAPH.D ########################### #
  10718.  
  10719. #ifdef GRAPHICS_SWITCH
  10720.  
  10721. # Schaltet die Grafik auf Text-Modus zurück.
  10722. # switch_text_mode();
  10723.   extern void switch_text_mode (void);
  10724.  
  10725. #endif
  10726.  
  10727. # ######################################################################### #
  10728.  
  10729.