home *** CD-ROM | disk | FTP | other *** search
/ Amiga ISO Collection / AmigaUtilCD2.iso / Programming / Misc / CLISP-1.LHA / CLISP960530-sr.lha / src / spvw.d < prev    next >
Encoding:
Text File  |  1996-08-13  |  530.9 KB  |  11,882 lines
  1. # Speicherverwaltung für CLISP
  2. # Bruno Haible 22.6.1995
  3.  
  4. # Inhalt:
  5. # Modulverwaltung
  6. # Debug-Hilfen
  7. # Speichergröße
  8. # Speicherlängenbestimmung
  9. # Garbage Collection
  10. # Speicherbereitstellungsfunktionen
  11. # Zirkularitätenfeststellung
  12. # elementare Stringfunktionen
  13. # andere globale Hilfsfunktionen
  14. # Initialisierung
  15. # Speichern und Laden von MEM-Files
  16. # Fremdprogrammaufruf
  17. # Version
  18.  
  19. #include "lispbibl.c"
  20. #include "aridecl.c" # für NUM_STACK
  21. #ifdef ENABLE_NLS
  22. #ifdef STDC_HEADERS
  23. #include <string.h>
  24. #endif
  25. #endif
  26.  
  27. # In diesem File haben die Tabellenmacros eine andere Verwendung:
  28.   #undef LISPSPECFORM
  29.   #undef LISPFUN
  30.   #undef LISPSYM
  31.   #undef LISPOBJ
  32.  
  33. # Tabelle aller SUBRs: ausgelagert nach SPVWTABF
  34. # Größe dieser Tabelle:
  35.   #define subr_anz  (sizeof(subr_tab)/sizeof(subr_))
  36.  
  37. # Tabelle aller FSUBRs: ausgelagert nach CONTROL
  38. # Größe dieser Tabelle:
  39.   #define fsubr_anz  (sizeof(fsubr_tab)/sizeof(fsubr_))
  40.  
  41. # Tabelle aller Pseudofunktionen: ausgelagert nach STREAM
  42. # Größe dieser Tabelle:
  43.   #define pseudofun_anz  (sizeof(pseudofun_tab)/sizeof(Pseudofun))
  44.  
  45. # Tabelle aller festen Symbole: ausgelagert nach SPVWTABS
  46. # Größe dieser Tabelle:
  47.   #define symbol_anz  (sizeof(symbol_tab)/sizeof(symbol_))
  48.  
  49. # Tabelle aller sonstigen festen Objekte: ausgelagert nach SPVWTABO
  50. # Größe dieser Tabelle:
  51.   #define object_anz  (sizeof(object_tab)/sizeof(object))
  52.  
  53. # Durchlaufen durch subr_tab:
  54. # (NB: subr_tab_ptr_as_object(ptr) wandelt einen durchlaufenden Pointer
  55. # in ein echtes Lisp-Objekt um.)
  56.   #ifdef MAP_MEMORY_TABLES
  57.     local uintC total_subr_anz;
  58.     #define for_all_subrs(statement)  \
  59.       { var reg6 subr_* ptr = (subr_*)&subr_tab; # subr_tab durchgehen \
  60.         var reg5 uintC count;                                          \
  61.         dotimesC(count,total_subr_anz, { statement; ptr++; } );        \
  62.       }
  63.   #else
  64.     #define for_all_subrs(statement)  \
  65.       { var reg7 module_* module; # modules durchgehen                  \
  66.         for_modules(all_modules,                                        \
  67.           { var reg5 subr_* ptr = module->stab;                         \
  68.             var reg6 uintC count;                                       \
  69.             dotimesC(count,*module->stab_size, { statement; ptr++; } ); \
  70.           });                                                           \
  71.       }
  72.   #endif
  73.  
  74. # Beim Durchlaufen durch symbol_tab:
  75. # Wandelt einen durchlaufenden Pointer in ein echtes Lisp-Objekt um.
  76.   #ifdef MAP_MEMORY_TABLES
  77.     #define symbol_tab_ptr_as_object(ptr)  as_object((oint)(ptr))
  78.   #else
  79.     #define symbol_tab_ptr_as_object(ptr)  type_pointer_object(symbol_type,ptr)
  80.   #endif
  81. # Durchlaufen durch symbol_tab:
  82.   #define for_all_constsyms(statement)  \
  83.     { var reg6 symbol_* ptr = (symbol_*)&symbol_tab; # symbol_tab durchgehen \
  84.       var reg5 uintC count;                                                  \
  85.       dotimesC(count,symbol_anz, { statement; ptr++; } );                    \
  86.     }
  87.  
  88. # Durchlaufen durch object_tab:
  89.   #define for_all_constobjs(statement)  \
  90.     { var reg5 module_* module; # modules durchgehen                      \
  91.       for_modules(all_modules,                                            \
  92.         { var reg3 object* objptr = module->otab; # object_tab durchgehen \
  93.           var reg4 uintC count;                                           \
  94.           dotimesC(count,*module->otab_size, { statement; objptr++; } );  \
  95.         });                                                               \
  96.     }
  97.  
  98. # Semaphoren: decide whether an interrupt request is ignored (/= 0)
  99. # or has effect (all = 0).
  100. # Werden mit set_break_sem_x gesetzt und mit clr_break_sem_x wieder gelöscht.
  101.   global break_sems_ break_sems;
  102.   # break_sem_1 == break_sems.einzeln[0]
  103.   #   gesetzt, solange die Speicherverwaltung eine Unterbrechung verbietet
  104.   #   (damit leerer Speicher nicht von der GC durchlaufen werden kann)
  105.   # break_sem_2 == break_sems.einzeln[1]
  106.   #   für Package-Verwaltung auf unterem Niveau und Hashtable-Verwaltung
  107.   # break_sem_3 == break_sems.einzeln[2]
  108.   #   für Package-Verwaltung auf höherem Niveau
  109.   # break_sem_4 == break_sems.einzeln[3]
  110.   #   set while (AMIGADOS) DOS or external functions are being called.
  111.  
  112. # GC-Statistik:
  113.   global uintL  gc_count = 0;      # Zähler für GC-Aufrufe
  114.   global uintL2 gc_space =         # Größe des von der GC insgesamt bisher
  115.                                    # wiederbeschafften Platzes (64-Bit-Akku)
  116.     #ifdef intQsize
  117.       0
  118.     #else
  119.       {0,0}
  120.     #endif
  121.     ;
  122. # Zeit, die die GC verbraucht:
  123.   global internal_time gc_time =        # GC-Zeitverbrauch bisher insgesamt
  124.     #ifdef TIME_1
  125.     0
  126.     #endif
  127.     #ifdef TIME_2
  128.     {0,0}
  129.     #endif
  130.     ;
  131.  
  132. # ------------------------------------------------------------------------------
  133. #                          Modulverwaltung
  134.  
  135. #ifdef DYNAMIC_MODULES
  136.  
  137.   extern uintC subr_tab_data_size;
  138.   extern uintC object_tab_size;
  139.   local module_ main_module =
  140.     { "clisp",
  141.       (subr_*)&subr_tab_data, &subr_tab_data_size,
  142.       (object*)&object_tab, &object_tab_size,
  143.       TRUE, NULL, NULL, NULL, NULL,
  144.       NULL # Hier beginnt die Liste der anderen Module
  145.     };
  146.   local module_ ** last_module = &main_module.next; # zeigt aufs Ende der Liste
  147.   global uintC module_count = 0;
  148.  
  149.   global void add_module (module_ * new_module);
  150.   global void add_module(module)
  151.     var reg1 module_ * module;
  152.     { *last_module = module; last_module = &module->next;
  153.       module_count++;
  154.     }
  155.  
  156.   #define for_modules(which,statement)  \
  157.     module = (which); until (module==NULL) { statement; module = module->next; }
  158.   #define all_modules  &main_module
  159.   #define all_other_modules  main_module.next
  160.  
  161. #else
  162.  
  163.   #define main_module  modules[0]
  164.  
  165.   #define for_modules(which,statement)  \
  166.     module = (which); until (module->name==NULL) { statement; module++; }
  167.   #define all_modules  &modules[0]
  168.   #define all_other_modules  &modules[1]
  169.  
  170. #endif
  171.  
  172. # ------------------------------------------------------------------------------
  173. #                            Debug-Hilfen
  174.  
  175. # uintL in Dezimalnotation direkt übers Betriebssystem ausgeben:
  176. # dez_out(zahl)
  177.   global void dez_out_ (uintL zahl);
  178.   global void dez_out_(zahl)
  179.     var reg1 uintL zahl;
  180.     { var struct { uintB contents[10+1]; } buffer;
  181.       # 10-Byte-Buffer reicht, da zahl < 2^32 <= 10^10 .
  182.       var reg2 uintB* bufptr = &buffer.contents[10]; # Pointer in den Buffer
  183.       *bufptr = 0; # ASCIZ-String-Ende
  184.       do { *--bufptr = '0'+(zahl%10); zahl=floor(zahl,10); }
  185.          until (zahl==0);
  186.       asciz_out((char*)bufptr);
  187.     }
  188.  
  189. # uintL in Hexadezimalnotation direkt übers Betriebssystem ausgeben:
  190. # hex_out(zahl)
  191.   global void hex_out_ (unsigned long zahl);
  192.   local char hex_table[] = "0123456789ABCDEF";
  193.   global void hex_out_(zahl)
  194.     var reg1 unsigned long zahl;
  195.     { var struct { uintB contents[2*sizeof(unsigned long)+1]; } buffer;
  196.       # 8/16-Byte-Buffer reicht, da zahl < 2^32 <= 16^8 bzw. zahl < 2^64 <= 16^16 .
  197.       var reg2 uintB* bufptr = &buffer.contents[2*sizeof(unsigned long)]; # Pointer in den Buffer
  198.       *bufptr = 0; # ASCIZ-String-Ende
  199.       do { *--bufptr = hex_table[zahl%16]; zahl=floor(zahl,16); }
  200.          until (zahl==0);
  201.       asciz_out((char*)bufptr);
  202.     }
  203.  
  204. # Speicherbereich in Hexadezimalnotation direkt übers Betriebssystem ausgeben:
  205. # mem_hex_out(buf,count);
  206.   global void mem_hex_out (void* buf, uintL count);
  207.   global void mem_hex_out(buf,count)
  208.     var reg5 void* buf;
  209.     var reg3 uintL count;
  210.     { var DYNAMIC_ARRAY(reg4,cbuf,char,3*count+1);
  211.       var reg2 uintB* ptr1 = buf;
  212.       var reg1 char* ptr2 = &cbuf[0];
  213.       dotimesL(count,count,
  214.         { *ptr2++ = ' ';
  215.           *ptr2++ = hex_table[floor(*ptr1,16)]; *ptr2++ = hex_table[*ptr1 % 16];
  216.           ptr1++;
  217.         });
  218.       *ptr2 = '\0';
  219.       asciz_out(cbuf);
  220.       FREE_DYNAMIC_ARRAY(cbuf);
  221.     }
  222.  
  223. # Lisp-Objekt in Lisp-Notation relativ direkt übers Betriebssystem ausgeben:
  224. # object_out(obj);
  225. # kann GC auslösen
  226.   global void object_out (object obj);
  227.   global void object_out(obj)
  228.     var object obj;
  229.     { pushSTACK(obj);
  230.       pushSTACK(var_stream(S(terminal_io),strmflags_wr_ch_B)); # Stream *TERMINAL-IO*
  231.       prin1(&STACK_0,STACK_1); # Objekt ausgeben
  232.       terpri(&STACK_0); # Newline ausgeben
  233.       skipSTACK(2);
  234.     }
  235.  
  236. # ------------------------------------------------------------------------------
  237. #                         Schnelles Programm-Ende
  238.  
  239. # jmp_buf zur Rückkehr zum Original-Wert des SP beim Programmstart:
  240.   local jmp_buf original_context;
  241.  
  242. # LISP sofort verlassen:
  243. # quit_sofort(exitcode);
  244. # > exitcode: 0 bei normalem, 1 bei abnormalem Programmende
  245.   # Wir müssen den SP auf den ursprünglichen Wert setzen.
  246.   # (Bei manchen Betriebssystemen wird erst der vom Programm belegte
  247.   # Speicher mit free() zurückgegeben, bevor ihm die Kontrolle entzogen
  248.   # wird. Für diese kurze Zeit muß man den SP vernünftig setzen.)
  249.   local int exitcode;
  250.   #define quit_sofort(xcode)  exitcode = xcode; longjmp(&!original_context,1)
  251.  
  252. # ------------------------------------------------------------------------------
  253. #                         Speicherverwaltung allgemein
  254.  
  255. /*
  256.  
  257. Overview over CLISP's garbage collection
  258. ----------------------------------------
  259.  
  260. Knowing that most malloc() implementations are buggy and/or slow, and
  261. because CLISP needs to perform garbage collection, CLISP has its own memory
  262. management subsystem in spvw.d.
  263.  
  264. Three kinds of storage are distinguished:
  265.   * Lisp data (the "heap"), i.e. storage which contains Lisp objects and
  266.     is managed by the garbage collector.
  267.   * Lisp stack (called STACK), contains Lisp objects,
  268.   * C data (including program text, data, malloc()ed memory).
  269.  
  270. A Lisp object is one word, containing a tag (partial type information)
  271. and either immediate data (e.g. fixnums or short floats) or a pointer
  272. to storage. Pointers to C data have tag = machine_type = 0, pointers to
  273. Lisp stack have tag = system_type, most other pointers point to Lisp data.
  274.  
  275. Let's turn to these Lisp objects that consume regular Lisp memory.
  276. Every Lisp object has a size which is determined when the object is
  277. allocated (using one of the allocate_... routines). The size can be
  278. computed from the type tag and - if necessary - the length field of
  279. the object's header. The length field always contains the number of
  280. elements of the object. The number of bytes is given by the function
  281. speicher_laenge().
  282.  
  283. Lisp objects which contain exactly 2 Lisp objects (i.e. conses, complex
  284. numbers, ratios) are stored in a separate area and occupy 2 words each.
  285. All other Lisp objects have "varying length" (well, more precisely,
  286. not a fixed length) and include a word for garbage collection purposes
  287. at their beginning.
  288.  
  289. The garbage collector is invoked when an allocate_...() request
  290. cannot be fulfilled. It marks all objects which are "live" (may be
  291. reached from the "roots"), compacts these objects and unmarks them.
  292. Non-live objects are lost; their storage is reclaimed.
  293.  
  294. 2-pointer objects are compacted by a simple hole-filling algorithm:
  295. fill the most-left object into the most-right hole, and so on, until
  296. the objects are contiguous at the right and the hole is contiguous at the
  297. left.
  298.  
  299. Variable-length objects are compacted by sliding them down (their address
  300. decreases).
  301.  
  302. There are 5 memory models. Which one is used, depends on the operating system.
  303.  
  304. SPVW_MIXED_BLOCKS_OPPOSITE: The heap consists of one block of fixed length
  305. (allocated at startup). The variable-length objects are allocated from
  306. the left, the 2-pointer objects are allocated from the right. There is a
  307. hole between them. When the hole shrinks to 0, GC is invoked. GC slides
  308. the variable-length objects to the left and concentrates the 2-pointer
  309. objects at the right end of the block again.
  310. When no more room is available, some reserve area beyond the right end
  311. of the block is halved, and the 2-pointer objects are moved to the right
  312. accordingly.
  313. (+) Simple management.
  314. (+) No fragmentation at all.
  315. (-) The total heap size is limited.
  316.  
  317. SPVW_MIXED_BLOCKS && TRIVIALMAP_MEMORY: The heap consists of two big blocks,
  318. one for variable-length objects and one for 2-pointer objects. Both have a
  319. hole to the right, but are extensible to the right.
  320. (+) Total heap size grows depending on the application's needs.
  321. (+) No fragmentation at all.
  322. (*) Works only when SINGLEMAP_MEMORY were possible as well.
  323.  
  324. SPVW_MIXED_PAGES: The heap consists of many small pages (usually around
  325. 8 KB). There are two kinds of pages: one for 2-pointer objects, one for
  326. variable-length objects. The set of all pages of a fixed kind is called
  327. a "Heap". Each page has its hole (free space) at its end. For every heap,
  328. the pages are kept sorted according to the size of their hole, using AVL
  329. trees. Garbage collection is invoked when the used space has grown by
  330. 25% since the last GC; until that point new pages are allocated from
  331. the operating system. The GC compacts the data in each page separately:
  332. data is moved to the left. Emptied pages are given back to the OS.
  333. If the holes then make up more than 25% of the occupied storage, a second
  334. GC turn moves objects across pages, from nearly empty ones to nearly full
  335. ones, with the aim to free as most pages as possible.
  336.  
  337. (-) every allocation requires AVL tree operations -> slower
  338. (+) Total heap size grows depending on the application's needs.
  339. (+) Works on operating systems which don't provide large contiguous areas.
  340.  
  341. SPVW_PURE_PAGES: Just like SPVW_MIXED_PAGES, except that every page contains
  342. data of only a single type tag, i.e. there is a Heap for every type tag.
  343.  
  344. (-) every allocation requires AVL tree operations -> slower
  345. (+) Total heap size grows depending on the application's needs.
  346. (+) Works on operating systems which don't provide large contiguous areas.
  347. (-) More fragmentation because objects of different type never fit into
  348.     the same page.
  349.  
  350. SPVW_PURE_BLOCKS: There is a big block of storage for each type tag.
  351. Each of these blocks has its data to the left and the hole to the right,
  352. but these blocks are extensible to the right (because there's enough room
  353. between them). A garbage collection is triggered when the allocation amount
  354. since the last GC reaches 50% of the amount of used space at the last GC,
  355. but at least 512 KB. The garbage collection cleans up each block separately:
  356. data is moved left.
  357.  
  358. (+) Total heap size grows depending on the application's needs.
  359. (+) No 16 MB total size limit.
  360. (*) Works only in combination with SINGLEMAP_MEMORY.
  361.  
  362.  
  363. The following combinations of memory model and mmap tricks are possible:
  364.  
  365.                        GENERATIONAL_GC -------------+
  366.                                                      \
  367.                     MULTIMAP_MEMORY -------------+    \
  368.                   SINGLEMAP_MEMORY -----------+   \    \
  369.                 TRIVIALMAP_MEMORY -------- +   \   \    \
  370.                no MAP_MEMORY -----------+   \   \   \    \
  371.                                          \   \   \   \    \
  372. SPVW_MIXED_BLOCKS_OPPOSITE              | X |   |   | X | X |
  373. SPVW_MIXED_BLOCKS && TRIVIALMAP_MEMORY  |   | X |   |   | X |
  374. SPVW_PURE_BLOCKS                        |   |   | X |   | X |
  375. SPVW_MIXED_PAGES                        | X |   |   |   |   |
  376. SPVW_PURE_PAGES                         | X |   |   |   |   |
  377.  
  378. Historically, the different memory models were developed in the following
  379. order (1 = first, ...):
  380. SPVW_MIXED_BLOCKS_OPPOSITE              | 1 |   |   | 2 | 9 |
  381. SPVW_MIXED_BLOCKS && TRIVIALMAP_MEMORY  |   | 7 |   |   | 8 |
  382. SPVW_PURE_BLOCKS                        |   |   | 5 |   | 6 |
  383. SPVW_MIXED_PAGES                        | 3 |   |   |   |   |
  384. SPVW_PURE_PAGES                         | 4 |   |   |   |   |
  385.  
  386.  
  387. The burden of GC upon the rest of CLISP:
  388.  
  389. Every subroutine marked with "kann GC auslösen" may invoke GC. GC moves
  390. all the Lisp objects and updates the pointers. But the GC looks only
  391. on the STACK and not in the C variables. (Anything else wouldn't be portable.)
  392. Therefore at every "unsafe" point - i.e. every call to such a subroutine -
  393. all the C variables of type `object' MUST BE ASSUMED TO BECOME GARBAGE.
  394. (Except for `object's that are known to be unmovable, e.g. immediate data
  395. or Subrs.) Pointers inside Lisp data (e.g. to the characters of a string or
  396. to the elements of a simple-vector) become INVALID as well.
  397.  
  398. The workaround is usually to allocate all the needed Lisp data first and
  399. do the rest of the computation with C variables, without calling unsafe
  400. routines, and without worrying about GC.
  401.  
  402.  
  403. Foreign Pointers
  404. ----------------
  405.  
  406. Pointers to C functions and to malloc()ed data can be hidden in Lisp
  407. objects of type machine_type; GC will not modify its value. But one should
  408. not dare to assume that a C stack pointer or the address of a C function
  409. in a shared library fulfills the same requirements.
  410.  
  411. If another pointer is to be viewed as a Lisp object, it is best to box it,
  412. e.g. in a simple-bit-vector or in an Fpointer. (See allocate_fpointer().)
  413.  
  414. */
  415.  
  416.  
  417. # Methode der Speicherverwaltung:
  418. #if defined(SPVW_BLOCKS) && defined(SPVW_MIXED)
  419.   #define SPVW_MIXED_BLOCKS
  420.   #if !defined(TRIVIALMAP_MEMORY)
  421.     # Blocks grow like this:       |******-->     <--****|
  422.     #define SPVW_MIXED_BLOCKS_OPPOSITE
  423.   #else # defined(TRIVIALMAP_MEMORY)
  424.     # Blocks grow like this:       |******-->      |***-->
  425.   #endif
  426. #endif
  427. #if defined(SPVW_BLOCKS) && defined(SPVW_PURE) # z.B. UNIX_LINUX ab Linux 0.99.7
  428.   #define SPVW_PURE_BLOCKS
  429. #endif
  430. #if defined(SPVW_PAGES) && defined(SPVW_MIXED) # z.B. SUN3, AMIGA, HP9000_800
  431.   #define SPVW_MIXED_PAGES
  432. #endif
  433. #if defined(SPVW_PAGES) && defined(SPVW_PURE) # z.B. SUN4, SUN386
  434.   #define SPVW_PURE_PAGES
  435. #endif
  436.  
  437. # Gesamtspeicheraufteilung:
  438. # 1. C-Programm. Speicher wird vom Betriebssystem zugeteilt.
  439. #    Nach Programmstart unverschieblich.
  440. # 2. C-Stack. Speicher wird vom C-Programm geholt.
  441. #    Unverschieblich.
  442. # 3. C-Heap. Hier unbenutzt.
  443. #ifdef SPVW_MIXED_BLOCKS
  444. # 4. LISP-Stack und LISP-Daten.
  445. #    4a. LISP-Stack. Unverschieblich.
  446. #    4b. Objekte variabler Länge. (Unverschieblich).
  447. #    4c. Conses u.ä. Verschieblich mit move_conses.
  448. #    Speicher hierfür wird vom Betriebssystem angefordert (hat den Vorteil,
  449. #    daß bei EXECUTE dem auszuführenden Fremdprogramm der ganze Speicher
  450. #    zur Verfügung gestellt werden kann, den LISP gerade nicht braucht).
  451. #    Auf eine Unterteilung in einzelne Pages wird hier verzichtet.
  452. #          || LISP-      |Objekte         |    leer  |Conses| Reserve |
  453. #          || Stack      |variabler Länge              u.ä. |         |
  454. #          |STACK_BOUND  |         objects.end   conses.start |         |
  455. #        MEMBOT   objects.start                         conses.end    MEMTOP
  456. #endif
  457. #ifdef SPVW_PURE_BLOCKS
  458. # 4. LISP-Stack. Unverschieblich.
  459. # 5. LISP-Daten. Für jeden Typ ein großer Block von Objekten.
  460. #endif
  461. #ifdef SPVW_MIXED_PAGES
  462. # 4. LISP-Stack. Unverschieblich.
  463. # 5. LISP-Daten.
  464. #    Unterteilt in Pages für Objekte variabler Länge und Pages für Conses u.ä.
  465. #endif
  466. #ifdef SPVW_PURE_PAGES
  467. # 4. LISP-Stack. Unverschieblich.
  468. # 5. LISP-Daten. Unterteilt in Pages, die nur Objekte desselben Typs enthalten.
  469. #endif
  470.  
  471. # Kanonische Adressen:
  472. # Bei MULTIMAP_MEMORY kann man über verschiedene Pointer auf dieselbe Speicher-
  473. # stelle zugreifen. Die Verwaltung der Heaps benötigt einen "kanonischen"
  474. # Pointer. Über diesen kann zugegriffen werden, und er kann mit >=, <=
  475. # verglichen werden. heap_start und heap_end sind kanonische Adressen.
  476.   #ifdef MULTIMAP_MEMORY
  477.     #define canonaddr(obj)  upointer(obj)
  478.     #define canon(address)  ((address) & oint_addr_mask)
  479.   #else
  480.     #define canonaddr(obj)  (aint)ThePointer(obj)
  481.     #define canon(address)  (address)
  482.   #endif
  483.   # Es gilt canonaddr(obj) == canon((aint)ThePointer(obj)).
  484.  
  485. # ------------------------------------------------------------------------------
  486. #                          Eigenes malloc(), free()
  487.  
  488. #ifdef AMIGAOS
  489.  
  490. # Eigenes malloc(), free() nötig wegen Resource Tracking.
  491.  
  492.   # Flag, das anzeigt, ob der Prozessor ein 68000 ist.
  493.   local boolean cpu_is_68000;
  494.   #if defined(MC68000)
  495.     #define CPU_IS_68000  TRUE
  496.   #elif defined(MC680Y0)
  497.     #define CPU_IS_68000  FALSE
  498.   #else
  499.     #define CPU_IS_68000  cpu_is_68000
  500.   #endif
  501.  
  502.   # Flag für AllocMem().
  503.   #define default_allocmemflag  MEMF_ANY
  504.   #if !(defined(WIDE) || defined(MC68000))
  505.     # Es kann sein, daß wir mit MEMF_ANY Speicher außerhalb des
  506.     # 24/26-Bit-Adreßraums bekommen, den wir nicht nutzen können.
  507.     # Dann versuchen wir's nochmal.
  508.     local uintL retry_allocmemflag;  # wird in init_amiga() gesetzt.
  509.   #endif
  510.  
  511.   # Doppelt verkettete Liste aller bisher belegten Speicherblöcke führen:
  512.   typedef struct MemBlockHeader { struct MemBlockHeader * next;
  513.                                   #ifdef SPVW_PAGES
  514.                                   struct MemBlockHeader * * prev;
  515.                                   #endif
  516.                                   uintL size;
  517.                                   oint usable_memory[unspecified]; # "oint" erzwingt Alignment
  518.                                 }
  519.           MemBlockHeader;
  520.   local MemBlockHeader* allocmemblocks = NULL;
  521.   #ifdef SPVW_PAGES
  522.   # Für alle p = allocmemblocks{->next}^n (n=0,1,...) mit !(p==NULL) gilt
  523.   # *(p->prev) = p.
  524.   #endif
  525.  
  526.   # Speicher vom Betriebssystem holen:
  527.   local void* allocmem (uintL amount, uintL allocmemflag);
  528.   local void* allocmem(amount,allocmemflag)
  529.     var reg2 uintL amount;
  530.     var reg3 uintL allocmemflag;
  531.     { amount = round_up(amount+offsetofa(MemBlockHeader,usable_memory),4);
  532.      {var reg1 void* address = AllocMem(amount,allocmemflag);
  533.       if (!(address==NULL))
  534.         { ((MemBlockHeader*)address)->size = amount;
  535.           ((MemBlockHeader*)address)->next = allocmemblocks;
  536.           #ifdef SPVW_PAGES
  537.           ((MemBlockHeader*)address)->prev = &allocmemblocks;
  538.           if (!(allocmemblocks == NULL))
  539.             { if (allocmemblocks->prev == &allocmemblocks) # Sicherheits-Check
  540.                 { allocmemblocks->prev = &((MemBlockHeader*)address)->next; }
  541.                 else
  542.                 { abort(); }
  543.             }
  544.           #endif
  545.           allocmemblocks = (MemBlockHeader*)address;
  546.           address = &((MemBlockHeader*)address)->usable_memory[0];
  547.         }
  548.       return address;
  549.     }}
  550.  
  551.   # Speicher dem Betriebssystem zurückgeben:
  552.   local void freemem (void* address);
  553.   local void freemem(address)
  554.     var reg2 void* address;
  555.     { var reg1 MemBlockHeader* ptr = (MemBlockHeader*)((aint)address - offsetofa(MemBlockHeader,usable_memory));
  556.       #ifdef SPVW_PAGES
  557.       if (*(ptr->prev) == ptr) # Sicherheits-Check
  558.         { var reg2 MemBlockHeader* ptrnext = ptr->next;
  559.           *(ptr->prev) = ptrnext; # ptr durch ptr->next ersetzen
  560.           if (!(ptrnext == NULL)) { ptrnext->prev = ptr->prev; }
  561.           FreeMem(ptr,ptr->size);
  562.           return;
  563.         }
  564.       #else
  565.       # Spar-Implementation, die nur in der Lage ist, den letzten allozierten
  566.       # Block zurückzugeben:
  567.       if (allocmem == ptr) # Sicherheits-Check
  568.         { allocmem = ptr->next; # ptr durch ptr->next ersetzen
  569.           FreeMem(ptr,ptr->size);
  570.           return;
  571.         }
  572.       #endif
  573.         else
  574.         { abort(); }
  575.     }
  576.  
  577.   #define malloc(amount)  allocmem(amount,default_allocmemflag)
  578.   #define free  freemem
  579.  
  580. #endif
  581.  
  582. #ifdef NEED_MALLOCA
  583.  
  584. # Eigener alloca()-Ersatz.
  585. # ptr = malloca(size) liefert einen Speicherblock gegebener Größe. Er kann
  586. # (muß aber nicht) mit freea(ptr) freigegeben werden.
  587. # freea(ptr) gibt alle seit der Allozierung von ptr per malloca()
  588. # gelieferten Speicherblöcke zurück, einschließlich ptr selbst.
  589.  
  590. # Die so allozierten Speicherblöcke bilden eine verkettete Liste.
  591. typedef struct malloca_header
  592.                { struct malloca_header * next;
  593.                  oint usable_memory[unspecified]; # "oint" erzwingt Alignment
  594.                }
  595.         malloca_header;
  596.  
  597. # Verkettete Liste der Speicherblöcke, der jüngste ganz vorn, der älteste
  598. # ganz hinten.
  599.   local malloca_header* malloca_list = NULL;
  600.  
  601. # malloca(size) liefert einen Speicherblock der Größe size.
  602.   global void* malloca (size_t size);
  603.   global void* malloca(size)
  604.     var reg2 size_t size;
  605.     { var reg1 malloca_header* ptr = (malloca_header*)malloc(offsetofa(malloca_header,usable_memory) + size);
  606.       if (!(ptr == NULL))
  607.         { ptr->next = malloca_list;
  608.           malloca_list = ptr;
  609.           return &ptr->usable_memory;
  610.         }
  611.         else
  612.         {
  613.           #ifdef VIRTUAL_MEMORY
  614.           //: DEUTSCH "Kein virtueller Speicher mehr verfügbar: RESET" 
  615.           //: ENGLISH "Virtual memory exhausted. RESET"
  616.           //: FRANCAIS "La mémoire virtuelle est épuisée : RAZ" 
  617.           err_asciz_out(GETTEXT("out of virtual memory"));
  618.           #else
  619.           //: DEUTSCH "Speicher voll: RESET" 
  620.           //: ENGLISH "Memory exhausted. RESET"
  621.           //: FRANCAIS "La mémoire est épuisée : RAZ"
  622.           err_asciz_out(GETTEXT("out of memory"));
  623.           #endif
  624.           reset();
  625.     }   }
  626.  
  627. # freea(ptr) gibt den Speicherblock ab ptr und alle jüngeren frei.
  628.   global void freea (void* ptr);
  629.   global void freea(address)
  630.     var reg4 void* address;
  631.     { var reg3 malloca_header* ptr = (malloca_header*)
  632.         ((aint)address - offsetofa(malloca_header,usable_memory));
  633.       var reg1 malloca_header* p = malloca_list;
  634.       loop
  635.         { var reg2 malloca_header* n = p->next;
  636.           free(p);
  637.           if (!(p == ptr))
  638.             { p = n; }
  639.             else
  640.             { malloca_list = n; break; }
  641.         }
  642.     }
  643.  
  644. #endif # NEED_MALLOCA
  645.  
  646. # ------------------------------------------------------------------------------
  647. #                          Page-Allozierung
  648.  
  649. # Anzahl der möglichen Typcodes überhaupt.
  650.   #define typecount  bit(oint_type_len<=8 ? oint_type_len : 8)
  651.  
  652. #ifdef MULTIMAP_MEMORY
  653.  
  654. # Das Betriebssystem erlaubt es, denselben (virtuellen) Speicher unter
  655. # verschiedenen Adressen anzusprechen.
  656. # Dabei gibt es allerdings Restriktionen:
  657. # - Die Adressenabbildung kann nur für ganze Speicherseiten auf einmal
  658. #   erstellt werden.
  659. # - Wir brauchen zwar nur diesen Adreßraum und nicht seinen Inhalt, müssen
  660. #   ihn aber mallozieren und dürfen ihn nicht freigeben, da er in unserer
  661. #   Kontrolle bleiben soll.
  662.  
  663. # Länge einer Speicherseite des Betriebssystems:
  664.   local /* uintL */ aint map_pagesize; # wird eine Zweierpotenz sein, meist 4096.
  665.  
  666. # Initialisierung:
  667. # initmap() bzw. initmap(tmpdir)
  668.  
  669. # In einen Speicherbereich [map_addr,map_addr+map_len-1] leere Seiten legen:
  670. # (map_addr und map_len durch map_pagesize teilbar.)
  671. # zeromap(map_addr,map_len)
  672.  
  673. # Auf einen Speicherbereich [map_addr,map_addr+map_len-1] Seiten legen,
  674. # die unter den Typcodes, die in typecases angegeben sind, ansprechbar
  675. # sein sollen:
  676. # multimap(typecases,imm_typecases,imm_flag,map_addr,map_len,save_flag);
  677.  
  678. # Alle immutablen Objekte mutabel machen:
  679. # immutable_off();
  680.  
  681. # Alle immutablen Objekte wieder immutabel machen:
  682. # immutable_on();
  683.  
  684. # Beendigung:
  685. # exitmap();
  686.  
  687. # Diese Typen kennzeichnen Objekte mit !immediate_type_p(type):
  688.   #define MM_TYPECASES  \
  689.     case_array: case_record: case_system: \
  690.     case_bignum: case_ratio: case_ffloat: case_dfloat: case_lfloat: case_complex: \
  691.     case_symbolflagged: case_cons:
  692.  
  693. # Diese Typen kennzeichnen immutable Objekte:
  694.   #ifdef IMMUTABLE
  695.     #ifdef IMMUTABLE_CONS
  696.       #define IMM_TYPECASES_1  case imm_cons_type:
  697.     #else
  698.       #define IMM_TYPECASES_1
  699.     #endif
  700.     #ifdef IMMUTABLE_ARRAY
  701.       #define IMM_TYPECASES_2  \
  702.         case imm_sbvector_type: case imm_sstring_type: case imm_svector_type: case imm_array_type: \
  703.         case imm_bvector_type: case imm_string_type: case imm_vector_type:
  704.     #else
  705.       #define IMM_TYPECASES_2
  706.     #endif
  707.     #define IMM_TYPECASES  IMM_TYPECASES_1 IMM_TYPECASES_2
  708.     local tint imm_types[] =
  709.       {
  710.         #ifdef IMMUTABLE_CONS
  711.         imm_cons_type,
  712.         #endif
  713.         #ifdef IMMUTABLE_ARRAY
  714.         imm_sbvector_type,
  715.         imm_sstring_type,
  716.         imm_svector_type,
  717.         imm_array_type,
  718.         imm_bvector_type,
  719.         imm_string_type,
  720.         imm_vector_type,
  721.         #endif
  722.       };
  723.     #define imm_types_count  (sizeof(imm_types)/sizeof(tint))
  724.     # Fehlermeldung:
  725.       nonreturning_function(local, fehler_immutable, (void));
  726.       local void fehler_immutable()
  727.         { 
  728.           //: DEUTSCH "Versuch der Modifikation unveränderlicher Daten."
  729.           //: ENGLISH "Attempt to modify read-only data"
  730.           //: FRANCAIS "Tentative de modification d'un objet non modifiable."
  731.           fehler(error,GETTEXT("modify of read-only data"));
  732.         }
  733.   #else
  734.     #define IMM_TYPECASES
  735.     #define fehler_immutable()
  736.   #endif
  737.  
  738. #if defined(IMMUTABLE) && !defined(GENERATIONAL_GC)
  739.   nonreturning_function(local, fehler_cannot_remap_immutable_objects_read_only, (void));
  740.   local void fehler_cannot_remap_immutable_objects_read_only ()
  741.     {
  742.       //: DEUTSCH ""
  743.       //: ENGLISH "Cannot remap immutable objects read-only."
  744.       //: FRANCAIS ""
  745.       asciz_out(GETTEXT("Cannot remap immutable objects read-only."));
  746.       errno_out(errno);
  747.       quit_sofort(1);
  748.     }
  749.  
  750.   nonreturning_function(local, fehler_cannot_remap_immutable_objects_read_write, (void));
  751.   local void fehler_cannot_remap_immutable_objects_read_write ()
  752.     { 
  753.       //: DEUTSCH ""
  754.       //: ENGLISH "Cannot remap immutable objects read/write."
  755.       //: FRANCAIS ""
  756.       asciz_out(GETTEXT("Cannot remap immutable objects read/write."));
  757.       errno_out(errno);
  758.       quit_sofort(1);
  759.     }
  760. #endif
  761.  
  762. #ifdef MULTIMAP_MEMORY_VIA_FILE
  763.  
  764.   # Debug level for tempfile: 0 = remove file immediately
  765.   #                           1 = filename depends on process id
  766.   #                           2 = reuse file next time
  767.   #define TEMPFILE_DEBUG_LEVEL  0
  768.  
  769.   local char tempfilename[MAXPATHLEN]; # Name eines temporären Files
  770.   local int zero_fd; # Handle von /dev/zero
  771.   # Zugriff auf /dev/zero: /dev/zero hat manchmal Permissions 0644. Daher
  772.   # OPEN() mit nur O_RDONLY statt O_RDWR. Daher MAP_PRIVATE statt MAP_SHARED.
  773.  
  774.   local int initmap (char* tmpdir);
  775.   local int initmap(tmpdir)
  776.     var reg3 char* tmpdir;
  777.     # Virtual Memory Mapping aufbauen:
  778.     { # Wir brauchen ein temporäres File.
  779.       # tempfilename := (string-concat tmpdir "/" "lisptemp.mem")
  780.       {var reg1 char* ptr1 = tmpdir;
  781.        var reg2 char* ptr2 = &tempfilename[0];
  782.        while (!(*ptr1 == '\0')) { *ptr2++ = *ptr1++; }
  783.        if (!((ptr2 > &tempfilename[0]) && (ptr2[-1] == '/')))
  784.          { *ptr2++ = '/'; }
  785.        ptr1 = "lisptemp.mem";
  786.        while (!(*ptr1 == '\0')) { *ptr2++ = *ptr1++; }
  787.        #if (TEMPFILE_DEBUG_LEVEL > 0)
  788.        *ptr2++ = '.';
  789.        #if (TEMPFILE_DEBUG_LEVEL == 1)
  790.        { unsigned int pid = getpid();
  791.          *ptr2++ = ((pid >> 12) & 0x0f) + 'a';
  792.          *ptr2++ = ((pid >> 8) & 0x0f) + 'a';
  793.          *ptr2++ = ((pid >> 4) & 0x0f) + 'a';
  794.          *ptr2++ = (pid & 0x0f) + 'a';
  795.        }
  796.        #endif
  797.        *ptr2++ = '0';
  798.        #endif
  799.        *ptr2 = '\0';
  800.       }
  801.       { var reg1 int fd = OPEN("/dev/zero",O_RDONLY,my_open_mask);
  802.         if (fd<0)
  803.           { 
  804.             //: DEUTSCH "Kann /dev/zero nicht öffnen." 
  805.             //: ENGLISH "Cannot open /dev/zero ."
  806.             //: FRANCAIS "Ne peux pas ouvrir /dev/zero ." 
  807.             asciz_out(GETTEXT("cannot open /dev/zero"));
  808.             errno_out(errno);
  809.             return -1; # error
  810.           }
  811.         zero_fd = fd;
  812.       }
  813.       return 0;
  814.     }
  815.  
  816.   #ifdef HAVE_MSYNC
  817.     typedef struct { void* mm_addr; uintL mm_len; } mmap_interval;
  818.     local mmap_interval mmap_intervals[256]; # 256 ist reichlich.
  819.     local mmap_interval* mmap_intervals_ptr = &mmap_intervals[0];
  820.     local void msync_mmap_intervals (void);
  821.     local void msync_mmap_intervals()
  822.       { var reg1 mmap_interval* ptr = &mmap_intervals[0];
  823.         until (ptr==mmap_intervals_ptr)
  824.           { if (msync((MMAP_ADDR_T)ptr->mm_addr,ptr->mm_len,MS_INVALIDATE) < 0)
  825.               { asciz_out("msync(0x"); hex_out(ptr->mm_addr); asciz_out(",0x");
  826.                 hex_out(ptr->mm_len); asciz_out(",MS_INVALIDATE)");
  827.                 asciz_out(DEUTSCH ? " scheitert." :
  828.                           ENGLISH ? " fails." :
  829.                           FRANCAIS ? " - erreur." :
  830.                           ""
  831.                          );
  832.                 errno_out(errno);
  833.               }
  834.             ptr++;
  835.       }   }
  836.   #else
  837.      #define msync_mmap_intervals()
  838.   #endif
  839.  
  840.   local int fdmap (int fd, void* map_addr, uintL map_len, int readonly, int shared);
  841.   local int fdmap(fd,map_addr,map_len,readonly,shared)
  842.     var reg3 int fd;
  843.     var reg1 void* map_addr;
  844.     var reg2 uintL map_len;
  845.     var reg4 int readonly;
  846.     var reg5 int shared;
  847.     { if ( (void*) mmap(map_addr, # gewünschte Adresse
  848.                         map_len, # Länge
  849.                         readonly ? PROT_READ : PROT_READ | PROT_WRITE, # Zugriffsrechte
  850.                         (shared ? MAP_SHARED : 0) | MAP_FIXED, # genau an diese Adresse!
  851.                         fd, 0 # File ab Position 0 legen
  852.                        )
  853.            == (void*)(-1)
  854.          )
  855.         { 
  856.           //: DEUTSCH "Kann keinen Speicher an Adresse 0x" 
  857.           //: ENGLISH "Cannot map memory to address 0x"
  858.           //: FRANCAIS "Ne peux pas placer de la mémoire à l'adresse 0x" 
  859.           asciz_out(GETTEXT("cannot map memory to address 0x"));
  860.           hex_out(map_addr);
  861.           //: DEUTSCH " legen."
  862.           //: ENGLISH " ." 
  863.           //: FRANCAIS " ."
  864.           asciz_out(GETTEXT("[end]cannot map to address 0x"));
  865.           errno_out(errno);
  866.           return -1; # error
  867.         }
  868.       #ifdef HAVE_MSYNC
  869.       mmap_intervals_ptr->mm_addr = map_addr; mmap_intervals_ptr->mm_len = map_len;
  870.       mmap_intervals_ptr++;
  871.       #endif
  872.       return 0;
  873.     }
  874.  
  875.   local int zeromap (void* map_addr, uintL map_len);
  876.   local int zeromap(map_addr,map_len)
  877.     var reg1 void* map_addr;
  878.     var reg2 uintL map_len;
  879.     { return fdmap(zero_fd,map_addr,map_len,FALSE,FALSE); }
  880.  
  881.   local int open_temp_fd (uintL map_len);
  882.   local int open_temp_fd(map_len)
  883.     var reg2 uintL map_len;
  884.     { var reg1 int fd;
  885.       #if (TEMPFILE_DEBUG_LEVEL > 0)
  886.       tempfilename[strlen(tempfilename)-1]++;
  887.       #endif
  888.       #if (TEMPFILE_DEBUG_LEVEL <= 1)
  889.       fd = OPEN(tempfilename,O_RDWR|O_CREAT|O_TRUNC|O_EXCL,my_open_mask);
  890.       #else
  891.       fd = OPEN(tempfilename,O_RDWR|O_CREAT,my_open_mask);
  892.       #endif
  893.       if (fd<0)
  894.         {
  895.           //: DEUTSCH "Kann "
  896.           //: ENGLISH "Cannot open " 
  897.           //: FRANCAIS "Ne peux pas ouvrir "
  898.           asciz_out(GETTEXT("cannot open"));
  899.           asciz_out(tempfilename);
  900.  
  901.           //: DEUTSCH " nicht öffnen."
  902.           //: ENGLISH " ."
  903.           //: FRANCAIS " ."
  904.           asciz_out(GETTEXT("[end]cannot open"));
  905.           errno_out(errno);
  906.           return -1; # error
  907.         }
  908.       #if (TEMPFILE_DEBUG_LEVEL == 0)
  909.       # und öffentlich unzugänglich machen, indem wir es löschen:
  910.       # (Das Betriebssystem löscht das File erst dann, wenn am Ende dieses
  911.       # Prozesses in _exit() ein close(fd) durchgeführt wird.)
  912.       if ( unlink(tempfilename) <0)
  913.         { 
  914.           //: DEUTSCH "Kann "
  915.           //: ENGLISH "Cannot delete "
  916.           //: FRANCAIS "Ne peux pas effacer "
  917.           asciz_out(GETTEXT("cannot delete"));
  918.           asciz_out(tempfilename);
  919.           //: DEUTSCH " nicht löschen."
  920.           //: ENGLISH " ."
  921.           //: FRANCAIS " ."
  922.           asciz_out(GETTEXT("[end]cannot delete"));
  923.           errno_out(errno);
  924.           return -1; # error
  925.         }
  926.       #endif
  927.       # überprüfen, ob genug Plattenplatz da ist:
  928.       { var struct statfs statbuf;
  929.         if (!( fstatfs(fd,&statbuf) <0))
  930.           if (!(statbuf.f_bsize == (long)(-1)) && !(statbuf.f_bavail == (long)(-1)))
  931.             { var reg2 uintL available = (uintL)(statbuf.f_bsize) * (uintL)(statbuf.f_bavail);
  932.               if (available < map_len)
  933.                 # auf der Platte ist voraussichtlich zu wenig Platz
  934.                 { 
  935.                   //: DEUTSCH "** WARNUNG: ** Zu wenig freier Plattenplatz für "
  936.                   //: ENGLISH "** WARNING: ** Not enough free disk space for "
  937.                   //: FRANCAIS "** AVERTISSEMENT : ** Trop peu de place disque restante sur "
  938.                   asciz_out(GETTEXT("out of disk space"));
  939.                   asciz_out(tempfilename);
  940.                   //: DEUTSCH  " ."
  941.                   //: ENGLISH  " ."
  942.                   //: FRANCAIS " ."
  943.                   asciz_out(GETTEXT("[end]out of disk space"));
  944.                   asciz_out(CRLFstring);
  945.                   //: DEUTSCH "Bitte LISP mit weniger Speicher (Option -m) neu starten."
  946.                   //: ENGLISH "Please restart LISP with less memory (option -m)."
  947.                   //: FRANCAIS "Prière de relancer LISP avec moins de mémoire (option -m)."
  948.                   asciz_out(GETTEXT("restart with less memory"));
  949.                   asciz_out(CRLFstring);
  950.       }     }   }
  951.       # Auf Größe map_len aufblähen:
  952.       { var uintB dummy = 0;
  953.         if (( lseek(fd,map_len-1,SEEK_SET) <0) || (!( full_write(fd,&dummy,1) ==1)))
  954.           { 
  955.             //: DEUTSCH "Kann "
  956.             //: ENGLISH "Cannot make "
  957.             //: FRANCAIS "Ne peux pas agrandir "
  958.             asciz_out(GETTEXT("cannot make file long enough"));
  959.             asciz_out(tempfilename);
  960.             //: DEUTSCH " nicht aufblähen." 
  961.             //: ENGLISH " long enough." 
  962.             //: FRANCAIS " ." 
  963.             asciz_out(GETTEXT("[end]cannot make file long enough"));
  964.             errno_out(errno);
  965.             return -1; # error
  966.       }   }
  967.       return fd;
  968.     }
  969.  
  970.   #if !defined(MAP_MEMORY_TABLES)
  971.     # Kopiert den Inhalt des Intervalls [map_addr..map_addr+map_len-1] ins File.
  972.     local int fdsave (int fd, void* map_addr, uintL map_len);
  973.     local int fdsave(fd,map_addr,map_len)
  974.       var reg2 int fd;
  975.       var reg3 void* map_addr;
  976.       var reg4 uintL map_len;
  977.       { if (( lseek(fd,0,SEEK_SET) <0) || (!( full_write(fd,map_addr,map_len) == map_len)))
  978.           { 
  979.             //: DEUTSCH "Kann "
  980.             //: ENGLISH "Cannot fill "
  981.             //: FRANCAIS "Ne peux pas remplir "
  982.             asciz_out(GETTEXT("cannot fill file"));
  983.             asciz_out(tempfilename);
  984.             //: DEUTSCH " nicht füllen."
  985.             //: ENGLISH " ."
  986.             //: FRANCAIS " ."
  987.             asciz_out(GETTEXT("[end]cannot fill file"));
  988.             errno_out(errno);
  989.             return -1; # error
  990.           }
  991.         return 0;
  992.       }
  993.   #else
  994.     #define fdsave(fd,map_addr,map_len)  0
  995.   #endif
  996.  
  997.   local int close_temp_fd (int fd);
  998.   local int close_temp_fd(fd)
  999.     var reg1 int fd;
  1000.     { if ( CLOSE(fd) <0)
  1001.         {
  1002.           //: DEUTSCH "Kann " 
  1003.           //: ENGLISH "Cannot close " 
  1004.           //: FRANCAIS "Ne peux pas fermer " 
  1005.           asciz_out(GETTEXT("cannot close"));
  1006.           asciz_out(tempfilename);
  1007.           //: DEUTSCH " nicht schließen."
  1008.           //: ENGLISH " ."
  1009.           //: FRANCAIS " ."
  1010.           asciz_out(GETTEXT("[end]cannot close"));
  1011.           errno_out(errno);
  1012.           return -1; # error
  1013.         }
  1014.       return 0;
  1015.     }
  1016.  
  1017.   # Vorgehen bei multimap:
  1018.   # 1. Temporäres File aufmachen
  1019.     #define open_mapid(map_len)  open_temp_fd(map_len) # -> fd
  1020.   # 2. File mehrfach überlagert in den Speicher legen
  1021.     #define map_mapid(fd,map_addr,map_len,readonly)  fdmap(fd,map_addr,map_len,readonly,TRUE)
  1022.   # 3. File schließen
  1023.   # (Das Betriebssystem schließt und löscht das File erst dann, wenn am
  1024.   # Ende dieses Prozesses in _exit() ein munmap() durchgeführt wird.)
  1025.     #define close_mapid(fd)  close_temp_fd(fd)
  1026.  
  1027.   #ifndef IMMUTABLE
  1028.     #define multimap1(type,typecases,imm_typecases,mapid,map_addr,map_len)  \
  1029.       { switch (type)        \
  1030.           { typecases        \
  1031.               if ( map_mapid(mapid,ThePointer(type_pointer_object(type,map_addr)),map_len,FALSE) <0) \
  1032.                 goto no_mem; \
  1033.               break;         \
  1034.             default: break;  \
  1035.       }   }
  1036.   #else
  1037.     #ifndef GENERATIONAL_GC
  1038.       #define multimap1(type,typecases,imm_typecases,mapid,map_addr,map_len)  \
  1039.         { var reg3 int readonly;                            \
  1040.           switch (type)                                     \
  1041.             { typecases                                     \
  1042.                 switch (type)                               \
  1043.                   { imm_typecases  readonly = TRUE; break;  \
  1044.                     default:       readonly = FALSE; break; \
  1045.                   }                                         \
  1046.                 if ( map_mapid(mapid,ThePointer(type_pointer_object(type,map_addr)),map_len,readonly) <0) \
  1047.                   goto no_mem;                              \
  1048.                 break;                                      \
  1049.               default: break;                               \
  1050.         }   }
  1051.     #else
  1052.       #define multimap1(type,typecases,imm_typecases,mapid,map_addr,map_len)  \
  1053.         { switch (type)                                     \
  1054.             { typecases                                     \
  1055.                 if ( map_mapid(mapid,ThePointer(type_pointer_object(type,map_addr)),map_len,FALSE) <0) \
  1056.                   goto no_mem;                              \
  1057.                 switch (type)                               \
  1058.                   { imm_typecases                           \
  1059.                       xmprotect((aint)ThePointer(type_pointer_object(type,map_addr)),map_len,PROT_READ); \
  1060.                       break;                                \
  1061.                     default:                                \
  1062.                       break;                                \
  1063.                   }                                         \
  1064.                 break;                                      \
  1065.               default: break;                               \
  1066.         }   }
  1067.     #endif
  1068.   #endif
  1069.  
  1070.   #if !defined(IMMUTABLE) || defined(GENERATIONAL_GC)
  1071.     #define done_mapid(imm_flag,mapid,map_addr,map_len)  \
  1072.       if ( close_mapid(mapid) <0) \
  1073.         goto no_mem;
  1074.     #define immutable_off()
  1075.     #define immutable_on()
  1076.     #define exitmap()  msync_mmap_intervals()
  1077.   #else # defined(IMMUTABLE) && !defined(GENERATIONAL_GC)
  1078.     typedef struct { int mm_mapid; aint mm_addr; uintL mm_len; } mmapping;
  1079.     local mmapping bigblock[1];
  1080.     local mmapping* bigblock_ptr = &bigblock[0];
  1081.     #define done_mapid(imm_flag,mapid,map_addr,map_len)  \
  1082.       if (imm_flag)                     \
  1083.         { bigblock[0].mm_mapid = mapid; \
  1084.           bigblock[0].mm_addr = map_addr; bigblock[0].mm_len = map_len; \
  1085.           bigblock_ptr++;               \
  1086.         }                               \
  1087.         else                            \
  1088.         { if ( close_mapid(mapid) <0)   \
  1089.             goto no_mem;                \
  1090.         }
  1091.  
  1092.     local void immutable_off (void);
  1093.     local void immutable_off()
  1094.       { var reg1 tint* tptr = &imm_types[0];
  1095.         var reg2 uintC count;
  1096.         dotimesC(count,imm_types_count,
  1097.           { var reg3 void* map_addr = ThePointer(type_pointer_object(*tptr,bigblock[0].mm_addr));
  1098.             if (map_mapid(bigblock[0].mm_mapid,map_addr,bigblock[0].mm_len,FALSE) <0)
  1099.               fehler_cannot_remap_immutable_objects_read_write();
  1100.             tptr++;
  1101.           });
  1102.       }
  1103.  
  1104.     local void immutable_on (void);
  1105.     local void immutable_on()
  1106.       { var reg1 tint* tptr = &imm_types[0];
  1107.         var reg2 uintC count;
  1108.         dotimesC(count,imm_types_count,
  1109.           { var reg3 void* map_addr = ThePointer(type_pointer_object(*tptr,bigblock[0].mm_addr));
  1110.             if (map_mapid(bigblock[0].mm_mapid,map_addr,bigblock[0].mm_len,TRUE) <0)
  1111.               fehler_cannot_remap_immutable_objects_read_only();
  1112.             tptr++;
  1113.           });
  1114.       }
  1115.     #define exitmap()  \
  1116.       { if (!(bigblock_ptr == &bigblock[0])) \
  1117.           close_mapid(bigblock[0].mm_mapid); \
  1118.         msync_mmap_intervals();              \
  1119.       }
  1120.   #endif
  1121.  
  1122.   #define multimap(typecases,imm_typecases,imm_flag,map_addr,map_len,save_flag)  \
  1123.     { # Temporäres File aufmachen:                            \
  1124.       var reg2 int mapid = open_mapid(map_len);               \
  1125.       if (mapid<0) goto no_mem;                               \
  1126.       if (save_flag) { if ( fdsave(mapid,(void*)map_addr,map_len) <0) goto no_mem; } \
  1127.       # und mehrfach überlagert in den Speicher legen:        \
  1128.       { var reg1 oint type;                                   \
  1129.         for (type=0; type < typecount; type++)                \
  1130.           { multimap1(type,typecases,imm_typecases,mapid,map_addr,map_len); } \
  1131.       }                                                       \
  1132.       # und evtl. öffentlich unzugänglich machen:             \
  1133.       done_mapid(imm_flag,mapid,map_addr,map_len);            \
  1134.     }
  1135.  
  1136. #endif # MULTIMAP_MEMORY_VIA_FILE
  1137.  
  1138. #ifdef MULTIMAP_MEMORY_VIA_SHM
  1139.  
  1140. # Virtual Memory Mapping über Shared Memory aufbauen:
  1141.  
  1142.   local int initmap (void);
  1143.   local int initmap()
  1144.     {
  1145.      #ifdef UNIX_LINUX
  1146.       { var struct shminfo shminfo;
  1147.         if ( shmctl(0,IPC_INFO,(struct shmid_ds *)&shminfo) <0)
  1148.           if (errno==ENOSYS)
  1149.             { 
  1150.               //: DEUTSCH "Compilieren Sie Ihr Betriebssystem neu mit Unterstützung von SYSV IPC."
  1151.               //: ENGLISH "Recompile your operating system with SYSV IPC support."
  1152.               //: FRANCAIS "Recompilez votre système opérationnel tel qu'il comprenne IPC SYSV."
  1153.               asciz_out(GETTEXT("need IPC support"));
  1154.               asciz_out(CRLFstring);
  1155.               return -1; # error
  1156.       }     }
  1157.      #endif
  1158.      return 0;
  1159.     }
  1160.  
  1161.   local int open_shmid (uintL map_len);
  1162.   local int open_shmid(map_len)
  1163.     var reg2 uintL map_len;
  1164.     { var reg1 int shmid = shmget(IPC_PRIVATE,map_len,0700|IPC_CREAT); # 0700 = 'Read/Write/Execute nur für mich'
  1165.       if (shmid<0)
  1166.         { 
  1167.           //: DEUTSCH "Kann kein privates Shared-Memory-Segment aufmachen." 
  1168.           //: ENGLISH "Cannot allocate private shared memory segment." 
  1169.           //: FRANCAIS "Ne peux pas allouer de segment privé de mémoire partagée." 
  1170.           asciz_out(GETTEXT("cannot allocate private shared memory segment"));
  1171.           errno_out(errno);
  1172.           return -1; # error
  1173.         }
  1174.       return shmid;
  1175.     }
  1176.  
  1177.   #ifndef SHM_REMAP  # Nur UNIX_LINUX benötigt SHM_REMAP in den shmflags
  1178.     #define SHM_REMAP  0
  1179.   #endif
  1180.   local int idmap (int shmid, void* map_addr, int shmflags);
  1181.   local int idmap(shmid,map_addr,shmflags)
  1182.     var reg2 int shmid;
  1183.     var reg1 void* map_addr;
  1184.     var reg3 int shmflags;
  1185.     { if ( shmat(shmid,
  1186.                  map_addr, # Adresse
  1187.                  shmflags # Flags (Default: Read/Write)
  1188.                 )
  1189.            == (void*)(-1)
  1190.          )
  1191.         {
  1192.           //: DEUTSCH "Kann kein Shared-Memory an Adresse 0x"
  1193.           //: ENGLISH "Cannot map shared memory to address 0x"
  1194.           //: FRANCAIS "Ne peux pas placer de la mémoire partagée à l'adresse 0x"
  1195.           asciz_out(GETTEXT("cannot map shared memory to address 0x"));
  1196.           hex_out(map_addr);
  1197.           //: DEUTSCH " legen."
  1198.           //: ENGLISH "."
  1199.           //: FRANCAIS "."
  1200.           asciz_out(GETTEXT("[end]cannot map shared memory to address 0x"));
  1201.           errno_out(errno);
  1202.           return -1; # error
  1203.         }
  1204.       return 0;
  1205.     }
  1206.  
  1207.   #if !defined(MAP_MEMORY_TABLES)
  1208.     # Kopiert den Inhalt des Intervalls [map_addr..map_addr+map_len-1] ins
  1209.     # Shared-Memory-Segment.
  1210.     local int shmsave (int shmid, void* map_addr, uintL map_len);
  1211.     local int shmsave(shmid,map_addr,map_len)
  1212.       var reg2 int shmid;
  1213.       var reg3 void* map_addr;
  1214.       var reg4 uintL map_len;
  1215.       { var reg1 void* temp_addr = shmat(shmid,
  1216.                                          0, # Adresse: beliebig
  1217.                                          0 # Flags: brauche keine
  1218.                                         );
  1219.         if (temp_addr == (void*)(-1))
  1220.           { 
  1221.             //: DEUTSCH "Kann Shared Memory nicht füllen." 
  1222.             //: ENGLISH "Cannot fill shared memory." 
  1223.             //: FRANCAIS "Ne peux pas remplir la mémoire partagée." 
  1224.             asciz_out(GETTEXT("cannot fill shared memory"));
  1225.             errno_out(errno);
  1226.             return -1; # error
  1227.           }
  1228.         memcpy(temp_addr,map_addr,map_len);
  1229.         if (shmdt(temp_addr) < 0)
  1230.           {
  1231.             //: DEUTSCH "Konnte Shared Memory nicht füllen."
  1232.             //: ENGLISH "Could not fill shared memory."
  1233.             //: FRANCAIS "Ne pouvais pas remplir la mémoire partagée."
  1234.             asciz_out(GETTEXT("could not fill shared memory"));
  1235.             errno_out(errno);
  1236.             return -1; # error
  1237.           }
  1238.         return 0;
  1239.       }
  1240.   #else
  1241.     #define shmsave(shmid,map_addr,map_len)  0
  1242.   #endif
  1243.  
  1244.   local int close_shmid (int shmid);
  1245.   local int close_shmid(shmid)
  1246.     var reg1 int shmid;
  1247.     { if ( shmctl(shmid,IPC_RMID,NULL) <0)
  1248.         { 
  1249.           //: DEUTSCH "Kann Shared-Memory-Segment nicht entfernen."
  1250.           //: ENGLISH "Cannot remove shared memory segment."
  1251.           //: FRANCAIS "Ne peux pas retirer un segment de mémoire partagée."
  1252.           asciz_out(GETTEXT("cannot remove shared memory segment"));
  1253.           errno_out(errno);
  1254.           return -1; # error
  1255.         }
  1256.       return 0;
  1257.     }
  1258.  
  1259.   local int zeromap (void* map_addr, uintL map_len);
  1260.   local int zeromap(map_addr,map_len)
  1261.     var reg3 void* map_addr;
  1262.     var reg2 uintL map_len;
  1263.     { var reg1 int shmid = open_shmid(map_len);
  1264.       if (shmid<0)
  1265.         { return -1; } # error
  1266.       if (idmap(shmid,map_addr,0) < 0)
  1267.         { return -1; } # error
  1268.       return close_shmid(shmid);
  1269.     }
  1270.  
  1271.   # Vorgehen bei multimap:
  1272.   # 1. Shared-Memory-Bereich zur Verfügung stellen
  1273.     #define open_mapid(map_len)  open_shmid(map_len) # -> shmid
  1274.   # 2. Shared-Memory mehrfach überlagert in den Speicher legen
  1275.     #define map_mapid(shmid,map_addr,map_len,flags)  idmap(shmid,map_addr,flags)
  1276.   # 3. öffentlich unzugänglich machen, indem wir ihn löschen:
  1277.   # (Das Betriebssystem löscht den Shared Memory erst dann, wenn am
  1278.   # Ende dieses Prozesses in _exit() ein munmap() durchgeführt wird.)
  1279.     #define close_mapid(shmid)  close_shmid(shmid)
  1280.  
  1281.   #ifndef IMMUTABLE
  1282.     #define multimap1(type,typecases,imm_typecases,mapid,map_addr,map_len)  \
  1283.       { switch (type)                                  \
  1284.           { typecases                                  \
  1285.               if ( map_mapid(mapid, ThePointer(type_pointer_object(type,map_addr)), map_len, \
  1286.                              (type==0 ? SHM_REMAP : 0) \
  1287.                             )                          \
  1288.                    <0                                  \
  1289.                  )                                     \
  1290.                 goto no_mem;                           \
  1291.               break;                                   \
  1292.             default: break;                            \
  1293.       }   }
  1294.   #else
  1295.     #ifndef GENERATIONAL_GC
  1296.       #define multimap1(type,typecases,imm_typecases,mapid,map_addr,map_len)  \
  1297.         { var reg6 int readonly;                            \
  1298.           switch (type)                                     \
  1299.             { typecases                                     \
  1300.                 switch (type)                               \
  1301.                   { imm_typecases  readonly = TRUE; break;  \
  1302.                     default:       readonly = FALSE; break; \
  1303.                   }                                         \
  1304.                 if ( map_mapid(mapid, ThePointer(type_pointer_object(type,map_addr)), map_len, \
  1305.                                (readonly ? SHM_RDONLY : 0) | (type==0 ? SHM_REMAP : 0) \
  1306.                               )                             \
  1307.                      <0                                     \
  1308.                    )                                        \
  1309.                   goto no_mem;                              \
  1310.                 break;                                      \
  1311.               default: break;                               \
  1312.         }   }
  1313.     #else
  1314.       #define multimap1(type,typecases,imm_typecases,mapid,map_addr,map_len)  \
  1315.         { switch (type)                                     \
  1316.             { typecases                                     \
  1317.                 if ( map_mapid(mapid, ThePointer(type_pointer_object(type,map_addr)), map_len, \
  1318.                                (type==0 ? SHM_REMAP : 0)    \
  1319.                               )                             \
  1320.                      <0                                     \
  1321.                    )                                        \
  1322.                   goto no_mem;                              \
  1323.                 switch (type)                               \
  1324.                   { imm_typecases                           \
  1325.                       xmprotect((aint)ThePointer(type_pointer_object(type,map_addr)),map_len,PROT_READ); \
  1326.                       break;                                \
  1327.                     default:                                \
  1328.                       break;                                \
  1329.                   }                                         \
  1330.                 break;                                      \
  1331.               default: break;                               \
  1332.         }   }
  1333.     #endif
  1334.   #endif
  1335.  
  1336.   #if !defined(IMMUTABLE) || defined(GENERATIONAL_GC)
  1337.     #define done_mapid(imm_flag,mapid,map_addr,map_len)  \
  1338.       if ( close_mapid(mapid) <0) \
  1339.         goto no_mem;
  1340.     #define immutable_off()
  1341.     #define immutable_on()
  1342.     #define exitmap()
  1343.   #else # defined(IMMUTABLE) && !defined(GENERATIONAL_GC)
  1344.     typedef struct { int mm_mapid; aint mm_addr; uintL mm_len; } mmapping;
  1345.     local mmapping bigblock[256]; # Hoffentlich reicht 256, da 256*64KB = 2^24 ??
  1346.     local mmapping* bigblock_ptr = &bigblock[0];
  1347.     # Wann werden Shared-Memory-Segmente freigegeben? Je nachdem,
  1348.     # ob shmat() auf einem Shared-Memory-Segment funktioniert, das bereits
  1349.     # mit shmctl(..,IPC_RMID,NULL) entfernt wurde, aber noch nattch > 0 hat.
  1350.     #ifdef SHM_RMID_VALID # UNIX_LINUX || ...
  1351.       #define SHM_RM_atonce  TRUE
  1352.       #define SHM_RM_atexit  FALSE
  1353.     #else # UNIX_SUNOS4 || ...
  1354.       #define SHM_RM_atonce  FALSE
  1355.       #define SHM_RM_atexit  TRUE
  1356.     #endif
  1357.     #define done_mapid(imm_flag,mapid,map_addr,map_len)  \
  1358.       if (imm_flag)                                                          \
  1359.         { bigblock_ptr->mm_mapid = mapid;                                    \
  1360.           bigblock_ptr->mm_addr = map_addr; bigblock_ptr->mm_len = map_len;  \
  1361.           bigblock_ptr++;                                                    \
  1362.           if (SHM_RM_atonce)                                                 \
  1363.             { if ( close_mapid(mapid) <0)                                    \
  1364.                 goto no_mem;                                                 \
  1365.             }                                                                \
  1366.         }                                                                    \
  1367.         else                                                                 \
  1368.         { if ( close_mapid(mapid) <0)                                        \
  1369.             goto no_mem;                                                     \
  1370.         }
  1371.     local void immutable_off (void);
  1372.     local void immutable_off()
  1373.       { var reg3 tint* tptr = &imm_types[0];
  1374.         var reg4 uintC count;
  1375.         dotimesC(count,imm_types_count,
  1376.           { var reg1 mmapping* ptr = &bigblock[0];
  1377.             until (ptr==bigblock_ptr)
  1378.               { var reg2 void* map_addr = ThePointer(type_pointer_object(*tptr,ptr->mm_addr));
  1379.                 if ((shmdt(map_addr) <0) ||
  1380.                     (map_mapid(ptr->mm_mapid, map_addr, ptr->mm_len, 0) <0))
  1381.                   fehler_cannot_remap_immutable_objects_read_write();
  1382.                 ptr++;
  1383.               }
  1384.             tptr++;
  1385.           });
  1386.       }
  1387.     local void immutable_on (void);
  1388.     local void immutable_on()
  1389.       { var reg3 tint* tptr = &imm_types[0];
  1390.         var reg4 uintC count;
  1391.         dotimesC(count,imm_types_count,
  1392.           { var reg1 mmapping* ptr = &bigblock[0];
  1393.             until (ptr==bigblock_ptr)
  1394.               { var reg2 void* map_addr = ThePointer(type_pointer_object(*tptr,ptr->mm_addr));
  1395.                 if ((shmdt(map_addr) <0) ||
  1396.                     (map_mapid(ptr->mm_mapid, map_addr, ptr->mm_len, SHM_RDONLY) <0))
  1397.                   fehler_cannot_remap_immutable_objects_read_only();
  1398.                 ptr++;
  1399.               }
  1400.             tptr++;
  1401.           });
  1402.       }
  1403.     #if SHM_RM_atexit
  1404.       #define exitmap()  \
  1405.         { var reg1 mmapping* ptr = &bigblock[0];                           \
  1406.           until (ptr==bigblock_ptr) { close_mapid(ptr->mm_mapid); ptr++; } \
  1407.         }
  1408.     #else
  1409.       #define exitmap()
  1410.     #endif
  1411.   #endif
  1412.  
  1413.   #define multimap(typecases,imm_typecases,imm_flag,total_map_addr,total_map_len,save_flag)  \
  1414.     { var reg4 uintL remaining_len = total_map_len;                                    \
  1415.       var reg5 aint map_addr = total_map_addr;                                         \
  1416.       do { var reg3 uintL map_len = (remaining_len > SHMMAX ? SHMMAX : remaining_len); \
  1417.            # Shared-Memory-Bereich aufmachen:                                          \
  1418.            var reg2 int mapid = open_mapid(map_len);                                   \
  1419.            if (mapid<0) goto no_mem;                                                   \
  1420.            if (save_flag && (map_addr==total_map_addr))                                \
  1421.              { if ( shmsave(mapid,(void*)total_map_addr,total_map_len) <0) goto no_mem; } \
  1422.            # und mehrfach überlagert in den Speicher legen:                            \
  1423.            { var reg1 oint type;                                                       \
  1424.              for (type=0; type < typecount; type++)                                    \
  1425.                { multimap1(type,typecases,imm_typecases,mapid,map_addr,map_len); }     \
  1426.            }                                                                           \
  1427.            # und evtl. öffentlich unzugänglich machen:                                 \
  1428.            done_mapid(imm_flag,mapid,map_addr,map_len);                                \
  1429.            map_addr += map_len; remaining_len -= map_len;                              \
  1430.          }                                                                             \
  1431.          until (remaining_len==0);                                                     \
  1432.     }
  1433.  
  1434. #endif # MULTIMAP_MEMORY_VIA_SHM
  1435.  
  1436. #endif # MULTIMAP_MEMORY
  1437.  
  1438. #if defined(SINGLEMAP_MEMORY) || defined(TRIVIALMAP_MEMORY)
  1439.  
  1440. # Das Betriebssystem erlaubt es, an willkürlichen Adressen Speicher hinzulegen,
  1441. # der sich genauso benimmt wie malloc()-allozierter Speicher.
  1442.  
  1443. # Länge einer Speicherseite des Betriebssystems:
  1444.   local /* uintL */ aint map_pagesize; # wird eine Zweierpotenz sein, meist 4096.
  1445.  
  1446. # Initialisierung:
  1447. # initmap()
  1448.  
  1449. # In einen Speicherbereich [map_addr,map_addr+map_len-1] leere Seiten legen:
  1450. # (map_addr und map_len durch map_pagesize teilbar.)
  1451. # zeromap(map_addr,map_len)
  1452.  
  1453. #ifdef HAVE_MACH_VM
  1454.  
  1455.   local int initmap (void);
  1456.   local int initmap()
  1457.     { return 0; }
  1458.  
  1459.   local int zeromap (void* map_addr, uintL map_len);
  1460.   local int zeromap(map_addr,map_len)
  1461.     var void* map_addr;
  1462.     var reg1 uintL map_len;
  1463.     { if (!(vm_allocate(task_self(), (vm_address_t*) &map_addr, map_len, FALSE)
  1464.             == KERN_SUCCESS
  1465.          ) )
  1466.         { 
  1467.           //: DEUTSCH "Kann keinen Speicher an Adresse 0x"
  1468.           //: ENGLISH "Cannot map memory to address 0x"
  1469.           //: FRANCAIS "Ne peux pas placer de la mémoire à l'adresse 0x" 
  1470.           asciz_out(GETTEXT("cannot map memory to address 0x"));
  1471.           hex_out(map_addr);
  1472.           //: DEUTSCH " legen."
  1473.           //: ENGLISH " ." 
  1474.           //: FRANCAIS " ."
  1475.           asciz_out(GETTEXT("[end]cannot map memory to address 0x"));
  1476.           asciz_out(CRLFstring);
  1477.           return -1; # error
  1478.         }
  1479.       return 0;
  1480.     }
  1481.  
  1482.   # Ein Ersatz für die mmap-Funktion. Nur für Files geeignet.
  1483.   #define MAP_FIXED    0
  1484.   #define MAP_PRIVATE  0
  1485.   global RETMMAPTYPE mmap (addr,len,prot,flags,fd,off)
  1486.     var MMAP_ADDR_T addr;
  1487.     var MMAP_SIZE_T len;
  1488.     var int prot; # sollte PROT_READ | PROT_WRITE sein??
  1489.     var int flags; # sollte MAP_FIXED | MAP_PRIVATE sein??
  1490.     var int fd; # sollte ein gültiges Handle sein
  1491.     var off_t off;
  1492.     { switch (vm_allocate(task_self(), (vm_address_t*) &addr, len, FALSE))
  1493.         { case KERN_SUCCESS:
  1494.             break;
  1495.           default:
  1496.             errno = EINVAL; return (RETMMAPTYPE)(-1);
  1497.         }
  1498.       switch (map_fd(fd, off, (vm_address_t*) &addr, 0, len))
  1499.         { case KERN_SUCCESS:
  1500.             return addr;
  1501.           case KERN_INVALID_ADDRESS:
  1502.           case KERN_INVALID_ARGUMENT:
  1503.           default:
  1504.             errno = EINVAL; return (RETMMAPTYPE)(-1);
  1505.     }   }
  1506.  
  1507.   # Ein Ersatz für die munmap-Funktion.
  1508.   global int munmap(addr,len)
  1509.     var reg2 MMAP_ADDR_T addr;
  1510.     var reg3 MMAP_SIZE_T len;
  1511.     { switch (vm_deallocate(task_self(),addr,len))
  1512.         { case KERN_SUCCESS:
  1513.             return 0;
  1514.           case KERN_INVALID_ADDRESS:
  1515.           default:
  1516.             errno = EINVAL; return -1;
  1517.     }   }
  1518.  
  1519.   # Ein Ersatz für die mprotect-Funktion.
  1520.   global int mprotect(addr,len,prot)
  1521.     var reg2 MMAP_ADDR_T addr;
  1522.     var reg3 MMAP_SIZE_T len;
  1523.     var reg4 int prot;
  1524.     { switch (vm_protect(task_self(),addr,len,0,prot))
  1525.         { case KERN_SUCCESS:
  1526.             return 0;
  1527.           case KERN_PROTECTION_FAILURE:
  1528.             errno = EACCES; return -1;
  1529.           case KERN_INVALID_ADDRESS:
  1530.           default:
  1531.             errno = EINVAL; return -1;
  1532.     }   }
  1533.  
  1534. #else
  1535.  
  1536. # Beide mmap()-Methoden gleichzeitig anzuwenden, ist unnötig:
  1537. #ifdef HAVE_MMAP_ANON
  1538.   #undef HAVE_MMAP_DEVZERO
  1539. #endif
  1540.  
  1541. #ifdef HAVE_MMAP_DEVZERO
  1542.   local int zero_fd; # Handle von /dev/zero
  1543.   # Zugriff auf /dev/zero: /dev/zero hat manchmal Permissions 0644. Daher
  1544.   # OPEN() mit nur O_RDONLY statt O_RDWR. Daher MAP_PRIVATE statt MAP_SHARED.
  1545.   #ifdef MAP_FILE
  1546.     #define map_flags  MAP_FILE | MAP_PRIVATE
  1547.   #else
  1548.     #define map_flags  MAP_PRIVATE
  1549.   #endif
  1550. #endif
  1551. #ifdef HAVE_MMAP_ANON
  1552.   #define zero_fd  -1 # irgendein ungültiges Handle geht!
  1553.   #define map_flags  MAP_ANON | MAP_PRIVATE
  1554. #endif
  1555.  
  1556.   local int initmap (void);
  1557.   local int initmap()
  1558.     {
  1559.       #ifdef HAVE_MMAP_DEVZERO
  1560.       { var reg1 int fd = OPEN("/dev/zero",O_RDONLY,my_open_mask);
  1561.         if (fd<0)
  1562.           { 
  1563.             //: DEUTSCH "Kann /dev/zero nicht öffnen."
  1564.             //: ENGLISH "Cannot open /dev/zero ."
  1565.             //: FRANCAIS "Ne peux pas ouvrir /dev/zero ."
  1566.             asciz_out(GETTEXT("cannot open /dev/zero"));
  1567.             errno_out(errno);
  1568.             return -1; # error
  1569.           }
  1570.         zero_fd = fd;
  1571.       }
  1572.       #endif
  1573.       return 0;
  1574.     }
  1575.  
  1576.   local int zeromap (void* map_addr, uintL map_len);
  1577.   local int zeromap(map_addr,map_len)
  1578.     var reg1 void* map_addr;
  1579.     var reg2 uintL map_len;
  1580.     { if ( (void*) mmap(map_addr, # gewünschte Adresse
  1581.                         map_len, # Länge
  1582.                         PROT_READ | PROT_WRITE, # Zugriffsrechte
  1583.                         map_flags | MAP_FIXED, # genau an diese Adresse!
  1584.                         zero_fd, 0 # leere Seiten legen
  1585.                        )
  1586.            == (void*)(-1)
  1587.          )
  1588.         { 
  1589.           //: DEUTSCH "Kann keinen Speicher an Adresse 0x"
  1590.           //: ENGLISH "Cannot map memory to address 0x"
  1591.           //: FRANCAIS "Ne peux pas placer de la mémoire à l'adresse 0x"
  1592.           asciz_out(GETTEXT("cannot map memory to address 0x"));
  1593.           hex_out(map_addr);
  1594.           //: DEUTSCH " legen." 
  1595.           //: ENGLISH " ." 
  1596.           //: FRANCAIS " ."
  1597.           asciz_out(GETTEXT("[end]cannot map memory to address 0x"));
  1598.           errno_out(errno);
  1599.           return -1; # error
  1600.         }
  1601.       return 0;
  1602.     }
  1603.  
  1604. #endif # HAVE_MACH_VM
  1605.  
  1606. # Immutable Objekte gibt es nicht.
  1607.   #define fehler_immutable()
  1608.  
  1609. #endif # SINGLEMAP_MEMORY || TRIVIALMAP_MEMORY
  1610.  
  1611. # ------------------------------------------------------------------------------
  1612. #                           Page-Verwaltung
  1613.  
  1614. # Page-Deskriptor:
  1615. typedef struct { aint start;   # Pointer auf den belegten Platz (aligned)
  1616.                  aint end;     # Pointer hinter den belegten Platz (aligned)
  1617.                  union { object firstmarked; uintL l; aint d; void* next; }
  1618.                        gcpriv; # private Variable während GC
  1619.                }
  1620.         _Page;
  1621.  
  1622. # Page-Deskriptor samt dazugehöriger Verwaltungsinformation:
  1623. # typedef ... Page;
  1624. # Hat die Komponenten page_start, page_end, page_gcpriv.
  1625.  
  1626. # Eine Ansammlung von Pages:
  1627. # typedef ... Pages;
  1628.  
  1629. # Eine Ansammlung von Pages und die für sie nötige Verwaltungsinformation:
  1630. # typedef ... Heap;
  1631.  
  1632. #ifdef SPVW_PAGES
  1633.  
  1634. #if !defined(VIRTUAL_MEMORY) || defined(BROKEN_MALLOC)
  1635. # Jede Page enthält einen Header für die AVL-Baum-Verwaltung.
  1636. # Das erlaubt es, daß die AVL-Baum-Verwaltung selbst keine malloc-Aufrufe
  1637. # tätigen muß.
  1638. #else # defined(VIRTUAL_MEMORY) && !defined(BROKEN_MALLOC)
  1639. # Bei Virtual Memory ist es schlecht, wenn die GC alle Seiten anfassen muß.
  1640. # Daher sei die AVL-Baum-Verwaltung separat.
  1641. #define AVL_SEPARATE
  1642. #endif
  1643.  
  1644. #define AVLID  spvw
  1645. #define AVL_ELEMENT  uintL
  1646. #define AVL_EQUAL(element1,element2)  ((element1)==(element2))
  1647. #define AVL_KEY  AVL_ELEMENT
  1648. #define AVL_KEYOF(element)  (element)
  1649. #define AVL_COMPARE(key1,key2)  (sintL)((key1)-(key2))
  1650. #define NO_AVL_MEMBER
  1651. #define NO_AVL_INSERT
  1652. #define NO_AVL_DELETE
  1653.  
  1654. #include "avl.c"
  1655.  
  1656. typedef struct NODE
  1657.                { NODEDATA nodedata;        # NODE für AVL-Baum-Verwaltung
  1658.                  #define page_room  nodedata.value # freier Platz in dieser Page (in Bytes)
  1659.                  _Page page;       # Page-Deskriptor, bestehend aus:
  1660.                  #define page_start  page.start  # Pointer auf den belegten Platz (aligned)
  1661.                  #define page_end    page.end    # Pointer auf den freien Platz (aligned)
  1662.                  #define page_gcpriv page.gcpriv # private Variable während GC
  1663.                  aint m_start;     # von malloc gelieferte Startadresse (unaligned)
  1664.                  aint m_length;    # bei malloc angegebene Page-Länge (in Bytes)
  1665.                }
  1666.         NODE;
  1667. #define HAVE_NODE
  1668.  
  1669. #if !defined(AVL_SEPARATE)
  1670.   # NODE innerhalb der Seite
  1671.   #define sizeof_NODE  sizeof(NODE)
  1672.   #define page_start0(page)  round_up((aint)page+sizeof(NODE),varobject_alignment)
  1673.   #define free_page(page)  begin_system_call(); free((void*)page->m_start); end_system_call();
  1674. #else
  1675.   # NODE extra
  1676.   #define sizeof_NODE  0
  1677.   #define page_start0(page)  round_up(page->m_start,varobject_alignment)
  1678.   #define free_page(page)  begin_system_call(); free((void*)page->m_start); free((void*)page); end_system_call();
  1679. #endif
  1680.  
  1681. #include "avl.c"
  1682.  
  1683. typedef NODE Page;
  1684.  
  1685. typedef Page* Pages;
  1686.  
  1687. typedef struct { Pages inuse;     # Die gerade benutzten Pages
  1688.                  # _Page reserve; # Eine Reserve-Page ??
  1689.                  # Bei Heap für Objekte fester Länge:
  1690.                  Pages lastused; # Ein Cache für die letzte benutzte Page
  1691.                }
  1692.         Heap;
  1693.  
  1694. # Größe einer normalen Page = minimale Pagegröße. Durch sizeof(cons_) teilbar.
  1695.   # Um offset_pages_len (s.u.) nicht zu groß werden zu lassen, darf die
  1696.   # Pagegröße nicht zu klein sein.
  1697.   #if (oint_addr_len<=32)
  1698.     #define oint_addr_relevant_len  oint_addr_len
  1699.   #else
  1700.     #if defined(DECALPHA) && defined(UNIX_OSF)
  1701.       # Alle Adressen liegen zwischen 1*2^32 und 2*2^32. Also faktisch doch
  1702.       # nur ein Adreßraum von 2^32.
  1703.       #define oint_addr_relevant_len  32
  1704.     #endif
  1705.   #endif
  1706.   #define min_page_size_brutto  bit(oint_addr_relevant_len/2)
  1707.   #define std_page_size  round_down(min_page_size_brutto-sizeof_NODE-(varobject_alignment-1),sizeof(cons_))
  1708.  
  1709. # Eine Dummy-Page für lastused:
  1710.   local NODE dummy_NODE;
  1711.   #define dummy_lastused  (&dummy_NODE)
  1712.  
  1713. #endif
  1714.  
  1715. #ifdef SPVW_BLOCKS
  1716.  
  1717. typedef _Page Page;
  1718. #define page_start   start
  1719. #define page_end     end
  1720. #define page_gcpriv  gcpriv
  1721.  
  1722. typedef Page Pages;
  1723.  
  1724. #ifdef GENERATIONAL_GC
  1725. # Für jede physikalische Speicherseite der alten Generation merken wir uns,
  1726. # um auf diese Seite nicht zugreifen zu müssen, welche Pointer auf Objekte
  1727. # der neuen Generation diese enthält.
  1728. # Solange man auf die Seite nicht schreibend zugreift, bleibt diese Information
  1729. # aktuell. Nachdem man auf die Seite aber schreibend zugegriffen hat, muß man
  1730. # diese Information bei der nächsten GC neu erstellen. Dies sollte man aber
  1731. # machen, ohne auf die Seite davor oder danach zugreifen zu müssen.
  1732. typedef struct { object* p; # Adresse des Pointers, innerhalb eines alten Objekts
  1733.                  object o;  # o = *p, Pointer auf ein neues Objekt
  1734.                }
  1735.         old_new_pointer;
  1736. typedef struct { # Durchlaufen der Pointer in der Seite benötigt Folgendes:
  1737.                    # Fortsetzung des letzten Objekts der Seite davor:
  1738.                    object* continued_addr;
  1739.                    uintC continued_count;
  1740.                    # Erstes Objekt, das in dieser Seite (oder später) beginnt:
  1741.                    aint firstobject;
  1742.                  # Der Cache der Pointer auf Objekte der neuen Generation:
  1743.                  int protection; # PROT_NONE : Nur der Cache ist gültig.
  1744.                                  # PROT_READ : Seite und Cache beide gültig.
  1745.                                  # PROT_READ_WRITE : Nur die Seite ist gültig.
  1746.                  uintL cache_size; # Anzahl der gecacheten Pointer
  1747.                  old_new_pointer* cache; # Cache aller Pointer in die neue
  1748.                                          # Generation
  1749.                }
  1750.         physpage_state;
  1751. #endif
  1752.  
  1753. typedef struct { Pages pages;
  1754.                  #ifndef SPVW_MIXED_BLOCKS_OPPOSITE
  1755.                  # d.h. SPVW_PURE_BLOCKS || (SPVW_MIXED_BLOCKS && TRIVIALMAP_MEMORY)
  1756.                  aint heap_limit;
  1757.                  #endif
  1758.                  #ifdef GENERATIONAL_GC
  1759.                  aint heap_gen0_start;
  1760.                  aint heap_gen0_end;
  1761.                  aint heap_gen1_start;
  1762.                  physpage_state* physpages;
  1763.                  #endif
  1764.                }
  1765.         Heap;
  1766. #define heap_start  pages.page_start
  1767. #define heap_end    pages.page_end
  1768. #ifndef SPVW_MIXED_BLOCKS_OPPOSITE
  1769. # Stets heap_start <= heap_end <= heap_limit.
  1770. # Der Speicher zwischen heap_start und heap_end ist belegt,
  1771. # der Speicher zwischen heap_end und heap_limit ist frei.
  1772. # heap_limit wird, wenn nötig, vergrößert.
  1773. #else
  1774. # Stets heap_start <= heap_end.
  1775. # Der Speicher zwischen heap_start und heap_end ist belegt,
  1776. #endif
  1777. #ifdef GENERATIONAL_GC
  1778. #ifndef SPVW_MIXED_BLOCKS_OPPOSITE
  1779. # Die Generation 0 (ältere Generation) beginnt bei heap_gen0_start,
  1780. #                                      geht bis    heap_gen0_end.
  1781. # Die Generation 1 (neuere Generation) beginnt bei heap_gen1_start,
  1782. #                                      geht bis    heap_end.
  1783. # heap_gen0_start und heap_gen1_start sind durch physpagesize teilbar.
  1784. # Zwischen heap_gen0_end und heap_gen1_start ist eine Lücke von weniger als
  1785. # einer Page.
  1786. # heap_start ist entweder = heap_gen0_start oder = heap_gen1_start.
  1787. #else
  1788. # Die Generation 0 (ältere Generation) beginnt bei heap_gen0_start,
  1789. #                                      geht bis    heap_gen0_end.
  1790. # Bei mem.varobjects:
  1791. #   Generation 1 (neuere Generation) beginnt bei heap_gen1_start,
  1792. #                                    geht bis    heap_end.
  1793. #   heap_gen0_start und heap_gen1_start sind durch physpagesize teilbar.
  1794. #   Zwischen heap_gen0_end und heap_gen1_start ist eine Lücke von weniger als
  1795. #   einer Page.
  1796. #   heap_start ist entweder = heap_gen0_start oder = heap_gen1_start.
  1797. # Bei mem.conses:
  1798.     #define heap_gen1_end  heap_gen1_start
  1799. #   Generation 1 (neuere Generation) beginnt bei heap_start,
  1800. #                                    geht bis    heap_gen1_end.
  1801. #   heap_gen1_end und heap_gen0_end sind durch physpagesize teilbar.
  1802. #   Zwischen heap_gen1_end und heap_gen0_start ist eine Lücke von weniger als
  1803. #   einer Page.
  1804. #   heap_end ist entweder = heap_gen1_end oder = heap_gen0_end.
  1805. #endif
  1806. # Der Status von Adresse addr (heap_gen0_start <= addr < heap_gen0_end) wird
  1807. # von physpages[(addr>>physpageshift)-(heap_gen0_start>>physpageshift)] gegeben.
  1808. # physpages=NULL ist möglich, wenn nicht genügend Platz da war!
  1809. #endif
  1810.  
  1811. #endif
  1812.  
  1813. #ifdef SPVW_MIXED
  1814.  
  1815. # Zwei Heaps: einer für Objekte variabler Länge, einer für Conses u.ä.
  1816. #define heapcount  2
  1817.  
  1818. #endif
  1819.  
  1820. #ifdef SPVW_PURE
  1821.  
  1822. # Ein Heap für jeden möglichen Typcode
  1823. #define heapcount  typecount
  1824.  
  1825. #endif
  1826.  
  1827. # Für jeden möglichen Heap (0 <= heapnr < heapcount) den Typ des Heaps feststellen:
  1828. # is_cons_heap(heapnr)
  1829. # is_varobject_heap(heapnr)
  1830. # is_heap_containing_objects(heapnr)
  1831. # is_unused_heap(heapnr)
  1832. #ifdef SPVW_MIXED
  1833.   #define is_cons_heap(heapnr)  ((heapnr)==1)
  1834.   #define is_varobject_heap(heapnr)  ((heapnr)==0)
  1835.   #define is_heap_containing_objects(heapnr)  (TRUE)
  1836.   #define is_unused_heap(heapnr)  (FALSE)
  1837. #endif
  1838. #ifdef SPVW_PURE
  1839.   #define is_cons_heap(heapnr)  (mem.heaptype[heapnr] == 0)
  1840.   #define is_varobject_heap(heapnr)  (mem.heaptype[heapnr] > 0)
  1841.   #define is_heap_containing_objects(heapnr)  ((mem.heaptype[heapnr] >= 0) && (mem.heaptype[heapnr] < 2))
  1842.   #define is_unused_heap(heapnr)  (mem.heaptype[heapnr] < 0)
  1843. #endif
  1844.  
  1845. # Durchlaufen aller CONS-Pages:
  1846. # for_each_cons_page(page, [statement, das 'var Page* page' benutzt] );
  1847.  
  1848. # Durchlaufen aller Pages von Objekten variabler Länge:
  1849. # for_each_varobject_page(page, [statement, das 'var Page* page' benutzt] );
  1850.  
  1851. # Durchlaufen aller Pages:
  1852. # for_each_page(page, [statement, das 'var Page* page' benutzt] );
  1853.  
  1854. #ifdef SPVW_BLOCKS
  1855.   #define map_heap(heap,pagevar,statement)  \
  1856.     { var reg1 Page* pagevar = &(heap).pages; statement; }
  1857. #endif
  1858. #ifdef SPVW_PAGES
  1859.   #define map_heap(heap,pagevar,statement)  \
  1860.     { AVL_map((heap).inuse,pagevar,statement); }
  1861. #endif
  1862.  
  1863. #ifdef SPVW_MIXED
  1864.  
  1865. #define for_each_cons_heap(heapvar,statement)  \
  1866.   { var reg3 Heap* heapvar = &mem.conses; statement; }
  1867. #define for_each_varobject_heap(heapvar,statement)  \
  1868.   { var reg3 Heap* heapvar = &mem.varobjects; statement; }
  1869. #define for_each_heap(heapvar,statement)  \
  1870.   { var reg4 uintL heapnr;                                        \
  1871.     for (heapnr=0; heapnr<heapcount; heapnr++)                    \
  1872.       { var reg3 Heap* heapvar = &mem.heaps[heapnr]; statement; } \
  1873.   }
  1874.  
  1875. #define for_each_cons_page(pagevar,statement)  \
  1876.   map_heap(mem.conses,pagevar,statement)
  1877. #define for_each_cons_page_reversed for_each_cons_page
  1878. #define for_each_varobject_page(pagevar,statement)  \
  1879.   map_heap(mem.varobjects,pagevar,statement)
  1880. #define for_each_page(pagevar,statement)  \
  1881.   { var reg4 uintL heapnr;                           \
  1882.     for (heapnr=0; heapnr<heapcount; heapnr++)       \
  1883.       map_heap(mem.heaps[heapnr],pagevar,statement); \
  1884.   }
  1885.  
  1886. #endif
  1887.  
  1888. #ifdef SPVW_PURE
  1889.  
  1890. # Innerhalb der Schleife ist heapnr die Nummer des Heaps.
  1891.  
  1892. #define for_each_cons_heap(heapvar,statement)  \
  1893.   { var reg4 uintL heapnr;                                          \
  1894.     for (heapnr=0; heapnr<heapcount; heapnr++)                      \
  1895.       if (mem.heaptype[heapnr] == 0)                                \
  1896.         { var reg3 Heap* heapvar = &mem.heaps[heapnr]; statement; } \
  1897.   }
  1898. #define for_each_varobject_heap(heapvar,statement)  \
  1899.   { var reg4 uintL heapnr;                                          \
  1900.     for (heapnr=0; heapnr<heapcount; heapnr++)                      \
  1901.       if (mem.heaptype[heapnr] > 0)                                 \
  1902.         { var reg3 Heap* heapvar = &mem.heaps[heapnr]; statement; } \
  1903.   }
  1904. #define for_each_heap(heapvar,statement)  \
  1905.   { var reg4 uintL heapnr;                                          \
  1906.     for (heapnr=0; heapnr<heapcount; heapnr++)                      \
  1907.       if (mem.heaptype[heapnr] >= 0)                                \
  1908.         { var reg3 Heap* heapvar = &mem.heaps[heapnr]; statement; } \
  1909.   }
  1910.  
  1911. #define for_each_cons_page(pagevar,statement)  \
  1912.   { var reg4 uintL heapnr;                             \
  1913.     for (heapnr=0; heapnr<heapcount; heapnr++)         \
  1914.       if (mem.heaptype[heapnr] == 0)                   \
  1915.         map_heap(mem.heaps[heapnr],pagevar,statement); \
  1916.   }
  1917. #define for_each_cons_page_reversed(pagevar,statement)  \
  1918.   { var reg4 uintL heapnr;                             \
  1919.     for (heapnr=heapcount; heapnr-- > 0; )             \
  1920.       if (mem.heaptype[heapnr] == 0)                   \
  1921.         map_heap(mem.heaps[heapnr],pagevar,statement); \
  1922.   }
  1923. #define for_each_varobject_page(pagevar,statement)  \
  1924.   { var reg4 uintL heapnr;                             \
  1925.     for (heapnr=0; heapnr<heapcount; heapnr++)         \
  1926.       if (mem.heaptype[heapnr] > 0)                    \
  1927.         map_heap(mem.heaps[heapnr],pagevar,statement); \
  1928.   }
  1929. #define for_each_page(pagevar,statement)  \
  1930.   { var reg4 uintL heapnr;                             \
  1931.     for (heapnr=0; heapnr<heapcount; heapnr++)         \
  1932.       if (mem.heaptype[heapnr] >= 0)                   \
  1933.         map_heap(mem.heaps[heapnr],pagevar,statement); \
  1934.   }
  1935.  
  1936. #endif
  1937.  
  1938. # ------------------------------------------------------------------------------
  1939.  
  1940. # Speichergrenzen der LISP-Daten:
  1941.   local struct { aint MEMBOT;
  1942.                  # dazwischen der LISP-Stack
  1943.                  Heap heaps[heapcount];
  1944.                  #ifdef SPVW_PURE
  1945.                  sintB heaptype[heapcount];
  1946.                    # zu jedem Typcode: 0 falls Conses u.ä.
  1947.                    #                   1 falls Objekte variabler Länge mit Pointern,
  1948.                    #                   2 falls Objekte variabler Länge ohne Pointer,
  1949.                    #                  -1 falls unbenutzter Typcode
  1950.                  #endif
  1951.                  #ifdef SPVW_MIXED
  1952.                   #define varobjects  heaps[0] # Objekte variabler Länge
  1953.                   #define conses      heaps[1] # Conses u.ä.
  1954.                  #endif
  1955.                  #if defined(SPVW_MIXED_BLOCKS) && defined(GENERATIONAL_GC)
  1956.                  sintB heapnr_from_type[typecount]; # Tabelle type -> heapnr
  1957.                  #endif
  1958.                  #ifdef SPVW_MIXED_BLOCKS_OPPOSITE
  1959.                   # dazwischen leer, frei für LISP-Objekte
  1960.                  #define MEMRES    conses.heap_end
  1961.                  # dazwischen Reserve
  1962.                  aint MEMTOP;
  1963.                  #endif
  1964.                  #if defined(SPVW_PURE_BLOCKS) || defined(TRIVIALMAP_MEMORY) || defined(GENERATIONAL_GC)
  1965.                  uintL total_room; # wieviel Platz belegt werden darf, ohne daß GC nötig wird
  1966.                  #ifdef GENERATIONAL_GC
  1967.                  boolean last_gc_full; # ob die letzte GC eine volle war
  1968.                  uintL last_gcend_space0; # wieviel Platz am Ende der letzten GC belegt war
  1969.                  uintL last_gcend_space1; # (von Generation 0 bzw. Generation 1)
  1970.                  #endif
  1971.                  #endif
  1972.                  #ifdef SPVW_PAGES
  1973.                  Pages free_pages; # eine Liste freier normalgroßer Pages
  1974.                  uintL total_space; # wieviel Platz die belegten Pages überhaupt enthalten
  1975.                  uintL used_space; # wieviel Platz gerade belegt ist
  1976.                  uintL last_gcend_space; # wieviel Platz am Ende der letzten GC belegt war
  1977.                  boolean last_gc_compacted; # ob die letzte GC schon kompaktiert hat
  1978.                  uintL gctrigger_space; # wieviel Platz belegt werden darf, bis die nächste GC nötig wird
  1979.                  #endif
  1980.                }
  1981.         mem;
  1982.   #if defined(SPVW_MIXED_BLOCKS_OPPOSITE) && !defined(GENERATIONAL_GC)
  1983.     #define RESERVE       0x00800L  # 2 KByte Speicherplatz als Reserve
  1984.   #else
  1985.     #define RESERVE             0   # brauche keine präallozierte Reserve
  1986.   #endif
  1987.   #define MINIMUM_SPACE 0x10000L  # 64 KByte als minimaler Speicherplatz
  1988.                                   #  für LISP-Daten
  1989.  
  1990. # Stack-Grenzen:
  1991.   global void* SP_bound;    # SP-Wachstumsgrenze
  1992.   global void* STACK_bound; # STACK-Wachstumsgrenze
  1993.   #if defined(EMUNIX) && defined(WINDOWS)
  1994.     global void* SP_start;  # SP bei Programmstart
  1995.   #endif
  1996.  
  1997. # Bei Überlauf eines der Stacks:
  1998.   nonreturning_function(global, SP_ueber, (void));
  1999.   global void SP_ueber()
  2000.     { 
  2001.       //: DEUTSCH "Programmstack-Überlauf: RESET"
  2002.       //: ENGLISH "Program stack overflow. RESET"
  2003.       //: FRANCAIS "Débordement de pile de programme : RAZ"
  2004.       err_asciz_out(GETTEXT("program stack overflow"));
  2005.       reset();
  2006.     }
  2007.   nonreturning_function(global, STACK_ueber, (void));
  2008.   global void STACK_ueber()
  2009.     { 
  2010.       //: DEUTSCH "LISP-Stack-Überlauf: RESET"
  2011.       //: ENGLISH "Lisp stack overflow. RESET"
  2012.       //: FRANCAIS "Débordement de pile Lisp : RAZ"
  2013.       asciz_out(GETTEXT("lisp stack overflow"));
  2014.       reset();
  2015.     }
  2016.  
  2017. # Überprüfung des Speicherinhalts auf GC-Festigkeit:
  2018.   #if defined(SPVW_PAGES) && defined(DEBUG_SPVW)
  2019.     # Überprüfen, ob die Verwaltung der Pages in Ordnung ist:
  2020.       #define CHECK_AVL_CONSISTENCY()  check_avl_consistency()
  2021.       local void check_avl_consistency (void);
  2022.       local void check_avl_consistency()
  2023.         { var reg4 uintL heapnr;
  2024.           for (heapnr=0; heapnr<heapcount; heapnr++)
  2025.             { AVL(AVLID,check) (mem.heaps[heapnr].inuse); }
  2026.         }
  2027.     # Überprüfen, ob die Grenzen der Pages in Ordnung sind:
  2028.       #define CHECK_GC_CONSISTENCY()  check_gc_consistency()
  2029.       local void check_gc_consistency (void);
  2030.       local void check_gc_consistency()
  2031.         { for_each_page(page,
  2032.             if ((sintL)page->page_room < 0)
  2033.               { asciz_out(NLstring);
  2034.                 //: DEUTSCH "Page bei Adresse 0x"
  2035.                 //: ENGLISH "Page bei Adresse 0x"
  2036.                 //: FRANCAIS "Page bei Adresse 0x"
  2037.                 asciz_out(GETTEXT("Page bei Adresse 0x"));
  2038.                 hex_out(page);
  2039.                 //: DEUTSCH " übergelaufen!!"
  2040.                 //: ENGLISH " übergelaufen!!"
  2041.                 //: FRANCAIS " übergelaufen!!"
  2042.                 asciz_out(GETTEXT(" übergelaufen!!"));
  2043.                 asciz_out(NLstring);
  2044.                 abort(); 
  2045.               }
  2046.             if (!(page->page_start == page_start0(page)))
  2047.               { asciz_out(NLstring);
  2048.                 //: DEUTSCH "Page bei Adresse 0x"
  2049.                 //: ENGLISH "Page bei Adresse 0x"
  2050.                 //: FRANCAIS "Page bei Adresse 0x"
  2051.                 asciz_out(GETTEXT("Page bei Adresse 0x"));
  2052.                 hex_out(page);
  2053.                 //: DEUTSCH " inkonsistent!!"
  2054.                 //: ENGLISH " inkonsistent!!"
  2055.                 //: FRANCAIS " inkonsistent!!"
  2056.                 asciz_out(GETTEXT(" inkonsistent!!"));
  2057.                 asciz_out(NLstring);
  2058.                 abort(); 
  2059.               }
  2060.             if (!(page->page_end + page->page_room
  2061.                   == round_down(page->m_start + page->m_length,varobject_alignment)
  2062.                ) )
  2063.               {
  2064.                 asciz_out(NLstring); 
  2065.                 //: DEUTSCH "Page bei Adresse 0x"
  2066.                 //: ENGLISH "Page bei Adresse 0x"
  2067.                 //: FRANCAIS "Page bei Adresse 0x"
  2068.                 asciz_out(GETTEXT("Page bei Adresse 0x"));
  2069.                 hex_out(page);
  2070.                 //: DEUTSCH " inkonsistent!!"
  2071.                 //: ENGLISH " inkonsistent!!"
  2072.                 //: FRANCAIS " inkonsistent!!"
  2073.                 asciz_out(GETTEXT(" inkonsistent!!"));
  2074.                 asciz_out(NLstring);
  2075.                 abort(); 
  2076.               }
  2077.             );
  2078.         }
  2079.     # Überprüfen, ob während der kompaktierenden GC
  2080.     # die Grenzen der Pages in Ordnung sind:
  2081.       #define CHECK_GC_CONSISTENCY_2()  check_gc_consistency_2()
  2082.       local void check_gc_consistency_2 (void);
  2083.       local void check_gc_consistency_2()
  2084.         { for_each_page(page,
  2085.             if ((sintL)page->page_room < 0)
  2086.               { 
  2087.                 asciz_out(NLstring);
  2088.                 //: DEUTSCH "Page bei Adresse 0x"
  2089.                 //: ENGLISH "Page bei Adresse 0x"
  2090.                 //: FRANCAIS "Page bei Adresse 0x"
  2091.                 asciz_out(GETTEXT("Page bei Adresse 0x"));
  2092.                 hex_out(page);
  2093.                 //: DEUTSCH " übergelaufen!!"
  2094.                 //: ENGLISH " übergelaufen!!"
  2095.                 //: FRANCAIS " übergelaufen!!"
  2096.                 asciz_out(GETTEXT(" übergelaufen!!"));
  2097.                 asciz_out(NLstring);
  2098.                 abort();
  2099.               }
  2100.             if (!(page->page_end + page->page_room - (page->page_start - page_start0(page))
  2101.                   == round_down(page->m_start + page->m_length,varobject_alignment)
  2102.                ) )
  2103.               { asciz_out(NLstring);
  2104.                 //: DEUTSCH "Page bei Adresse 0x"
  2105.                 //: ENGLISH "Page bei Adresse 0x"
  2106.                 //: FRANCAIS "Page bei Adresse 0x"
  2107.                 asciz_out(GETTEXT("Page bei Adresse 0x"));
  2108.                 hex_out(page); 
  2109.                 //: DEUTSCH " inkonsistent!!"
  2110.                 //: ENGLISH " inkonsistent!!"
  2111.                 //: FRANCAIS " inkonsistent!!"
  2112.                 asciz_out(GETTEXT(" inkonsistent!!"));
  2113.                 asciz_out(NLstring);
  2114.                 abort(); 
  2115.               }
  2116.             );
  2117.         }
  2118.   #else
  2119.     #define CHECK_AVL_CONSISTENCY()
  2120.     #define CHECK_GC_CONSISTENCY()
  2121.     #define CHECK_GC_CONSISTENCY_2()
  2122.   #endif
  2123.   #ifdef DEBUG_SPVW
  2124.     # Überprüfen, ob die Tabellen der Packages halbwegs in Ordnung sind:
  2125.       #define CHECK_PACK_CONSISTENCY()  check_pack_consistency()
  2126.       global void check_pack_consistency (void);
  2127.       global void check_pack_consistency()
  2128.         { var reg9 object plist = O(all_packages);
  2129.           while (consp(plist))
  2130.             { var reg8 object pack = Car(plist);
  2131.               var object symtabs[2];
  2132.               var uintC i;
  2133.               symtabs[0] = ThePackage(pack)->pack_external_symbols;
  2134.               symtabs[1] = ThePackage(pack)->pack_internal_symbols;
  2135.               for (i = 0; i < 2; i++)
  2136.                 { var reg6 object symtab = symtabs[i];
  2137.                   var reg4 object table = TheSvector(symtab)->data[1];
  2138.                   var reg3 uintL index = TheSvector(table)->length;
  2139.                   until (index==0)
  2140.                     { var reg1 object entry = TheSvector(table)->data[--index];
  2141.                       var reg2 uintC count = 0;
  2142.                       while (consp(entry))
  2143.                         { if (!msymbolp(Car(entry))) abort();
  2144.                           entry = Cdr(entry);
  2145.                           count++; if (count>=10000) abort();
  2146.                 }   }   }
  2147.               plist = Cdr(plist);
  2148.         }   }
  2149.   #else
  2150.       #define CHECK_PACK_CONSISTENCY()
  2151.   #endif
  2152.  
  2153. # ------------------------------------------------------------------------------
  2154. #                       Speichergröße
  2155.  
  2156. # Liefert die Größe des von den LISP-Objekten belegten Platzes.
  2157.   global uintL used_space (void);
  2158.   #ifdef SPVW_BLOCKS
  2159.    #ifdef SPVW_MIXED_BLOCKS_OPPOSITE
  2160.     global uintL used_space()
  2161.       {
  2162.         #if !defined(GENERATIONAL_GC)
  2163.           #define Heap_used_space(h)  ((uintL)((h).pages.end - (h).pages.start))
  2164.           return Heap_used_space(mem.varobjects) # Platz für Objekte variabler Länge
  2165.                  + Heap_used_space(mem.conses); # Platz für Conses
  2166.         #else # defined(GENERATIONAL_GC)
  2167.           return (uintL)(mem.varobjects.heap_gen0_end - mem.varobjects.heap_gen0_start)
  2168.                  + (uintL)(mem.varobjects.heap_end - mem.varobjects.heap_gen1_start)
  2169.                  + (uintL)(mem.conses.heap_gen1_end - mem.conses.heap_start)
  2170.                  + (uintL)(mem.conses.heap_gen0_end - mem.conses.heap_gen0_start);
  2171.         #endif
  2172.       }
  2173.    #else
  2174.     global uintL used_space()
  2175.       { var reg4 uintL sum = 0;
  2176.         #if !defined(GENERATIONAL_GC)
  2177.           for_each_page(page, { sum += page->page_end - page->page_start; } );
  2178.         #else # defined(GENERATIONAL_GC)
  2179.           for_each_heap(heap,
  2180.             { sum += (heap->heap_gen0_end - heap->heap_gen0_start)
  2181.                      + (heap->heap_end - heap->heap_gen1_start);
  2182.             });
  2183.         #endif
  2184.         return sum;
  2185.       }
  2186.    #endif
  2187.   #endif
  2188.   #ifdef SPVW_PAGES
  2189.     #if 0
  2190.     global uintL used_space()
  2191.       { var reg4 uintL sum = 0;
  2192.         for_each_page(page, { sum += page->page_end - page->page_start; } );
  2193.         return sum;
  2194.       }
  2195.     #else
  2196.     # Da die Berechnung von used_space() auf jede Page einmal zugreift, was
  2197.     # viel Paging bedeuten kann, wird das Ergebnis in mem.used_space gerettet.
  2198.     global uintL used_space()
  2199.       { return mem.used_space; }
  2200.     #endif
  2201.   #endif
  2202.  
  2203. # Liefert die Größe des für LISP-Objekte noch verfügbaren Platzes.
  2204.   global uintL free_space (void);
  2205.   #ifdef SPVW_BLOCKS
  2206.    #if defined(SPVW_MIXED_BLOCKS_OPPOSITE) && !defined(GENERATIONAL_GC)
  2207.     global uintL free_space()
  2208.       { return (mem.conses.heap_start-mem.varobjects.heap_end); } # Platz in der großen Lücke
  2209.    #else
  2210.     global uintL free_space()
  2211.       { return mem.total_room; } # Platz, der bis zur nächsten GC verbraucht werden darf
  2212.    #endif
  2213.   #endif
  2214.   #ifdef SPVW_PAGES
  2215.     #if 0
  2216.     global uintL free_space()
  2217.       { var reg4 uintL sum = 0;
  2218.         for_each_page(page, { sum += page->page_room; } );
  2219.         return sum;
  2220.       }
  2221.     #else
  2222.     # Da die Berechnung von free_space() auf jede Page einmal zugreift, was
  2223.     # viel Paging bedeuten kann, wird das Ergebnis mit Hilfe von mem.used_space
  2224.     # berechnet.
  2225.     global uintL free_space()
  2226.       { return mem.total_space - mem.used_space; }
  2227.     #endif
  2228.   #endif
  2229.  
  2230. #ifdef SPVW_PAGES
  2231.   # Berechnet mem.used_space und mem.total_space neu.
  2232.   # Das check-Flag gibt an, ob dabei mem.used_space gleich bleiben muß.
  2233.   local void recalc_space (boolean check);
  2234.   local void recalc_space(check)
  2235.     var reg6 boolean check;
  2236.     { var reg4 uintL sum_used = 0;
  2237.       var reg5 uintL sum_free = 0;
  2238.       for_each_page(page,
  2239.                     { sum_used += page->page_end - page->page_start;
  2240.                       sum_free += page->page_room;
  2241.                     }
  2242.                    );
  2243.       if (check)
  2244.         { if (!(mem.used_space == sum_used)) abort(); }
  2245.         else
  2246.         { mem.used_space = sum_used; }
  2247.       mem.total_space = sum_used + sum_free;
  2248.     }
  2249. #endif
  2250.  
  2251. # ------------------------------------------------------------------------------
  2252. #                   Speicherlängenbestimmung
  2253.  
  2254. # Bei allen Objekten variabler Länge (die von links nach rechts wachsen)
  2255. # steht (außer während der GC) in den ersten 4 Bytes ein Pointer auf sich
  2256. # selbst, bei Symbolen auch noch die Flags.
  2257.  
  2258. # Liefert den Typcode eines Objekts variabler Länge an einer gegebenen Adresse:
  2259.   #define typecode_at(addr)  mtypecode(((Varobject)(addr))->GCself)
  2260.   # oder (äquivalent):
  2261.   # define typecode_at(addr)  (((((Varobject)(addr))->header_flags)>>(oint_type_shift%8))&tint_type_mask)
  2262. # Fallunterscheidungen nach diesem müssen statt 'case_symbol:' ein
  2263. # 'case_symbolwithflags:' enthalten.
  2264.   #define case_symbolwithflags  \
  2265.     case symbol_type:                                        \
  2266.     case symbol_type|bit(constant_bit_t):                    \
  2267.     case symbol_type|bit(keyword_bit_t)|bit(constant_bit_t): \
  2268.     case symbol_type|bit(special_bit_t):                     \
  2269.     case symbol_type|bit(special_bit_t)|bit(constant_bit_t): \
  2270.     case symbol_type|bit(special_bit_t)|bit(keyword_bit_t)|bit(constant_bit_t)
  2271.  
  2272. # UP, bestimmt die Länge eines LISP-Objektes variabler Länge (in Bytes).
  2273. # (Sie ist durch varobject_alignment teilbar.)
  2274.   local uintL speicher_laenge (void* addr);
  2275.   # Varobject_aligned_size(HS,ES,C) liefert die Länge eines Objekts variabler
  2276.   # Länge mit HS=Header-Size, ES=Element-Size, C=Element-Count.
  2277.   # Varobject_aligned_size(HS,ES,C) = round_up(HS+ES*C,varobject_alignment) .
  2278.     #define Varobject_aligned_size(HS,ES,C)  \
  2279.       ((ES % varobject_alignment) == 0               \
  2280.        ? # ES ist durch varobject_alignment teilbar  \
  2281.          round_up(HS,varobject_alignment) + (ES)*(C) \
  2282.        : round_up((HS)+(ES)*(C),varobject_alignment) \
  2283.       )
  2284.   # Länge eines Objekts, je nach Typ:
  2285.     #define size_symbol()  # Symbol \
  2286.       round_up( sizeof(symbol_), varobject_alignment)
  2287.     #define size_sbvector(length)  # simple-bit-vector \
  2288.       ( ceiling( (uintL)(length) + 8*offsetofa(sbvector_,data), 8*varobject_alignment ) \
  2289.         * varobject_alignment                                                           \
  2290.       )
  2291.     #define size_sstring(length)  # simple-string \
  2292.       round_up( (uintL)(length) + offsetofa(sstring_,data), varobject_alignment)
  2293.     #define size_svector(length)  # simple-vector \
  2294.       Varobject_aligned_size(offsetofa(svector_,data),sizeof(object),(uintL)(length))
  2295.     #define size_array(size)  # Nicht-simpler Array, mit \
  2296.       # size = Dimensionszahl + (1 falls Fill-Pointer) + (1 falls Displaced-Offset) \
  2297.       Varobject_aligned_size(offsetofa(array_,dims),sizeof(uintL),(uintL)(size))
  2298.     #define size_srecord(length)  # Simple-Record \
  2299.       Varobject_aligned_size(offsetofa(record_,recdata),sizeof(object),(uintL)(length))
  2300.     #define size_xrecord(length,xlength)  # Extended-Record \
  2301.       Varobject_aligned_size(offsetofa(record_,recdata),sizeof(uintB),(sizeof(object)/sizeof(uintB))*(uintL)(length)+(uintL)(xlength))
  2302.     #define size_bignum(length)  # Bignum \
  2303.       Varobject_aligned_size(offsetofa(bignum_,data),sizeof(uintD),(uintL)(length))
  2304.     #ifndef WIDE
  2305.     #define size_ffloat()  # Single-Float \
  2306.       round_up( sizeof(ffloat_), varobject_alignment)
  2307.     #endif
  2308.     #define size_dfloat()  # Double-Float \
  2309.       round_up( sizeof(dfloat_), varobject_alignment)
  2310.     #define size_lfloat(length)  # Long-Float \
  2311.       Varobject_aligned_size(offsetofa(lfloat_,data),sizeof(uintD),(uintL)(length))
  2312.  
  2313. #ifdef SPVW_MIXED
  2314.  
  2315.   local uintL speicher_laenge (addr)
  2316.     var reg2 void* addr;
  2317.     { switch (typecode_at(addr) & ~bit(garcol_bit_t)) # Typ des Objekts
  2318.         { case_symbolwithflags: # Symbol
  2319.             return size_symbol();
  2320.           case_sbvector: # simple-bit-vector
  2321.             return size_sbvector(((Sbvector)addr)->length);
  2322.           case_sstring: # simple-string
  2323.             return size_sstring(((Sstring)addr)->length);
  2324.           case_svector: # simple-vector
  2325.             return size_svector(((Svector)addr)->length);
  2326.           case_array1: case_obvector: case_ostring: case_ovector:
  2327.             # Nicht-simpler Array:
  2328.             { var reg2 uintL size;
  2329.               size = (uintL)(((Array)addr)->rank);
  2330.               if (((Array)addr)->flags & bit(arrayflags_fillp_bit)) { size += 1; }
  2331.               if (((Array)addr)->flags & bit(arrayflags_dispoffset_bit)) { size += 1; }
  2332.               # size = Dimensionszahl + (1 falls Fill-Pointer) + (1 falls Displaced-Offset)
  2333.               return size_array(size);
  2334.             }
  2335.           case_record: # Record
  2336.             if (((Record)addr)->rectype < 0)
  2337.               return size_srecord(((Srecord)addr)->reclength);
  2338.               else
  2339.               return size_xrecord(((Xrecord)addr)->reclength,((Xrecord)addr)->recxlength);
  2340.           case_bignum: # Bignum
  2341.             return size_bignum(((Bignum)addr)->length);
  2342.           #ifndef WIDE
  2343.           case_ffloat: # Single-Float
  2344.             return size_ffloat();
  2345.           #endif
  2346.           case_dfloat: # Double-Float
  2347.             return size_dfloat();
  2348.           case_lfloat: # Long-Float
  2349.             return size_lfloat(((Lfloat)addr)->len);
  2350.           case_machine:
  2351.           case_char:
  2352.           case_subr:
  2353.           case_system:
  2354.           case_fixnum:
  2355.           case_sfloat:
  2356.           #ifdef WIDE
  2357.           case_ffloat:
  2358.           #endif
  2359.             # Das sind direkte Objekte, keine Pointer.
  2360.           /* case_ratio: */
  2361.           /* case_complex: */
  2362.           default:
  2363.             # Das sind keine Objekte variabler Länge.
  2364.             /*NOTREACHED*/ abort();
  2365.     }   }
  2366.  
  2367.   #define var_speicher_laenge_
  2368.   #define calc_speicher_laenge(addr)  speicher_laenge((void*)(addr))
  2369.  
  2370. #endif # SPVW_MIXED
  2371.  
  2372. #ifdef SPVW_PURE
  2373.  
  2374.   # spezielle Funktionen für jeden Typ:
  2375.   inline local uintL speicher_laenge_symbol (addr) # Symbol
  2376.     var reg1 void* addr;
  2377.     { return size_symbol(); }
  2378.   inline local uintL speicher_laenge_sbvector (addr) # simple-bit-vector
  2379.     var reg1 void* addr;
  2380.     { return size_sbvector(((Sbvector)addr)->length); }
  2381.   inline local uintL speicher_laenge_sstring (addr) # simple-string
  2382.     var reg1 void* addr;
  2383.     { return size_sstring(((Sstring)addr)->length); }
  2384.   inline local uintL speicher_laenge_svector (addr) # simple-vector
  2385.     var reg1 void* addr;
  2386.     { return size_svector(((Svector)addr)->length); }
  2387.   inline local uintL speicher_laenge_array (addr) # nicht-simpler Array
  2388.     var reg1 void* addr;
  2389.     { var reg2 uintL size;
  2390.       size = (uintL)(((Array)addr)->rank);
  2391.       if (((Array)addr)->flags & bit(arrayflags_fillp_bit)) { size += 1; }
  2392.       if (((Array)addr)->flags & bit(arrayflags_dispoffset_bit)) { size += 1; }
  2393.       # size = Dimensionszahl + (1 falls Fill-Pointer) + (1 falls Displaced-Offset)
  2394.       return size_array(size);
  2395.     }
  2396.   inline local uintL speicher_laenge_record (addr) # Record
  2397.     var reg1 void* addr;
  2398.     { if (((Record)addr)->rectype < 0)
  2399.         return size_srecord(((Srecord)addr)->reclength);
  2400.         else
  2401.         return size_xrecord(((Xrecord)addr)->reclength,((Xrecord)addr)->recxlength);
  2402.     }
  2403.   inline local uintL speicher_laenge_bignum (addr) # Bignum
  2404.     var reg1 void* addr;
  2405.     { return size_bignum(((Bignum)addr)->length); }
  2406.   #ifndef WIDE
  2407.   inline local uintL speicher_laenge_ffloat (addr) # Single-Float
  2408.     var reg1 void* addr;
  2409.     { return size_ffloat(); }
  2410.   #endif
  2411.   inline local uintL speicher_laenge_dfloat (addr) # Double-Float
  2412.     var reg1 void* addr;
  2413.     { return size_dfloat(); }
  2414.   inline local uintL speicher_laenge_lfloat (addr) # Long-Float
  2415.     var reg1 void* addr;
  2416.     { return size_lfloat(((Lfloat)addr)->len); }
  2417.  
  2418.   # Tabelle von Funktionen:
  2419.   typedef uintL (*speicher_laengen_fun) (void* addr);
  2420.   local speicher_laengen_fun speicher_laengen[heapcount];
  2421.  
  2422.   local void init_speicher_laengen (void);
  2423.   local void init_speicher_laengen()
  2424.     { var reg1 uintL heapnr;
  2425.       for (heapnr=0; heapnr<heapcount; heapnr++)
  2426.         { switch (heapnr)
  2427.             { case_symbol:
  2428.                 speicher_laengen[heapnr] = &speicher_laenge_symbol; break;
  2429.               case_sbvector:
  2430.                 speicher_laengen[heapnr] = &speicher_laenge_sbvector; break;
  2431.               case_sstring:
  2432.                 speicher_laengen[heapnr] = &speicher_laenge_sstring; break;
  2433.               case_svector:
  2434.                 speicher_laengen[heapnr] = &speicher_laenge_svector; break;
  2435.               case_array1: case_obvector: case_ostring: case_ovector:
  2436.                 speicher_laengen[heapnr] = &speicher_laenge_array; break;
  2437.               case_record:
  2438.                 speicher_laengen[heapnr] = &speicher_laenge_record; break;
  2439.               case_bignum:
  2440.                 speicher_laengen[heapnr] = &speicher_laenge_bignum; break;
  2441.               #ifndef WIDE
  2442.               case_ffloat:
  2443.                 speicher_laengen[heapnr] = &speicher_laenge_ffloat; break;
  2444.               #endif
  2445.               case_dfloat:
  2446.                 speicher_laengen[heapnr] = &speicher_laenge_dfloat; break;
  2447.               case_lfloat:
  2448.                 speicher_laengen[heapnr] = &speicher_laenge_lfloat; break;
  2449.               case_machine:
  2450.               case_char:
  2451.               case_subr:
  2452.               case_system:
  2453.               case_fixnum:
  2454.               case_sfloat:
  2455.               #ifdef WIDE
  2456.               case_ffloat:
  2457.               #endif
  2458.                 # Das sind direkte Objekte, keine Pointer.
  2459.               /* case_ratio: */
  2460.               /* case_complex: */
  2461.               default:
  2462.                 # Das sind keine Objekte variabler Länge.
  2463.                 speicher_laengen[heapnr] = (speicher_laengen_fun)&abort; break;
  2464.     }   }   }
  2465.  
  2466.   #define var_speicher_laenge_  \
  2467.     var reg5 speicher_laengen_fun speicher_laenge_ = speicher_laengen[heapnr];
  2468.   #define calc_speicher_laenge(addr)  (*speicher_laenge_)((void*)(addr))
  2469.  
  2470. #endif # SPVW_PURE
  2471.  
  2472. # ------------------------------------------------------------------------------
  2473. #            Hilfsfunktion für den Generational Garbage-Collector
  2474.  
  2475. #ifdef GENERATIONAL_GC # impliziert SPVW_PURE_BLOCKS <==> SINGLEMAP_MEMORY
  2476.                        # oder       SPVW_MIXED_BLOCKS und TRIVIALMAP_MEMORY
  2477.                        # oder       SPVW_MIXED_BLOCKS_OPPOSITE
  2478.  
  2479. local /* uintL */ aint physpagesize;  # = map_pagesize
  2480. local uintL physpageshift; # 2^physpageshift = physpagesize
  2481.  
  2482. typedef enum { handler_failed, handler_immutable, handler_done }
  2483.         handle_fault_result;
  2484. local handle_fault_result handle_fault (aint address);
  2485.  
  2486. # Unterroutine für protection: PROT_NONE -> PROT_READ
  2487. local int handle_read_fault (aint address, physpage_state* physpage);
  2488. local int handle_read_fault(address,physpage)
  2489.   var reg4 aint address;
  2490.   var reg3 physpage_state* physpage;
  2491.   { # Seite auf den Stand des Cache bringen:
  2492.     { var reg2 uintL count = physpage->cache_size;
  2493.       if (count > 0)
  2494.         { var reg1 old_new_pointer* ptr = physpage->cache;
  2495.           #if !defined(NORMAL_MULTIMAP_MEMORY)
  2496.           if (mprotect((MMAP_ADDR_T)address, physpagesize, PROT_READ_WRITE) < 0)
  2497.             return -1;
  2498.           #endif
  2499.           dotimespL(count,count, { *(ptr->p) = ptr->o; ptr++; } );
  2500.     }   }
  2501.     # Seite read-only einblenden:
  2502.     #if !defined(MULTIMAP_MEMORY)
  2503.     if (mprotect((MMAP_ADDR_T)address, physpagesize, PROT_READ) < 0)
  2504.       return -1;
  2505.     #else # MULTIMAP_MEMORY
  2506.     ASSERT(address == upointer(address));
  2507.     #ifdef MINIMAL_MULTIMAP_MEMORY
  2508.     if (mprotect((MMAP_ADDR_T)ThePointer(type_pointer_object(machine_type,address)), physpagesize, PROT_READ) < 0)
  2509.       return -1;
  2510.     if (mprotect((MMAP_ADDR_T)ThePointer(type_pointer_object(imm_type,address)), physpagesize, PROT_READ) < 0)
  2511.       return -1;
  2512.     #else # NORMAL_MULTIMAP_MEMORY
  2513.     { var reg1 uintL type;
  2514.       for (type = 0; type < typecount; type++)
  2515.         if (mem.heapnr_from_type[type] >= 0) # type in MM_TYPECASES aufgeführt?
  2516.           { if (mprotect((MMAP_ADDR_T)ThePointer(type_pointer_object(type,address)), physpagesize, PROT_READ) < 0)
  2517.               return -1;
  2518.     }     }
  2519.     #endif
  2520.     #endif
  2521.     physpage->protection = PROT_READ;
  2522.     return 0;
  2523.   }
  2524.  
  2525. # Unterroutine für protection: PROT_READ -> PROT_READ_WRITE
  2526. local int handle_readwrite_fault (aint address, physpage_state* physpage);
  2527. local int handle_readwrite_fault(address,physpage)
  2528.   var reg2 aint address;
  2529.   var reg1 physpage_state* physpage;
  2530.   { # Seite read-write einblenden:
  2531.     #if !defined(NORMAL_MULTIMAP_MEMORY)
  2532.     if (mprotect((MMAP_ADDR_T)address, physpagesize, PROT_READ_WRITE) < 0)
  2533.       return -1;
  2534.     #else # NORMAL_MULTIMAP_MEMORY
  2535.     ASSERT(address == upointer(address));
  2536.     { var reg1 uintL type;
  2537.       for (type = 0; type < typecount; type++)
  2538.         if (mem.heapnr_from_type[type] >= 0) # type in MM_TYPECASES aufgeführt?
  2539.           switch (type)
  2540.             { default:
  2541.                 if (mprotect((MMAP_ADDR_T)ThePointer(type_pointer_object(type,address)), physpagesize, PROT_READ_WRITE) < 0)
  2542.                   return -1;
  2543.               IMM_TYPECASES # type in IMM_TYPECASES aufgeführt -> bleibt read-only
  2544.                 break;
  2545.     }       }
  2546.     #endif
  2547.     physpage->protection = PROT_READ_WRITE;
  2548.     return 0;
  2549.   }
  2550.  
  2551. local handle_fault_result handle_fault(address)
  2552.   var reg6 aint address;
  2553.   { var reg3 uintL heapnr;
  2554.     var reg5 object obj = as_object((oint)address << oint_addr_shift);
  2555.     var reg4 aint uaddress = canon(address); # hoffentlich = canonaddr(obj);
  2556.     #if defined(MULTIMAP_MEMORY) && defined(IMMUTABLE)
  2557.     var reg7 boolean is_immutable;
  2558.     #ifdef MINIMAL_MULTIMAP_MEMORY
  2559.     is_immutable = (as_oint(obj) & bit(immutable_bit_o) ? TRUE : FALSE);
  2560.     #else
  2561.     switch (typecode(obj))
  2562.       { IMM_TYPECASES # Zugriff auf ein immutables Objekt
  2563.           is_immutable = TRUE; break;
  2564.         default:
  2565.           is_immutable = FALSE; break;
  2566.       }
  2567.     #endif
  2568.     #else
  2569.     #define is_immutable  0
  2570.     #endif
  2571.     #ifdef SPVW_PURE_BLOCKS
  2572.     heapnr = typecode(obj);
  2573.     #elif defined(TRIVIALMAP_MEMORY)
  2574.     heapnr = (uaddress >= mem.heaps[1].heap_gen0_start ? 1 : 0);
  2575.     #else # SPVW_MIXED_BLOCKS_OPPOSITE
  2576.     heapnr = (uaddress >= mem.heaps[1].heap_start ? 1 : 0);
  2577.     #endif
  2578.     if (!is_heap_containing_objects(heapnr)) goto error1;
  2579.     {var reg2 Heap* heap = &mem.heaps[heapnr];
  2580.      if (!((heap->heap_gen0_start <= uaddress) && (uaddress < heap->heap_gen0_end)))
  2581.        { if (is_immutable) return handler_immutable; else goto error2; }
  2582.      if (heap->physpages == NULL)
  2583.        { if (is_immutable) return handler_immutable; else goto error3; }
  2584.      {var reg1 physpage_state* physpage =
  2585.         &heap->physpages[(uaddress>>physpageshift)-(heap->heap_gen0_start>>physpageshift)];
  2586.       switch (physpage->protection)
  2587.         { case PROT_NONE:
  2588.             # protection: PROT_NONE -> PROT_READ
  2589.             if (handle_read_fault(uaddress & -physpagesize,physpage) < 0) goto error4;
  2590.             return handler_done;
  2591.           case PROT_READ:
  2592.             # protection: PROT_READ -> PROT_READ_WRITE
  2593.             if (is_immutable)
  2594.               return handler_immutable; # Schreibzugriff auf ein immutables Objekt
  2595.             if (handle_readwrite_fault(uaddress & -physpagesize,physpage) < 0) goto error5;
  2596.             return handler_done;
  2597.           default:
  2598.             if (is_immutable)
  2599.               return handler_immutable; # Schreibzugriff auf ein immutables Objekt
  2600.             goto error6;
  2601.         }
  2602.       error4:
  2603.         { var int saved_errno = errno;
  2604.           asciz_out(CRLFstring);
  2605.           //: DEUTSCH "handle_fault error4 ! mprotect(0x"
  2606.           //: ENGLISH "handle_fault error4 ! mprotect(0x"
  2607.           //: FRANCAIS "handle_fault error4 ! mprotect(0x"
  2608.           asciz_out(GETTEXT("handle_fault error4 ! mprotect(0x"));
  2609.           hex_out(address & -physpagesize);
  2610.           asciz_out(",0x"); hex_out(physpagesize); asciz_out(",...) -> "); errno_out(saved_errno);
  2611.         }
  2612.         goto error;
  2613.       error5:
  2614.         { var int saved_errno = errno;
  2615.           asciz_out(CRLFstring);
  2616.           //: DEUTSCH "handle_fault error5 ! mprotect(0x"
  2617.           //: ENGLISH "handle_fault error5 ! mprotect(0x"
  2618.           //: FRANCAIS "handle_fault error5 ! mprotect(0x"
  2619.           asciz_out(GETTEXT("handle_fault error5 ! mprotect(0x"));
  2620.           hex_out(address & -physpagesize); asciz_out(",0x");
  2621.           hex_out(physpagesize); asciz_out(","); dez_out(PROT_READ_WRITE);
  2622.           asciz_out(") -> "); errno_out(saved_errno);
  2623.         }
  2624.         goto error;
  2625.       error6:
  2626.         asciz_out(CRLFstring);
  2627.         //: DEUTSCH "handle_fault error6 ! protection = "
  2628.         //: ENGLISH "handle_fault error6 ! protection = "
  2629.         //: FRANCAIS "handle_fault error6 ! protection = "
  2630.         asciz_out(GETTEXT("handle_fault error6 ! protection = "));
  2631.         dez_out(physpage->protection);
  2632.         goto error;
  2633.      }
  2634.      error2:
  2635.        asciz_out(CRLFstring);
  2636.        //: DEUTSCH "handle_fault error2 ! address = 0x"
  2637.        //: ENGLISH "handle_fault error2 ! address = 0x"
  2638.        //: FRANCAIS "handle_fault error2 ! address = 0x"
  2639.        asciz_out(GETTEXT("handle_fault error2 ! address = 0x"));
  2640.        hex_out(address); asciz_out(" not in [0x");
  2641.        hex_out(heap->heap_gen0_start); asciz_out(",0x");
  2642.        hex_out(heap->heap_gen0_end); asciz_out(") !");
  2643.        goto error;
  2644.      error3:
  2645.        asciz_out(CRLFstring);
  2646.        //: DEUTSCH "handle_fault error3 !"
  2647.        //: ENGLISH "handle_fault error3 !"
  2648.        //: FRANCAIS "handle_fault error3 !"
  2649.        asciz_out(GETTEXT("handle_fault error3 !"));
  2650.        goto error;
  2651.     }
  2652.     error1:
  2653.       asciz_out(CRLFstring);
  2654.        //: DEUTSCH "handle_fault error1 !"
  2655.        //: ENGLISH "handle_fault error1 !"
  2656.        //: FRANCAIS "handle_fault error1 !"
  2657.       asciz_out(GETTEXT("handle_fault error1 !"));
  2658.       goto error;
  2659.     error:
  2660.     return handler_failed;
  2661.     #undef is_immutable
  2662.   }
  2663.  
  2664. #ifdef SPVW_MIXED_BLOCKS
  2665. # Systemaufrufe wie read() und write() melden kein SIGSEGV, sondern EFAULT.
  2666. # handle_fault_range(PROT_READ,start,end) macht einen Adreßbereich lesbar,
  2667. # handle_fault_range(PROT_READ_WRITE,start,end) macht ihn schreibbar.
  2668. global boolean handle_fault_range (int prot, aint start_address, aint end_address);
  2669. global boolean handle_fault_range(prot,start_address,end_address)
  2670.   var reg3 int prot;
  2671.   var reg6 aint start_address;
  2672.   var reg5 aint end_address;
  2673.   { 
  2674.     #if defined(MULTIMAP_MEMORY) && defined(IMMUTABLE)
  2675.     var reg8 boolean is_immutable;
  2676.     #ifdef MINIMAL_MULTIMAP_MEMORY
  2677.     is_immutable = (((oint)start_address << oint_addr_shift) & bit(immutable_bit_o) ? TRUE : FALSE);
  2678.     #else # NORMAL_MULTIMAP_MEMORY
  2679.     var reg7 tint type = typecode(as_object((oint)start_address << oint_addr_shift));
  2680.     switch (type)
  2681.       { IMM_TYPECASES # Zugriff auf ein immutables Objekt
  2682.           is_immutable = TRUE; break;
  2683.         default:
  2684.           is_immutable = FALSE; break;
  2685.       }
  2686.     #endif
  2687.     #else
  2688.     #define is_immutable  0
  2689.     #endif
  2690.     start_address = canon(start_address);
  2691.     end_address = canon(end_address);
  2692.     if (!(start_address < end_address)) { return TRUE; }
  2693.    {var reg4 Heap* heap = &mem.heaps[0]; # varobject_heap
  2694.     if ((end_address <= heap->heap_gen0_start) || (heap->heap_gen0_end <= start_address))
  2695.       return TRUE; # nichts zu tun, aber seltsam, daß überhaupt ein Fehler kam
  2696.     if (heap->physpages == NULL)
  2697.       { if (is_immutable) { fehler_immutable(); }
  2698.         return FALSE;
  2699.       }
  2700.     if ((prot & PROT_WRITE) && is_immutable) { fehler_immutable(); }
  2701.     { var reg2 aint address;
  2702.       for (address = start_address & -physpagesize; address < end_address; address += physpagesize)
  2703.         if ((heap->heap_gen0_start <= address) && (address < heap->heap_gen0_end))
  2704.           { var reg1 physpage_state* physpage =
  2705.               &heap->physpages[(address>>physpageshift)-(heap->heap_gen0_start>>physpageshift)];
  2706.             if (!(physpage->protection & PROT_READ) && (prot & PROT_READ_WRITE))
  2707.               # protection: PROT_NONE -> PROT_READ
  2708.               { if (handle_read_fault(address,physpage) < 0)
  2709.                   return FALSE;
  2710.               }
  2711.             if (!(physpage->protection & PROT_WRITE) && (prot & PROT_WRITE))
  2712.               # protection: PROT_READ -> PROT_READ_WRITE
  2713.               { if (handle_readwrite_fault(address,physpage) < 0)
  2714.                   return FALSE;
  2715.               }
  2716.     }     }
  2717.     return TRUE;
  2718.     #undef is_immutable
  2719.   }}
  2720. #endif
  2721.  
  2722. # mprotect() mit Ausstieg im Falle des Scheiterns
  2723. local void xmprotect (aint addr, uintL len, int prot);
  2724. local void xmprotect(addr,len,prot)
  2725.   var reg1 aint addr;
  2726.   var reg2 uintL len;
  2727.   var reg3 int prot;
  2728.   { if (mprotect((MMAP_ADDR_T)addr,len,prot) < 0)
  2729.       { 
  2730.         //: DEUTSCH "mprotect() klappt nicht."
  2731.         //: ENGLISH "mprotect() failed."
  2732.         //: FRANCAIS "mprotect() ne fonctionne pas."
  2733.         asciz_out(GETTEXT("mprotect failed"));
  2734.         errno_out(errno);
  2735.         abort();
  2736.   }   }
  2737.  
  2738. #ifdef MULTIMAP_MEMORY
  2739.   # mehrfaches mprotect() auf alle Mappings eines Adreßbereiches
  2740.   local void xmmprotect (aint addr, uintL len, int prot);
  2741.   local void xmmprotect(addr,len,prot)
  2742.     var reg2 aint addr;
  2743.     var reg3 uintL len;
  2744.     var reg4 int prot;
  2745.     {
  2746.       #ifdef NORMAL_MULTIMAP_MEMORY
  2747.       var reg1 uintL type;
  2748.       for (type = 0; type < typecount; type++)
  2749.         if (mem.heapnr_from_type[type] >= 0) # type in MM_TYPECASES aufgeführt?
  2750.           { xmprotect((aint)ThePointer(type_pointer_object(type,addr)),len,prot); }
  2751.       #else # MINIMAL_MULTIMAP_MEMORY
  2752.       xmprotect((aint)ThePointer(type_pointer_object(machine_type,addr)),len,prot);
  2753.       xmprotect((aint)ThePointer(type_pointer_object(imm_type,addr)),len,prot);
  2754.       #endif
  2755.     }
  2756. #else
  2757.   #define xmmprotect  xmprotect
  2758. #endif
  2759.  
  2760. #ifdef IMMUTABLE # impliziert SPVW_MIXED_BLOCKS_OPPOSITE
  2761.  
  2762. # Implementation von immutable_on() und immutable_off(), basierend auf
  2763. # mprotect(). Nur für Betriebssysteme, die mprotect() auf Shared Memory
  2764. # korrekt implementieren.
  2765.  
  2766.   #undef immutable_off
  2767.   #undef immutable_on
  2768.  
  2769.   # immutable_on_off(...);
  2770.   # modifiziert die Protection der Seiten, die zu den Typcodes in IMM_TYPECASES
  2771.   # gehören.
  2772.   # physpage->protection == PROT_NONE --> mprotect(..,..,PROT_NONE)
  2773.   # physpage->protection == PROT_READ --> mprotect(..,..,PROT_READ)
  2774.   # physpage->protection == PROT_READ_WRITE && flag --> mprotect(..,..,PROT_READ)
  2775.   # physpage->protection == PROT_READ_WRITE && !flag --> mprotect(..,..,PROT_READ_WRITE)
  2776.  
  2777.   # mehrfaches mprotect() auf alle Immutable-Mappings eines Adreßbereiches
  2778.   local void ximmprotect (aint addr, uintL len, int prot);
  2779.   local void ximmprotect(addr,len,prot)
  2780.     var reg2 aint addr;
  2781.     var reg3 uintL len;
  2782.     var reg4 int prot;
  2783.     {
  2784.       #ifdef NORMAL_MULTIMAP_MEMORY
  2785.       var reg1 uintL type;
  2786.       for (type = 0; type < typecount; type++)
  2787.         switch (type)
  2788.           { IMM_TYPECASES # type in IMM_TYPECASES aufgeführt?
  2789.               xmprotect((aint)ThePointer(type_pointer_object(type,addr)),len,prot);
  2790.               break;
  2791.             default:
  2792.               break;
  2793.           }
  2794.       #else # MINIMAL_MULTIMAP_MEMORY
  2795.       xmprotect((aint)ThePointer(type_pointer_object(imm_type,addr)),len,prot);
  2796.       #endif
  2797.     }
  2798.  
  2799.   local void immutable_on_off (int oldprotrw, int newprotrw);
  2800.   local void immutable_on_off(oldprotrw,newprotrw)
  2801.     var reg9 int oldprotrw;
  2802.     var reg8 int newprotrw;
  2803.     { var reg2 aint address;
  2804.       # Minimiere die Anzahl der nötigen mprotect()-Aufrufe: Auf Halde steht
  2805.       # ein mprotect-Aufruf für das Intervall [todo_address,address-1].
  2806.       var reg1 aint todo_address = 0;
  2807.       var reg3 int todo_prot; # Parameter für mprotect-Aufruf, falls !(todo_address==0)
  2808.       #define do_todo()  \
  2809.         { if (todo_address)                                               \
  2810.             { if (todo_address < address)                                 \
  2811.                 ximmprotect(todo_address,address-todo_address,todo_prot); \
  2812.               todo_address = 0;                                           \
  2813.         }   }
  2814.       #define addto_todo(old_prot,new_prot)  \
  2815.         { if (todo_address && (todo_prot == new_prot))            \
  2816.             {} # incrementiere address                            \
  2817.             else                                                  \
  2818.             { do_todo();                                          \
  2819.               if (!(old_prot==new_prot))                          \
  2820.                 { todo_address = address; todo_prot = new_prot; } \
  2821.         }   }
  2822.       # Heap 0 durchlaufen:
  2823.       { var reg7 Heap* heap = &mem.heaps[0];
  2824.         address = heap->heap_gen0_start & -physpagesize;
  2825.         if (heap->physpages == NULL)
  2826.           { addto_todo(oldprotrw,newprotrw); }
  2827.           else
  2828.           { var reg4 physpage_state* physpage = heap->physpages;
  2829.             var reg6 uintL pagecount =
  2830.               (((heap->heap_gen0_end + (physpagesize-1)) & -physpagesize)
  2831.                - (heap->heap_gen0_start & -physpagesize)
  2832.               ) >> physpageshift;
  2833.             var reg5 uintL count;
  2834.             dotimesL(count,pagecount,
  2835.               { switch (physpage->protection)
  2836.                   { case PROT_NONE: addto_todo(PROT_NONE,PROT_NONE); break;
  2837.                     case PROT_READ: addto_todo(PROT_READ,PROT_READ); break;
  2838.                     case PROT_READ_WRITE: addto_todo(oldprotrw,newprotrw); break;
  2839.                     default: abort();
  2840.                   }
  2841.                 physpage++;
  2842.                 address += physpagesize;
  2843.               });
  2844.           }
  2845.         address = (heap->heap_gen0_end + (physpagesize-1)) & -physpagesize;
  2846.         #if 0 # unnötig
  2847.         addto_todo(oldprotrw,newprotrw);
  2848.         address = (heap->heap_end + (physpagesize-1)) & -physpagesize;
  2849.         #endif
  2850.       }
  2851.       # Nun kommen Generation 1 von Heap 0, die große Lücke, Generation 1 von Heap 1.
  2852.       addto_todo(oldprotrw,newprotrw);
  2853.       # Heap 1 durchlaufen:
  2854.       { var reg7 Heap* heap = &mem.heaps[1];
  2855.         #if 0 # unnötig
  2856.         address = heap->heap_start & -physpagesize;
  2857.         addto_todo(oldprotrw,newprotrw);
  2858.         #endif
  2859.         address = heap->heap_gen0_start & -physpagesize;
  2860.         if (heap->physpages == NULL)
  2861.           { addto_todo(oldprotrw,newprotrw); }
  2862.           else
  2863.           { var reg4 physpage_state* physpage = heap->physpages;
  2864.             var reg6 uintL pagecount =
  2865.               (((heap->heap_gen0_end + (physpagesize-1)) & -physpagesize)
  2866.                - (heap->heap_gen0_start & -physpagesize)
  2867.               ) >> physpageshift;
  2868.             var reg5 uintL i;
  2869.             for (i = 0; i < pagecount; i++, physpage++, address += physpagesize)
  2870.               switch (physpage->protection)
  2871.                 { case PROT_NONE: addto_todo(PROT_NONE,PROT_NONE); break;
  2872.                   case PROT_READ: addto_todo(PROT_READ,PROT_READ); break;
  2873.                   case PROT_READ_WRITE: addto_todo(oldprotrw,newprotrw); break;
  2874.                   default: abort();
  2875.                 }
  2876.           }
  2877.         address = (heap->heap_gen0_end + (physpagesize-1)) & -physpagesize;
  2878.       }
  2879.       do_todo();
  2880.     }
  2881.  
  2882.   #define immutable_off()  immutable_on_off(PROT_READ,PROT_READ_WRITE)
  2883.   #define immutable_on()  immutable_on_off(PROT_READ_WRITE,PROT_READ)
  2884.  
  2885. #endif # IMMUTABLE && GENERATIONAL_GC
  2886.  
  2887. # Versionen von malloc() und realloc(), bei denen der Input auch = NULL sein darf:
  2888.   #define xfree(ptr)  \
  2889.     if (!((ptr)==NULL)) free(ptr);
  2890.   #define xrealloc(ptr,size)  \
  2891.     (((ptr)==NULL) ? (void*)malloc(size) : (void*)realloc(ptr,size))
  2892.  
  2893. #endif # GENERATIONAL_GC
  2894.  
  2895. # ------------------------------------------------------------------------------
  2896. #                       Garbage-Collector
  2897.  
  2898. # Gesamtstrategie:
  2899. # 1. Pseudorekursives Markieren durch Setzen von garcol_bit.
  2900. # 2. Verschieben der Objekte fester Länge (Conses u.ä.),
  2901. #    Durchrechnen der Verschiebungen der Objekte variabler Länge.
  2902. # 3. Aktualisieren der Pointer.
  2903. # 4. Durchführen der Verschiebungen der Objekte variabler Länge.
  2904.  
  2905. #ifdef GENERATIONAL_GC
  2906.   # Alte Generation mit Hilfe des Cache auf den aktuellen Stand bringen:
  2907.   local void prepare_old_generation (void);
  2908.   local void prepare_old_generation()
  2909.     { var reg8 uintL heapnr;
  2910.       for (heapnr=0; heapnr<heapcount; heapnr++)
  2911.         if (is_heap_containing_objects(heapnr))
  2912.           { var reg7 Heap* heap = &mem.heaps[heapnr];
  2913.             var reg5 aint gen0_start = heap->heap_gen0_start;
  2914.             var reg6 aint gen0_end = heap->heap_gen0_end;
  2915.             gen0_start = gen0_start & -physpagesize;
  2916.             gen0_end = (gen0_end + (physpagesize-1)) & -physpagesize;
  2917.             if (gen0_start < gen0_end)
  2918.               { if (!(heap->physpages==NULL))
  2919.                   { # Erst read-write einblenden:
  2920.                     xmmprotect(gen0_start, gen0_end-gen0_start, PROT_READ_WRITE);
  2921.                     # Dann den Cache entleeren:
  2922.                     {var reg3 physpage_state* physpage = heap->physpages;
  2923.                      var reg4 uintL physpagecount;
  2924.                      dotimespL(physpagecount, (gen0_end-gen0_start) >> physpageshift,
  2925.                        { if (physpage->protection == PROT_NONE)
  2926.                            { var reg2 uintL count = physpage->cache_size;
  2927.                              if (count > 0)
  2928.                                { var reg1 old_new_pointer* ptr = physpage->cache;
  2929.                                  dotimespL(count,count, { *(ptr->p) = ptr->o; ptr++; } );
  2930.                            }   }
  2931.                          physpage->protection = PROT_READ_WRITE;
  2932.                          xfree(physpage->cache); physpage->cache = NULL;
  2933.                          physpage++;
  2934.                        });
  2935.                      /* xfree(heap->physpages); heap->physpages = NULL; */
  2936.                   } }
  2937.                 # Dann die Lücke zwischen der alten und der neuen Generation so
  2938.                 # füllen, daß die Kompaktierungs-Algorithmen funktionieren:
  2939.                 if (is_cons_heap(heapnr))
  2940.                   { var reg1 object* ptr;
  2941.                     var reg2 uintL count;
  2942.                     #ifdef SPVW_MIXED_BLOCKS_OPPOSITE
  2943.                     ptr = (object*) heap->heap_gen1_end;
  2944.                     count = (heap->heap_gen0_start - heap->heap_gen1_end)/sizeof(object);
  2945.                     #else
  2946.                     ptr = (object*) heap->heap_gen0_end;
  2947.                     count = (heap->heap_gen1_start - heap->heap_gen0_end)/sizeof(object);
  2948.                     #endif
  2949.                     dotimesL(count,count, { *ptr++ = nullobj; } );
  2950.                   }
  2951.               }
  2952.     }     }
  2953. #endif
  2954.  
  2955. # Test, ob ein Objekt obj in der gerade ignorierten Generation liegt.
  2956. # in_old_generation(obj,type,heapnr)
  2957. # > obj: Objekt mit !immediate_type_p(type = typecode(obj))
  2958. # > heapnr: 0 bei Objekt variabler Länge, 1 bei Cons o.ä.
  2959. # < TRUE falls man eine "kleine" Generational GC durchführt und
  2960. #   obj in der alten Generation liegt.
  2961. # Vorsicht bei Symbolen: Ist obj eines der konstanten Symbole, so ist das
  2962. # Ergebnis nicht spezifiziert!
  2963. #ifdef GENERATIONAL_GC
  2964.   #ifdef SPVW_PURE_BLOCKS
  2965.     #define in_old_generation(obj,type,heapnr)  \
  2966.       (canonaddr(obj) < mem.heaps[type].heap_start)
  2967.   #else # SPVW_MIXED_BLOCKS
  2968.     #ifdef SPVW_MIXED_BLOCKS_OPPOSITE
  2969.       #define in_old_generation_0(obj)  \
  2970.         (canonaddr(obj) < mem.varobjects.heap_start)
  2971.       #define in_old_generation_1(obj)  \
  2972.         (canonaddr(obj) >= mem.conses.heap_end)
  2973.       #define in_old_generation_general(obj)  \
  2974.         (in_old_generation_0(obj) || in_old_generation_1(obj))
  2975.       #ifdef GNU
  2976.         # meist ist heapnr konstant, das erlaubt Optimierung:
  2977.         #define in_old_generation(obj,type,heapnr)  \
  2978.           (__builtin_constant_p(heapnr)                                        \
  2979.            ? (heapnr==0 ? in_old_generation_0(obj) : in_old_generation_1(obj)) \
  2980.            : in_old_generation_general(obj)                                    \
  2981.           )
  2982.       #else
  2983.         #define in_old_generation(obj,type,heapnr)  \
  2984.           in_old_generation_general(obj)
  2985.       #endif
  2986.     #else
  2987.       #define in_old_generation(obj,type,heapnr)  \
  2988.         (canonaddr(obj) < mem.heaps[heapnr].heap_start)
  2989.     #endif
  2990.   #endif
  2991. #else
  2992.   #define in_old_generation(obj,type,heapnr)  FALSE
  2993. #endif
  2994.  
  2995. # Markierungs-Unterprogramm
  2996.   # Verfahren: Markierungsroutine ohne Stackbenutzung (d.h.
  2997.   #  nicht "rekursiv") durch Abstieg in die zu markierende
  2998.   #  Struktur mit Pointermodifikation (Pointer werden umgedreht,
  2999.   #  damit sie als "Ariadnefaden" zurück dienen können)
  3000.   # Konvention: ein Objekt X gilt als markiert, wenn
  3001.   #  - ein Objekt variabler Länge: Bit garcol_bit,(X) gesetzt
  3002.   #  - ein Zwei-Pointer-Objekt: Bit garcol_bit,(X) gesetzt
  3003.   #  - ein SUBR/FSUBR: Bit garcol_bit,(X+const_offset) gesetzt
  3004.   #  - Character, Short-Float, Fixnum etc.: stets.
  3005.   local void gc_mark (object obj);
  3006.   # Markierungsbit an einer Adresse setzen: mark(addr);
  3007.     #define mark(addr)  *(oint*)(addr) |= wbit(garcol_bit_o)
  3008.   # Markierungsbit an einer Adresse setzen: unmark(addr);
  3009.     #define unmark(addr)  *(oint*)(addr) &= ~wbit(garcol_bit_o)
  3010.   # Markierungsbit an einer Adresse abfragen: if (marked(addr)) ...
  3011.     #ifdef fast_mtypecode
  3012.       #define marked(addr)  (mtypecode(*(object*)(addr)) & bit(garcol_bit_t))
  3013.     #else
  3014.       #if !(garcol_bit_o == 32-1) || defined(WIDE)
  3015.         #define marked(addr)  (*(oint*)(addr) & wbit(garcol_bit_o))
  3016.       #else # garcol_bit_o = 32-1 = Vorzeichenbit
  3017.         #define marked(addr)  (*(sintL*)(addr) < 0)
  3018.       #endif
  3019.     #endif
  3020.   # Markierungsbit in einem Objekt setzen:
  3021.     #define with_mark_bit(obj)  as_object(as_oint(obj) | wbit(garcol_bit_o))
  3022.   # Markierungsbit in einem Objekt löschen:
  3023.     #define without_mark_bit(obj)  as_object(as_oint(obj) & ~wbit(garcol_bit_o))
  3024.   local void gc_mark(obj)
  3025.     var reg4 object obj;
  3026.     { var reg2 object dies = obj; # aktuelles Objekt
  3027.       var reg3 object vorg = nullobj; # Vorgänger-Objekt
  3028.       down: # Einsprung für Abstieg.
  3029.             # dies = zu markierendes Objekt, vorg = sein Vorgänger
  3030.             switch (typecode(dies))
  3031.               { case_cons:
  3032.                 case_ratio:
  3033.                 case_complex:
  3034.                   # Objekt mit genau 2 Pointern (Cons u.ä.)
  3035.                   if (in_old_generation(dies,typecode(dies),1))
  3036.                     goto up; # ältere Generation nicht markieren
  3037.                   { var reg1 oint* dies_ = (oint*)ThePointer(dies);
  3038.                     if (marked(dies_)) goto up; # markiert -> hoch
  3039.                     mark(dies_); # markieren
  3040.                   }
  3041.                   { var reg1 object dies_ = objectplus(dies,(soint)(sizeof(cons_)-sizeof(object))<<(oint_addr_shift-addr_shift));
  3042.                                           # mit dem letzten Pointer anfangen
  3043.                     var reg1 object nachf = *(object*)ThePointer(dies_); # Nachfolger
  3044.                     *(object*)ThePointer(dies_) = vorg; # Vorgänger eintragen
  3045.                     vorg = dies_; # aktuelles Objekt wird neuer Vorgänger
  3046.                     dies = nachf; # Nachfolger wird aktuelles Objekt
  3047.                     goto down; # und absteigen
  3048.                   }
  3049.                 case_symbol: # Symbol
  3050.                   if (in_old_generation(dies,typecode(dies),0))
  3051.                     goto up; # ältere Generation (dazu zählt auch die symbol_tab!) nicht markieren
  3052.                   { var reg1 oint* dies_ = (oint*)(TheSymbol(dies));
  3053.                     if (marked(dies_)) goto up; # markiert -> hoch
  3054.                     mark(dies_); # markieren
  3055.                     mark(pointerplus(dies_,symbol_objects_offset)); # ersten Pointer markieren
  3056.                   }
  3057.                   { var reg1 object dies_ = objectplus(dies,(soint)(sizeof(symbol_)-sizeof(object))<<(oint_addr_shift-addr_shift));
  3058.                                           # mit dem letzten Pointer anfangen
  3059.                     var reg1 object nachf = *(object*)(TheSymbol(dies_)); # Nachfolger
  3060.                     *(object*)(TheSymbol(dies_)) = vorg; # Vorgänger eintragen
  3061.                     vorg = dies_; # aktuelles Objekt wird neuer Vorgänger
  3062.                     dies = nachf; # Nachfolger wird aktuelles Objekt
  3063.                     goto down; # und absteigen
  3064.                   }
  3065.                 case_sbvector: # simple-bit-vector
  3066.                 case_sstring: # simple-string
  3067.                 case_bignum: # Bignum
  3068.                 #ifndef WIDE
  3069.                 case_ffloat: # Single-Float
  3070.                 #endif
  3071.                 case_dfloat: # Double-Float
  3072.                 case_lfloat: # Long-Float
  3073.                   # Objekte variabler Länge, die keine Pointer enthalten:
  3074.                   if (in_old_generation(dies,typecode(dies),0))
  3075.                     goto up; # ältere Generation nicht markieren
  3076.                   mark(TheVarobject(dies)); # markieren
  3077.                   goto up; # und hoch
  3078.                 case_array1: case_obvector: case_ostring: case_ovector:
  3079.                   # Arrays, die nicht simple sind:
  3080.                   if (in_old_generation(dies,typecode(dies),0))
  3081.                     goto up; # ältere Generation nicht markieren
  3082.                   { var reg1 oint* dies_ = (oint*)TheArray(dies);
  3083.                     if (marked(dies_)) goto up; # markiert -> hoch
  3084.                     mark(dies_); # markieren
  3085.                   }
  3086.                   { var reg1 object dies_ = objectplus(dies,(soint)(array_data_offset)<<(oint_addr_shift-addr_shift));
  3087.                                           # Datenvektor ist der erste und einzige Pointer
  3088.                     var reg1 object nachf = *(object*)TheArray(dies_); # Nachfolger
  3089.                     *(object*)TheArray(dies_) = vorg; # Vorgänger eintragen
  3090.                     mark(TheArray(dies_)); # ersten und einzigen Pointer markieren
  3091.                     vorg = dies_; # aktuelles Objekt wird neuer Vorgänger
  3092.                     dies = nachf; # Nachfolger wird aktuelles Objekt
  3093.                     goto down; # und absteigen
  3094.                   }
  3095.                 case_svector: # simple-vector
  3096.                   if (in_old_generation(dies,typecode(dies),0))
  3097.                     goto up; # ältere Generation nicht markieren
  3098.                   { var reg1 oint* dies_ = (oint*)TheSvector(dies);
  3099.                     if (marked(dies_)) goto up; # markiert -> hoch
  3100.                     mark(dies_); # markieren
  3101.                   }
  3102.                   { var reg1 uintL len = TheSvector(dies)->length;
  3103.                     if (len==0) goto up; # Länge 0: wieder hoch
  3104.                    {var reg1 object dies_ = objectplus(dies,
  3105.                                               ((soint)offsetofa(svector_,data) << (oint_addr_shift-addr_shift))
  3106.                                               + (len * (soint)sizeof(object) << (oint_addr_shift-addr_shift))
  3107.                                               - ((soint)sizeof(object) << (oint_addr_shift-addr_shift)) );
  3108.                                               # mit dem letzten Pointer anfangen
  3109.                     var reg1 object nachf = *(object*)TheSvector(dies_); # Nachfolger
  3110.                     *(object*)TheSvector(dies_) = vorg; # Vorgänger eintragen
  3111.                     mark(&TheSvector(dies)->data[0]); # ersten Pointer markieren
  3112.                     vorg = dies_; # aktuelles Objekt wird neuer Vorgänger
  3113.                     dies = nachf; # Nachfolger wird aktuelles Objekt
  3114.                     goto down; # und absteigen
  3115.                   }}
  3116.                 case_record:
  3117.                   # Record:
  3118.                   if (in_old_generation(dies,typecode(dies),0))
  3119.                     goto up; # ältere Generation nicht markieren
  3120.                   { var reg1 oint* dies_ = (oint*)TheRecord(dies);
  3121.                     if (marked(dies_)) goto up; # markiert -> hoch
  3122.                     mark(dies_); # markieren
  3123.                   }
  3124.                   { var reg1 uintL len = Record_length(dies);
  3125.                     if (len==0) goto up; # Länge 0: wieder hoch
  3126.                    {var reg1 object dies_ = objectplus(dies,
  3127.                                               ((soint)offsetofa(record_,recdata) << (oint_addr_shift-addr_shift))
  3128.                                             + (len * (soint)sizeof(object) << (oint_addr_shift-addr_shift))
  3129.                                             - ((soint)sizeof(object) << (oint_addr_shift-addr_shift)) );
  3130.                                             # mit dem letzten Pointer anfangen
  3131.                     var reg1 object nachf = *(object*)TheRecord(dies_); # Nachfolger
  3132.                     *(object*)TheRecord(dies_) = vorg; # Vorgänger eintragen
  3133.                     mark(&TheRecord(dies)->recdata[0]); # ersten Pointer markieren
  3134.                     vorg = dies_; # aktuelles Objekt wird neuer Vorgänger
  3135.                     dies = nachf; # Nachfolger wird aktuelles Objekt
  3136.                     goto down; # und absteigen
  3137.                   }}
  3138.                 case_machine: # Maschinenadresse
  3139.                 case_char: # Character
  3140.                 case_system: # Frame-Pointer, Read-Label, System
  3141.                 case_fixnum: # Fixnum
  3142.                 case_sfloat: # Short-Float
  3143.                 #ifdef WIDE
  3144.                 case_ffloat: # Single-Float
  3145.                 #endif
  3146.                   # Das sind direkte Objekte, keine Pointer.
  3147.                   goto up;
  3148.                 case_subr: # SUBR
  3149.                   { var reg1 oint* dies_ = (oint*)pointerplus(TheSubr(dies),subr_const_offset);
  3150.                     if (marked(dies_)) goto up; # markiert -> hoch
  3151.                     # markieren später
  3152.                   }
  3153.                   { var reg1 object dies_ = objectplus(dies,
  3154.                                               (soint)(subr_const_offset+(subr_const_anz-1)*sizeof(object))<<(oint_addr_shift-addr_shift));
  3155.                                               # mit dem letzten Pointer anfangen
  3156.                     var reg1 object nachf = *(object*)TheSubr(dies_); # Nachfolger
  3157.                     *(object*)TheSubr(dies_) = vorg; # Vorgänger eintragen
  3158.                     # ersten Pointer (und damit das SUBR selbst) markieren:
  3159.                     mark(pointerplus(TheSubr(dies),subr_const_offset));
  3160.                     vorg = dies_; # aktuelles Objekt wird neuer Vorgänger
  3161.                     dies = nachf; # Nachfolger wird aktuelles Objekt
  3162.                     goto down; # und absteigen
  3163.                   }
  3164.                 default:
  3165.                   # Das sind keine Objekte.
  3166.                   /*NOTREACHED*/ abort();
  3167.               }
  3168.       up:   # Einsprung zum Aufstieg.
  3169.             # dies = gerade markiertes Objekt, vorg = sein Vorgänger
  3170.             if (eq(vorg,nullobj)) # Endekennzeichen erreicht?
  3171.               return; # ja -> fertig
  3172.             if (!marked(ThePointer(vorg))) # schon durch?
  3173.               # nein ->
  3174.               # nächstes Element weiter links (Komme von up, gehe nach down)
  3175.               # dies = gerade markiertes Objekt, in *vorg einzutragen
  3176.               { var reg3 object vorvorg = *(object*)ThePointer(vorg); # alter Vorgänger
  3177.                 *(object*)ThePointer(vorg) = dies; # Komponente zurückschreiben
  3178.                 vorg = objectplus(vorg,-(soint)(sizeof(object))<<(oint_addr_shift-addr_shift)); # zur nächsten Komponente
  3179.                 if (marked(ThePointer(vorg))) # dort schon markiert?
  3180.                   { dies = # nächste Komponente, ohne Markierung
  3181.                            without_mark_bit(*(object*)ThePointer(vorg));
  3182.                     *(object*)ThePointer(vorg) = # alten Vorgänger weiterschieben, dabei Markierung erneuern
  3183.                            with_mark_bit(vorvorg);
  3184.                   }
  3185.                   else
  3186.                   { dies = *(object*)ThePointer(vorg); # nächste Komponente, ohne Markierung
  3187.                     *(object*)ThePointer(vorg) = vorvorg; # alten Vorgänger weiterschieben
  3188.                   }
  3189.                 goto down;
  3190.               }
  3191.             # schon durch -> wieder aufsteigen
  3192.             { var reg3 object vorvorg = # alten Vorgänger holen, ohne Markierungsbit
  3193.                                         without_mark_bit(*(object*)ThePointer(vorg));
  3194.               *(object*)ThePointer(vorg) = dies; # erste Komponente zurückschreiben
  3195.               switch (typecode(vorg))
  3196.                 { case_cons:
  3197.                   case_ratio:
  3198.                   case_complex:
  3199.                     # Objekt mit genau 2 Pointern (Cons u.ä.)
  3200.                     { mark(ThePointer(vorg)); # wieder markieren
  3201.                       dies = vorg; # Cons wird aktuelles Objekt
  3202.                       vorg = vorvorg; goto up; # weiter aufsteigen
  3203.                     }
  3204.                   case_symbol:
  3205.                     # Symbol
  3206.                     { dies = objectplus(vorg,-(soint)symbol_objects_offset<<(oint_addr_shift-addr_shift)); # Symbol wird aktuelles Objekt
  3207.                       vorg = vorvorg; goto up; # weiter aufsteigen
  3208.                     }
  3209.                   case_svector:
  3210.                     # simple-vector mit mindestens 1 Komponente
  3211.                     { dies = objectplus(vorg,-(soint)offsetofa(svector_,data)<<(oint_addr_shift-addr_shift)); # Svector wird aktuelles Objekt
  3212.                       vorg = vorvorg; goto up; # weiter aufsteigen
  3213.                     }
  3214.                   case_array1: case_obvector: case_ostring: case_ovector:
  3215.                     # Nicht-simple Arrays:
  3216.                     { dies = objectplus(vorg,-(soint)array_data_offset<<(oint_addr_shift-addr_shift)); # Array wird aktuelles Objekt
  3217.                       vorg = vorvorg; goto up; # weiter aufsteigen
  3218.                     }
  3219.                   case_record:
  3220.                     # Record:
  3221.                     { dies = objectplus(vorg,-(soint)offsetofa(record_,recdata)<<(oint_addr_shift-addr_shift)); # Record wird aktuelles Objekt
  3222.                       vorg = vorvorg; goto up; # weiter aufsteigen
  3223.                     }
  3224.                   case_subr: # SUBR
  3225.                     { mark(TheSubr(vorg)); # wieder markieren
  3226.                       dies = objectplus(vorg,-(soint)subr_const_offset<<(oint_addr_shift-addr_shift)); # SUBR wird aktuelles Objekt
  3227.                       vorg = vorvorg; goto up; # weiter aufsteigen
  3228.                     }
  3229.                   case_machine: # Maschinenadresse
  3230.                   case_char: # Character
  3231.                   case_system: # Frame-Pointer, Read-Label, System
  3232.                   case_fixnum: # Fixnum
  3233.                   case_sfloat: # Short-Float
  3234.                   #ifdef WIDE
  3235.                   case_ffloat: # Single-Float
  3236.                   #endif
  3237.                     # Das sind direkte Objekte, keine Pointer.
  3238.                   case_sbvector: # simple-bit-vector
  3239.                   case_sstring: # simple-string
  3240.                   case_bignum: # Bignum
  3241.                   #ifndef WIDE
  3242.                   case_ffloat: # Single-Float
  3243.                   #endif
  3244.                   case_dfloat: # Double-Float
  3245.                   case_lfloat: # Long-Float
  3246.                     # Objekte variabler Länge, die keine Pointer enthalten.
  3247.                   default:
  3248.                     # Das sind keine Objekte.
  3249.                     /*NOTREACHED*/ abort();
  3250.     }       }   }
  3251.  
  3252. #ifdef GENERATIONAL_GC
  3253.  
  3254. # Nummer der Generation, die bereinigt wird.
  3255. # 0 : alles (Generation 0 + Generation 1)
  3256. # 1 : nur Generation 1
  3257. local uintC generation;
  3258.  
  3259. # Sparsames Durchlaufen durch alle Pointer einer physikalischen Seite:
  3260. # walk_physpage(heapnr,physpage,pageend,heapend,walkfun);
  3261. # Hierfür ist wesentlich, daß varobject_alignment ein Vielfaches
  3262. # von sizeof(object) ist.
  3263.   #define walk_physpage(heapnr,physpage,pageend,heapend,walkfun)  \
  3264.     { { var reg2 uintC count = physpage->continued_count;             \
  3265.         if (count > 0)                                                \
  3266.           { var reg1 object* ptr = physpage->continued_addr;          \
  3267.             dotimespC(count,count, { walkfun(*ptr); ptr++; } );       \
  3268.       }   }                                                           \
  3269.       { var reg4 aint physpage_end =                                  \
  3270.           (pageend < heapend ? pageend : heapend);                    \
  3271.         walk_area(heapnr,physpage->firstobject,physpage_end,walkfun); \
  3272.     } }
  3273.   #ifdef SPVW_PURE
  3274.     #define walk_area(heapnr,physpage_start,physpage_end,walkfun)  \
  3275.       { var reg3 aint objptr = physpage_start;                          \
  3276.         switch (heapnr)                                                 \
  3277.           { case_cons:                                                  \
  3278.             case_ratio:                                                 \
  3279.             case_complex:                                               \
  3280.               # Objekt mit genau 2 Pointern (Cons u.ä.)                 \
  3281.               { var reg1 object* ptr = (object*)objptr;                 \
  3282.                 while ((aint)ptr < physpage_end)                        \
  3283.                   { walkfun(*ptr); ptr++; }                             \
  3284.               }                                                         \
  3285.               break;                                                    \
  3286.             case_symbol: # Symbol                                       \
  3287.               while (objptr < physpage_end)                             \
  3288.                 { var reg1 object* ptr = (object*)(objptr+symbol_objects_offset); \
  3289.                   var reg2 uintC count;                                 \
  3290.                   dotimespC(count,(sizeof(symbol_)-symbol_objects_offset)/sizeof(object), \
  3291.                     { if ((aint)ptr < physpage_end)                     \
  3292.                         { walkfun(*ptr); ptr++; }                       \
  3293.                         else break;                                     \
  3294.                     });                                                 \
  3295.                   objptr += size_symbol();                              \
  3296.                 }                                                       \
  3297.               break;                                                    \
  3298.             case_array1: case_obvector: case_ostring: case_ovector:     \
  3299.               # Arrays, die nicht simple sind:                          \
  3300.               while (objptr < physpage_end)                             \
  3301.                 { var reg1 object* ptr = &((Array)objptr)->data;        \
  3302.                   if ((aint)ptr < physpage_end)                         \
  3303.                     { walkfun(*ptr); }                                  \
  3304.                   objptr += speicher_laenge_array((Array)objptr);       \
  3305.                 }                                                       \
  3306.               break;                                                    \
  3307.             case_svector: # simple-vector                               \
  3308.               while (objptr < physpage_end)                             \
  3309.                 { var reg2 uintL count = ((Svector)objptr)->length;     \
  3310.                   var reg1 object* ptr = &((Svector)objptr)->data[0];   \
  3311.                   objptr += size_svector(count);                        \
  3312.                   dotimesL(count,count,                                 \
  3313.                     { if ((aint)ptr < physpage_end)                     \
  3314.                         { walkfun(*ptr); ptr++; }                       \
  3315.                         else break;                                     \
  3316.                     });                                                 \
  3317.                 }                                                       \
  3318.               break;                                                    \
  3319.             case_record: # Record                                       \
  3320.               while (objptr < physpage_end)                             \
  3321.                 { var reg2 uintC count;                                 \
  3322.                   var reg1 object* ptr = &((Record)objptr)->recdata[0]; \
  3323.                   objptr += (((Record)objptr)->rectype < 0              \
  3324.                              ? (count = ((Srecord)objptr)->reclength, size_srecord(count)) \
  3325.                              : (count = ((Xrecord)objptr)->reclength, size_xrecord(count,((Xrecord)objptr)->recxlength)) \
  3326.                             );                                          \
  3327.                   dotimesC(count,count,                                 \
  3328.                     { if ((aint)ptr < physpage_end)                     \
  3329.                         { walkfun(*ptr); ptr++; }                       \
  3330.                         else break;                                     \
  3331.                     });                                                 \
  3332.                 }                                                       \
  3333.               break;                                                    \
  3334.             default:                                                    \
  3335.               # Solche Objekte kommen nicht vor.                        \
  3336.               /*NOTREACHED*/ abort();                                   \
  3337.       }   }
  3338.   #endif
  3339.   #ifdef SPVW_MIXED
  3340.     #define walk_area(heapnr,physpage_start,physpage_end,walkfun)  \
  3341.       { var reg3 aint objptr = physpage_start;                                   \
  3342.         switch (heapnr)                                                          \
  3343.           { case 0: # Objekte variabler Länge                                    \
  3344.               while (objptr < physpage_end)                                      \
  3345.                 { switch (typecode_at(objptr)) # Typ des nächsten Objekts        \
  3346.                     { case_symbolwithflags: # Symbol                             \
  3347.                         { var reg1 object* ptr = (object*)(objptr+symbol_objects_offset); \
  3348.                           var reg2 uintC count;                                  \
  3349.                           dotimespC(count,(sizeof(symbol_)-symbol_objects_offset)/sizeof(object), \
  3350.                             { if ((aint)ptr < physpage_end)                      \
  3351.                                 { walkfun(*ptr); ptr++; }                        \
  3352.                                 else break;                                      \
  3353.                             });                                                  \
  3354.                           objptr += size_symbol();                               \
  3355.                         }                                                        \
  3356.                         break;                                                   \
  3357.                       case_array1: case_obvector: case_ostring: case_ovector:    \
  3358.                         # Arrays, die nicht simple sind:                         \
  3359.                         { var reg1 object* ptr = &((Array)objptr)->data;         \
  3360.                           if ((aint)ptr < physpage_end)                          \
  3361.                             { walkfun(*ptr); }                                   \
  3362.                           objptr += speicher_laenge((Array)objptr);              \
  3363.                         }                                                        \
  3364.                         break;                                                   \
  3365.                       case_svector: # simple-vector                              \
  3366.                         { var reg2 uintL count = ((Svector)objptr)->length;      \
  3367.                           var reg1 object* ptr = &((Svector)objptr)->data[0];    \
  3368.                           objptr += size_svector(count);                         \
  3369.                           dotimesL(count,count,                                  \
  3370.                             { if ((aint)ptr < physpage_end)                      \
  3371.                                 { walkfun(*ptr); ptr++; }                        \
  3372.                                 else break;                                      \
  3373.                             });                                                  \
  3374.                         }                                                        \
  3375.                         break;                                                   \
  3376.                       case_record: # Record                                      \
  3377.                         { var reg2 uintC count;                                  \
  3378.                           var reg1 object* ptr = &((Record)objptr)->recdata[0];  \
  3379.                           objptr += (((Record)objptr)->rectype < 0               \
  3380.                                      ? (count = ((Srecord)objptr)->reclength, size_srecord(count)) \
  3381.                                      : (count = ((Xrecord)objptr)->reclength, size_xrecord(count,((Xrecord)objptr)->recxlength)) \
  3382.                                     );                                           \
  3383.                           dotimesC(count,count,                                  \
  3384.                             { if ((aint)ptr < physpage_end)                      \
  3385.                                 { walkfun(*ptr); ptr++; }                        \
  3386.                                 else break;                                      \
  3387.                             });                                                  \
  3388.                         }                                                        \
  3389.                         break;                                                   \
  3390.                       default: # simple-bit-vector, simple-string, bignum, float \
  3391.                         objptr += speicher_laenge((Varobject)objptr);            \
  3392.                         break;                                                   \
  3393.                 }   }                                                            \
  3394.               break;                                                             \
  3395.             case 1: # 2-Pointer-Objekte                                          \
  3396.               { var reg1 object* ptr = (object*)objptr;                          \
  3397.                 while ((aint)ptr < physpage_end)                                 \
  3398.                   { walkfun(*ptr); ptr++; }                                      \
  3399.               }                                                                  \
  3400.               break;                                                             \
  3401.             default: /*NOTREACHED*/ abort();                                     \
  3402.       }   }
  3403.   #endif
  3404. # Dasselbe als Funktion:
  3405. # walk_physpage_(heapnr,physpage,pageend,heapend,walkstep);
  3406. # bzw. walk_area_(heapnr,physpage_start,physpage_end,walkstep);
  3407.   typedef void (*walkstep_fun)(object* ptr);
  3408.   local void walk_physpage_ (uintL heapnr, physpage_state* physpage, aint pageend, aint heapend, walkstep_fun walkstep);
  3409.   local void walk_physpage_(heapnr,physpage,pageend,heapend,walkstep)
  3410.     var reg8 uintL heapnr;
  3411.     var reg6 physpage_state* physpage;
  3412.     var reg7 aint pageend;
  3413.     var reg7 aint heapend;
  3414.     var reg5 walkstep_fun walkstep;
  3415.     {
  3416.       #define walkstep1(obj)  walkstep(&(obj))
  3417.       walk_physpage(heapnr,physpage,pageend,heapend,walkstep1);
  3418.       #undef walkstep1
  3419.     }
  3420.   local void walk_area_ (uintL heapnr, aint physpage_start, aint physpage_end, walkstep_fun walkstep);
  3421.   local void walk_area_(heapnr,physpage_start,physpage_end,walkstep)
  3422.     var reg6 uintL heapnr;
  3423.     var reg7 aint physpage_start;
  3424.     var reg4 aint physpage_end;
  3425.     var reg5 walkstep_fun walkstep;
  3426.     {
  3427.       #define walkstep1(obj)  walkstep(&(obj))
  3428.       walk_area(heapnr,physpage_start,physpage_end,walkstep1);
  3429.       #undef walkstep1
  3430.     }
  3431.  
  3432.   local void gc_mark_at (object* ptr);
  3433.   local void gc_mark_at(ptr)
  3434.     var reg1 object* ptr;
  3435.     { gc_mark(*ptr); }
  3436.  
  3437. #endif
  3438.  
  3439. # Markierungsphase:
  3440.   # Es werden alle "aktiven" Strukturen markiert.
  3441.   # Aktiv ist alles, was erreichbar ist
  3442.   # - vom LISP-Stack aus  oder
  3443.   # - bei Generational-GC: von der alten Generation aus  oder
  3444.   # - als Programmkonstanten (dazu gehört auch die Liste aller Packages).
  3445.   local void gc_markphase (void);
  3446.   local void gc_markphase()
  3447.     { { var reg1 object* objptr = &STACK_0; # Pointer, der durch den STACK läuft
  3448.         until (eq(*objptr,nullobj)) # bis STACK zu Ende ist:
  3449.           { if ( *((oint*)objptr) & wbit(frame_bit_o) ) # Beginnt hier ein Frame?
  3450.              { if (( *((oint*)objptr) & wbit(skip2_bit_o) ) == 0) # Ohne skip2-Bit?
  3451.                 objptr skipSTACKop 2; # ja -> um 2 weiterrücken
  3452.                 else
  3453.                 objptr skipSTACKop 1; # nein -> um 1 weiterrücken
  3454.              }
  3455.              else
  3456.              { # normales Objekt, markieren:
  3457.                var reg2 object obj = *objptr;
  3458.                switch (typecode(obj)) # evtl. Symbol-Flags entfernen
  3459.                  { case_symbolflagged:
  3460.                      #ifndef NO_symbolflags
  3461.                      obj = symbol_without_flags(obj);
  3462.                      #endif
  3463.                    default: break;
  3464.                  }
  3465.                gc_mark(obj);
  3466.                objptr skipSTACKop 1; # weiterrücken
  3467.       }   }  }
  3468.       #ifdef GENERATIONAL_GC
  3469.       # Alte Generation markieren, wobei man sie sehr sparsam durchläuft:
  3470.       if (generation > 0)
  3471.         { var reg7 uintL heapnr;
  3472.           for (heapnr=0; heapnr<heapcount; heapnr++)
  3473.             if (is_heap_containing_objects(heapnr)) # Objekte, die keine Pointer enthalten,
  3474.                                                     # braucht man nicht zu durchlaufen.
  3475.               { var reg6 Heap* heap = &mem.heaps[heapnr];
  3476.                 var reg4 aint gen0_start = heap->heap_gen0_start;
  3477.                 var reg5 aint gen0_end = heap->heap_gen0_end;
  3478.                 if (gen0_start < gen0_end)
  3479.                   if (heap->physpages==NULL)
  3480.                     { walk_area_(heapnr,gen0_start,gen0_end,gc_mark_at); } # fallback
  3481.                     else
  3482.                     { var reg3 physpage_state* physpage = heap->physpages;
  3483.                       gen0_start &= -physpagesize;
  3484.                       do { gen0_start += physpagesize;
  3485.                            if ((physpage->protection == PROT_NONE)
  3486.                                || (physpage->protection == PROT_READ)
  3487.                               )
  3488.                              # Cache ausnutzen, gecachte Pointer markieren:
  3489.                              { var reg2 uintL count = physpage->cache_size;
  3490.                                if (count > 0)
  3491.                                  { var reg1 old_new_pointer* ptr = physpage->cache;
  3492.                                    dotimespL(count,count, { gc_mark(ptr->o); ptr++; } );
  3493.                              }   }
  3494.                              else
  3495.                              # ganzen Page-Inhalt markieren:
  3496.                              { walk_physpage_(heapnr,physpage,gen0_start,gen0_end,gc_mark_at); }
  3497.                            physpage++;
  3498.                          }
  3499.                          while (gen0_start < gen0_end);
  3500.         }     }     }
  3501.       #endif
  3502.       # Alle Programmkonstanten markieren:
  3503.       for_all_subrs( gc_mark(subr_tab_ptr_as_object(ptr)); ); # subr_tab durchgehen
  3504.       #if !defined(GENERATIONAL_GC)
  3505.       for_all_constsyms( gc_mark(symbol_tab_ptr_as_object(ptr)); ); # symbol_tab durchgehen
  3506.       #else
  3507.       # gc_mark() betrachtet wegen des Macros in_old_generation() alle konstanten
  3508.       # Symbole als zur alten Generation zugehörig und durchläuft sie nicht.
  3509.       for_all_constsyms( # symbol_tab durchgehen
  3510.         { gc_mark(ptr->symvalue);
  3511.           gc_mark(ptr->symfunction);
  3512.           gc_mark(ptr->proplist);
  3513.           gc_mark(ptr->pname);
  3514.           gc_mark(ptr->homepackage);
  3515.         });
  3516.       #endif
  3517.       for_all_constobjs( gc_mark(*objptr); ); # object_tab durchgehen
  3518.     }
  3519.  
  3520. # UP: Stellt fest, ob ein Objekt noch "lebt".
  3521. # D.h. ob nach der Markierungsphase das Markierungsbit gesetzt ist.
  3522.   local boolean alive (object obj);
  3523.   local boolean alive(obj)
  3524.     var reg1 object obj;
  3525.     { switch (typecode(obj)) # je nach Typ
  3526.         { case_cons: # Cons
  3527.           case_ratio: # Ratio
  3528.           case_complex: # Complex
  3529.             if (in_old_generation(obj,typecode(obj),1)) return TRUE;
  3530.             if (marked(ThePointer(obj))) return TRUE; else return FALSE;
  3531.           case_symbol: # Symbol
  3532.           case_array: # Array
  3533.           case_bignum: # Bignum
  3534.           #ifndef WIDE
  3535.           case_ffloat: # Single-Float
  3536.           #endif
  3537.           case_dfloat: # Double-Float
  3538.           case_lfloat: # Long-Float
  3539.           case_record: # Record
  3540.             if (in_old_generation(obj,typecode(obj),0)) return TRUE;
  3541.             if (marked(ThePointer(obj))) return TRUE; else return FALSE;
  3542.           case_subr: # Subr
  3543.             if (marked((oint*)pointerplus(TheSubr(obj),subr_const_offset)))
  3544.               return TRUE; else return FALSE;
  3545.           case_machine: # Maschinenpointer
  3546.           case_char: # Character
  3547.           case_system: # Frame-pointer, Read-label, system
  3548.           case_fixnum: # Fixnum
  3549.           case_sfloat: # Short-Float
  3550.           #ifdef WIDE
  3551.           case_ffloat: # Single-Float
  3552.           #endif
  3553.             return TRUE;
  3554.           default:
  3555.             # Das sind keine Objekte.
  3556.             /*NOTREACHED*/ abort();
  3557.     }   }
  3558.  
  3559. # SUBRs und feste Symbole demarkieren:
  3560.   local void unmark_fixed_varobjects (void);
  3561.   local void unmark_fixed_varobjects()
  3562.     { for_all_subrs( unmark((aint)ptr+subr_const_offset); ); # jedes Subr demarkieren
  3563.       #if !defined(GENERATIONAL_GC)
  3564.       for_all_constsyms( unmark(&((Symbol)ptr)->GCself); ); # jedes Symbol in symbol_tab demarkieren
  3565.       #else
  3566.       # Da wir die konstanten Symbole nicht markiert haben, sondern nur ihren
  3567.       # Inhalt, brauchen wir sie auch nicht zu demarkieren.
  3568.       #endif
  3569.     }
  3570.  
  3571. #if !defined(MORRIS_GC)
  3572.  
  3573.  #ifdef SPVW_MIXED_BLOCKS_OPPOSITE
  3574.  
  3575.   # CONS-Zellen zwischen page->page_start und page->page_end oben
  3576.   # konzentrieren:
  3577.   local void gc_compact_cons_page (Page* page);
  3578.   local void gc_compact_cons_page(page)
  3579.     var reg3 Page* page;
  3580.     # Dabei wandert der Pointer p1 von unten und der Pointer p2 von
  3581.     # oben durch den Speicherbereich, bis sie kollidieren. Es
  3582.     # werden dabei markierte Strukturen über unmarkierte geschoben.
  3583.     { var reg1 aint p1 = page->page_start; # untere Grenze
  3584.       var reg2 aint p2 = page->page_end; # obere Grenze
  3585.       sweeploop:
  3586.         # Suche nächstobere unmarkierte Zelle <p2 und demarkiere dabei alle:
  3587.         sweeploop1:
  3588.           if (p1==p2) goto sweepok2; # Grenzen gleich geworden -> fertig
  3589.           p2 -= sizeof(cons_); # nächste Zelle von oben erfassen
  3590.           if (marked(p2)) # markiert?
  3591.             { unmark(p2); # demarkieren
  3592.               goto sweeploop1;
  3593.             }
  3594.         # p1 <= p2, p2 zeigt auf eine unmarkierte Zelle.
  3595.         # Suche nächstuntere markierte Zelle >=p1:
  3596.         sweeploop2:
  3597.           if (p1==p2) goto sweepok1; # Grenzen gleich geworden -> fertig
  3598.           if (!marked(p1)) # unmarkiert?
  3599.             { p1 += sizeof(cons_); # bei der nächstunteren Zelle
  3600.               goto sweeploop2; # weitersuchen
  3601.             }
  3602.         # p1 < p2, p1 zeigt auf eine markierte Zelle.
  3603.         unmark(p1); # demarkieren
  3604.         # Zelleninhalt in die unmarkierte Zelle kopieren:
  3605.         ((object*)p2)[0] = ((object*)p1)[0];
  3606.         ((object*)p2)[1] = ((object*)p1)[1];
  3607.         *(object*)p1 = type_pointer_object(0,p2); # neue Adresse hinterlassen
  3608.         mark(p1); # und markieren (als Erkennung fürs Aktualisieren)
  3609.         p1 += sizeof(cons_); # Diese Zelle ist fertig.
  3610.         goto sweeploop; # weiter
  3611.       sweepok1: p1 += sizeof(cons_); # letztes unmarkiertes Cons übergehen
  3612.       sweepok2:
  3613.       # p1 = neue untere Grenze des Cons-Bereiches
  3614.       page->page_start = p1;
  3615.     }
  3616.  
  3617.  #else
  3618.  
  3619.   # CONS-Zellen zwischen page->page_start und page->page_end unten
  3620.   # konzentrieren:
  3621.   local void gc_compact_cons_page (Page* page);
  3622.   local void gc_compact_cons_page(page)
  3623.     var reg3 Page* page;
  3624.     # Dabei wandert der Pointer p1 von unten und der Pointer p2 von
  3625.     # oben durch den Speicherbereich, bis sie kollidieren. Es
  3626.     # werden dabei markierte Strukturen über unmarkierte geschoben.
  3627.     { var reg1 aint p1 = page->page_start; # untere Grenze
  3628.       var reg2 aint p2 = page->page_end; # obere Grenze
  3629.       sweeploop:
  3630.         # Suche nächstobere markierte Zelle <p2:
  3631.         sweeploop1:
  3632.           if (p1==p2) goto sweepok2; # Grenzen gleich geworden -> fertig
  3633.           p2 -= sizeof(cons_); # nächste Zelle von oben erfassen
  3634.           if (!marked(p2)) goto sweeploop1; # unmarkiert?
  3635.         # p1 <= p2, p2 zeigt auf eine markierte Zelle.
  3636.         unmark(p2); # demarkieren
  3637.         # Suche nächstuntere unmarkierte Zelle >=p1 und demarkiere dabei alle:
  3638.         sweeploop2:
  3639.           if (p1==p2) goto sweepok1; # Grenzen gleich geworden -> fertig
  3640.           if (marked(p1)) # markiert?
  3641.             { unmark(p1); # demarkieren
  3642.               p1 += sizeof(cons_); # bei der nächstoberen Zelle
  3643.               goto sweeploop2; # weitersuchen
  3644.             }
  3645.         # p1 < p2, p1 zeigt auf eine unmarkierte Zelle.
  3646.         # Zelleninhalt von der markierten in die unmarkierte Zelle kopieren:
  3647.         ((object*)p1)[0] = ((object*)p2)[0];
  3648.         ((object*)p1)[1] = ((object*)p2)[1];
  3649.         *(object*)p2 = type_pointer_object(0,p1); # neue Adresse hinterlassen
  3650.         mark(p2); # und markieren (als Erkennung fürs Aktualisieren)
  3651.         p1 += sizeof(cons_); # Diese Zelle ist fertig.
  3652.         goto sweeploop; # weiter
  3653.       sweepok1: p1 += sizeof(cons_); # letztes markiertes Cons übergehen
  3654.       sweepok2:
  3655.       # p1 = neue obere Grenze des Cons-Bereiches
  3656.       page->page_end = p1;
  3657.     }
  3658.  
  3659.  #endif
  3660.  
  3661. #else # defined(MORRIS_GC)
  3662.  
  3663. # Algorithmus siehe:
  3664. # [F. Lockwood Morris: A time- and space-efficient garbage collection algorithm.
  3665. #  CACM 21,8 (August 1978), 662-665.]
  3666.  
  3667.   # Alle unmarkierten CONS-Zellen löschen und die markierten CONS-Zellen demarkieren,
  3668.   # damit das Markierungsbit für die Rückwärtspointer zur Verfügung steht.
  3669.   local void gc_morris1 (Page* page);
  3670.   local void gc_morris1(page)
  3671.     var reg4 Page* page;
  3672.     { var reg1 aint p1 = page->page_start; # untere Grenze
  3673.       var reg2 aint p2 = page->page_end; # obere Grenze
  3674.       var reg3 aint d = 0; # freien Speicher mitzählen
  3675.       until (p1==p2)
  3676.         { if (!marked(p1))
  3677.             { ((object*)p1)[0] = nullobj;
  3678.               ((object*)p1)[1] = nullobj;
  3679.               d += sizeof(cons_);
  3680.             }
  3681.             else
  3682.             { unmark(p1);
  3683.               #ifdef DEBUG_SPVW
  3684.               if (eq(((object*)p1)[0],nullobj) || eq(((object*)p1)[1],nullobj))
  3685.                 abort();
  3686.               #endif
  3687.             }
  3688.           p1 += sizeof(cons_); # Diese Zelle ist fertig.
  3689.         }
  3690.       page->page_gcpriv.d = d; # freien Speicher abspeichern
  3691.     }
  3692.  
  3693.  #ifdef SPVW_MIXED_BLOCKS_OPPOSITE
  3694.  
  3695.   # Es gibt nur eine einzige Page mit Zwei-Pointer-Objekten.
  3696.  
  3697.   local void gc_morris2 (Page* page);
  3698.   local void gc_morris2(page)
  3699.     var reg7 Page* page;
  3700.     { # Jede Zelle innerhalb eines Cons enthält nun eine Liste aller
  3701.       # Adressen von Pointern auf diese Zelle, die aus einer Wurzel heraus
  3702.       # oder aus einem Varobject heraus auf diese Zelle zeigen.
  3703.       #
  3704.       # Die nicht gelöschten Conses von links nach rechts durchlaufen:
  3705.       # (Zwischendurch enthält jede Zelle eine Liste aller Adressen
  3706.       # von Pointern auf diese Zelle, die aus einer Wurzel heraus,
  3707.       # aus einem Varobject heraus oder aus einem weiter links liegenden
  3708.       # Cons auf diese Zelle zeigen.)
  3709.       var reg4 aint p1 = page->page_start; # untere Grenze
  3710.       var reg5 aint p2 = p1 + page->gcpriv.d; # spätere untere Grenze
  3711.       var reg6 aint p1limit = page->page_end; # obere Grenze
  3712.       until (p1==p1limit) # stets p1 <= p2 <= p1limit
  3713.         { # Beide Zellen eines Cons werden genau gleich behandelt.
  3714.           var reg1 object obj = *(object*)p1;
  3715.           if (!eq(obj,nullobj))
  3716.             { # p1 wird nach p2 verschoben.
  3717.               # Die bisher registrierten Pointer auf diese Zelle werden aktualisiert:
  3718.               until ((as_oint(obj) & wbit(garcol_bit_o)) == 0) # Liste abarbeiten
  3719.                 { obj = without_mark_bit(obj);
  3720.                  {var reg2 aint p = upointer(obj);
  3721.                   var reg3 object next_obj = *(object*)p;
  3722.                   *(object*)p = type_pointer_object(typecode(obj),p2);
  3723.                   obj = next_obj;
  3724.                 }}
  3725.               # Falls die Zelle einen Pointer "nach rechts" enthält, wird er umgedreht.
  3726.               { var reg3 tint type = typecode(obj);
  3727.                 switch (type)
  3728.                   { case_cons: case_ratio: case_complex:
  3729.                       { var reg2 aint p = upointer(obj);
  3730.                         if (!in_old_generation(obj,type,1) && (p > p1))
  3731.                           { # Für spätere Aktualisierung
  3732.                             # p1 in die Liste der Pointer auf p einhängen:
  3733.                             *(object*)p1 = *(object*)p;
  3734.                             *(object*)p = with_mark_bit(type_pointer_object(type,p1));
  3735.                             break;
  3736.                       }   }
  3737.                     default:
  3738.                       *(object*)p1 = obj;
  3739.               }   }
  3740.               p2 += sizeof(object);
  3741.             }
  3742.           p1 += sizeof(object);
  3743.         }
  3744.       if (!(p2==p1limit)) abort();
  3745.     }
  3746.   local void gc_morris3 (Page* page);
  3747.   local void gc_morris3(page)
  3748.     var reg7 Page* page;
  3749.     { # Jede Zelle innerhalb eines Cons enthält nun wieder den ursprünglichen
  3750.       # Inhalt.
  3751.       #
  3752.       # Die nicht gelöschten Conses von rechts nach links durchlaufen
  3753.       # und dabei rechts kompaktieren:
  3754.       # (Zwischendurch enthält jede Zelle eine Liste aller Adressen
  3755.       # von Pointern auf diese Zelle, die aus einem weiter rechts liegenden
  3756.       # Cons auf diese Zelle zeigen.)
  3757.       var reg6 aint p1limit = page->page_start; # untere Grenze
  3758.       var reg4 aint p1 = page->page_end; # obere Grenze
  3759.       var reg5 aint p2 = p1; # obere Grenze
  3760.       #ifdef DEBUG_SPVW
  3761.       until (p1==p1limit)
  3762.         { p1 -= 2*sizeof(object);
  3763.           if (eq(*(object*)p1,nullobj)+eq(*(object*)(p1^sizeof(object)),nullobj)==1)
  3764.             abort();
  3765.         }
  3766.       p1 = page->page_end;
  3767.       #endif
  3768.       until (p1==p1limit) # stets p1limit <= p1 <= p2
  3769.         { # Beide Zellen eines Cons werden genau gleich behandelt.
  3770.           p1 -= sizeof(object);
  3771.           #ifdef DEBUG_SPVW
  3772.           if (eq(*(object*)p1,nullobj)+eq(*(object*)(p1^sizeof(object)),nullobj)==1)
  3773.             abort();
  3774.           if (!((p1 % (2*sizeof(object))) == 0))
  3775.             { if (!((p2 % (2*sizeof(object))) == 0))
  3776.                 abort();
  3777.             }
  3778.           #endif
  3779.          {var reg1 object obj = *(object*)p1;
  3780.           if (!eq(obj,nullobj))
  3781.             { p2 -= sizeof(object);
  3782.               # p1 wird nach p2 verschoben.
  3783.               # Die neu registrierten Pointer auf diese Zelle werden aktualisiert:
  3784.               until ((as_oint(obj) & wbit(garcol_bit_o)) == 0) # Liste abarbeiten
  3785.                 { obj = without_mark_bit(obj);
  3786.                  {var reg2 aint p = upointer(obj);
  3787.                   var reg3 object next_obj = *(object*)p;
  3788.                   *(object*)p = type_pointer_object(typecode(obj),p2);
  3789.                   obj = next_obj;
  3790.                 }}
  3791.               #ifdef DEBUG_SPVW
  3792.               if (eq(obj,nullobj)) abort();
  3793.               #endif
  3794.               *(object*)p2 = obj;
  3795.               { var reg5 tint type = typecode(obj);
  3796.                 if (!immediate_type_p(type)) # unverschieblich -> nichts tun
  3797.                   switch (type)
  3798.                     { case_cons: case_ratio: case_complex: # Zwei-Pointer-Objekt
  3799.                         { var reg4 aint p = upointer(obj);
  3800.                           if (p < p1) # Pointer nach links?
  3801.                             { # Für spätere Aktualisierung
  3802.                               # p2 in die Liste der Pointer auf p einhängen:
  3803.                               #ifdef DEBUG_SPVW
  3804.                               if (eq(*(object*)p,nullobj)) abort();
  3805.                               #endif
  3806.                               *(object*)p2 = *(object*)p;
  3807.                               *(object*)p = with_mark_bit(type_pointer_object(type,p2));
  3808.                             }
  3809.                           elif (p == p1) # Pointer auf sich selbst?
  3810.                             { *(object*)p2 = type_pointer_object(type,p2); }
  3811.                         }
  3812.                         break;
  3813.                       default: # Objekt variabler Länge
  3814.                         if (marked(ThePointer(obj))) # markiert?
  3815.                           *(object*)p2 = type_untype_object(type,untype(*(object*)ThePointer(obj)));
  3816.                         break;
  3817.               }     }
  3818.             }}
  3819.         }
  3820.       # p2 = neue untere Grenze des Cons-Bereiches
  3821.       if (!(p2 == page->page_start + page->page_gcpriv.d)) abort();
  3822.       page->page_start = p2;
  3823.     }
  3824.  
  3825.  #elif defined(SPVW_MIXED_BLOCKS) # TRIVIALMAP_MEMORY
  3826.  
  3827.   local void gc_morris2 (Page* page);
  3828.   local void gc_morris2(page)
  3829.     var reg7 Page* page;
  3830.     { # Jede Zelle innerhalb eines Cons enthält nun eine Liste aller
  3831.       # Adressen von Pointern auf diese Zelle, die aus einer Wurzel heraus
  3832.       # oder aus einem Varobject heraus auf diese Zelle zeigen.
  3833.       #
  3834.       # Die nicht gelöschten Conses von rechts nach links durchlaufen:
  3835.       # (Zwischendurch enthält jede Zelle eine Liste aller Adressen
  3836.       # von Pointern auf diese Zelle, die aus einer Wurzel heraus,
  3837.       # aus einem Varobject heraus oder aus einem weiter rechts liegenden
  3838.       # Cons auf diese Zelle zeigen.)
  3839.       var reg5 aint p1 = page->page_end; # obere Grenze
  3840.       var reg4 aint p2 = p1 - page->gcpriv.d; # spätere obere Grenze
  3841.       var reg6 aint p1limit = page->page_start; # untere Grenze
  3842.       #ifdef DEBUG_SPVW
  3843.       until (p1==p1limit)
  3844.         { p1 -= 2*sizeof(object);
  3845.           if (eq(*(object*)p1,nullobj)+eq(*(object*)(p1^sizeof(object)),nullobj)==1)
  3846.             abort();
  3847.         }
  3848.       p1 = page->page_end;
  3849.       #endif
  3850.       until (p1==p1limit) # stets p1limit <= p2 <= p1
  3851.         { # Beide Zellen eines Cons werden genau gleich behandelt.
  3852.           p1 -= sizeof(object);
  3853.           #ifdef DEBUG_SPVW
  3854.           if (eq(*(object*)p1,nullobj)+eq(*(object*)(p1^sizeof(object)),nullobj)==1)
  3855.             abort();
  3856.           #endif
  3857.          {var reg1 object obj = *(object*)p1;
  3858.           if (!eq(obj,nullobj))
  3859.             { p2 -= sizeof(object);
  3860.               # p1 wird nach p2 verschoben.
  3861.               # Die bisher registrierten Pointer auf diese Zelle werden aktualisiert:
  3862.               until ((as_oint(obj) & wbit(garcol_bit_o)) == 0) # Liste abarbeiten
  3863.                 { obj = without_mark_bit(obj);
  3864.                  {var reg2 aint p = upointer(obj);
  3865.                   var reg3 object next_obj = *(object*)p;
  3866.                   *(object*)p = type_pointer_object(typecode(obj),p2);
  3867.                   obj = next_obj;
  3868.                 }}
  3869.               # obj = ursprünglicher Inhalt der Zelle p1.
  3870.               #ifdef DEBUG_SPVW
  3871.               if (eq(obj,nullobj)) abort();
  3872.               #endif
  3873.               # Falls die Zelle einen Pointer "nach links" enthält, wird er umgedreht.
  3874.               { var reg3 tint type = typecode(obj);
  3875.                 switch (type)
  3876.                   { case_cons: case_ratio: case_complex:
  3877.                       { var reg2 aint p = upointer(obj);
  3878.                         if (!in_old_generation(obj,type,1) && (p < p1))
  3879.                           { # Für spätere Aktualisierung
  3880.                             # p1 in die Liste der Pointer auf p einhängen:
  3881.                             *(object*)p1 = *(object*)p;
  3882.                             *(object*)p = with_mark_bit(type_pointer_object(type,p1));
  3883.                             break;
  3884.                       }   }
  3885.                     default:
  3886.                       *(object*)p1 = obj;
  3887.             } }   }
  3888.         }}
  3889.       if (!(p2==p1limit)) abort();
  3890.     }
  3891.   local void gc_morris3 (Page* page);
  3892.   local void gc_morris3(page)
  3893.     var reg7 Page* page;
  3894.     { # Jede Zelle innerhalb eines Cons enthält nun wieder den ursprünglichen
  3895.       # Inhalt.
  3896.       #
  3897.       # Die nicht gelöschten Conses von links nach rechts durchlaufen
  3898.       # und dabei links kompaktieren:
  3899.       # (Zwischendurch enthält jede Zelle eine Liste aller Adressen
  3900.       # von Pointern auf diese Zelle, die aus einem weiter links liegenden
  3901.       # Cons auf diese Zelle zeigen.)
  3902.       var reg6 aint p1limit = page->page_end; # obere Grenze
  3903.       var reg4 aint p1 = page->page_start; # untere Grenze
  3904.       var reg5 aint p2 = p1; # untere Grenze
  3905.       until (p1==p1limit) # stets p1limit <= p1 <= p2
  3906.         { # Beide Zellen eines Cons werden genau gleich behandelt.
  3907.           var reg1 object obj = *(object*)p1;
  3908.           if (!eq(obj,nullobj))
  3909.             { # p1 wird nach p2 verschoben.
  3910.               # Die neu registrierten Pointer auf diese Zelle werden aktualisiert:
  3911.               until ((as_oint(obj) & wbit(garcol_bit_o)) == 0) # Liste abarbeiten
  3912.                 { obj = without_mark_bit(obj);
  3913.                  {var reg2 aint p = upointer(obj);
  3914.                   var reg3 object next_obj = *(object*)p;
  3915.                   *(object*)p = type_pointer_object(typecode(obj),p2);
  3916.                   obj = next_obj;
  3917.                 }}
  3918.               # obj = richtiger Inhalt der Zelle p1.
  3919.               { var reg5 tint type = typecode(obj);
  3920.                 if (!immediate_type_p(type)) # unverschieblich -> nichts tun
  3921.                   switch (type)
  3922.                     { case_cons: case_ratio: case_complex: # Zwei-Pointer-Objekt
  3923.                         { var reg4 aint p = upointer(obj);
  3924.                           if (p > p1) # Pointer nach rechts?
  3925.                             { # Für spätere Aktualisierung
  3926.                               # p2 in die Liste der Pointer auf p einhängen:
  3927.                               #ifdef DEBUG_SPVW
  3928.                               if (eq(*(object*)p,nullobj)) abort();
  3929.                               #endif
  3930.                               *(object*)p2 = *(object*)p;
  3931.                               *(object*)p = with_mark_bit(type_pointer_object(type,p2));
  3932.                             }
  3933.                           elif (p == p1) # Pointer auf sich selbst?
  3934.                             { *(object*)p2 = type_pointer_object(type,p2); }
  3935.                           else
  3936.                             { *(object*)p2 = obj; }
  3937.                         }
  3938.                         break;
  3939.                       default: # Objekt variabler Länge
  3940.                         if (marked(ThePointer(obj))) # markiert?
  3941.                           *(object*)p2 = type_untype_object(type,untype(*(object*)ThePointer(obj)));
  3942.                           else
  3943.                           *(object*)p2 = obj;
  3944.                         break;
  3945.                     }
  3946.                   else # unverschieblich oder Pointer in die alte Generation -> nichts tun
  3947.                   { *(object*)p2 = obj; }
  3948.               }
  3949.               p2 += sizeof(object);
  3950.             }
  3951.           p1 += sizeof(object);
  3952.         }
  3953.       # p2 = neue obere Grenze des Cons-Bereiches
  3954.       if (!(p2 == page->page_end - page->page_gcpriv.d)) abort();
  3955.       page->page_end = p2;
  3956.     }
  3957.  
  3958.  #else # SPVW_PURE_BLOCKS <==> SINGLEMAP_MEMORY
  3959.  
  3960.   # gc_morris2 und gc_morris3 müssen je einmal für jede Page aufgerufen werden,
  3961.   # und zwar gc_morris2 von rechts nach links, dann gc_morris3 von links nach rechts
  3962.   # (im Sinne der Anordnung der Adressen)!
  3963.  
  3964.   local void gc_morris2 (Page* page);
  3965.   local void gc_morris2(page)
  3966.     var reg7 Page* page;
  3967.     { # Jede Zelle innerhalb eines Cons enthält nun eine Liste aller
  3968.       # Adressen von Pointern auf diese Zelle, die aus einer Wurzel heraus
  3969.       # oder aus einem Varobject heraus auf diese Zelle zeigen.
  3970.       #
  3971.       # Die nicht gelöschten Conses von rechts nach links durchlaufen:
  3972.       # (Zwischendurch enthält jede Zelle eine Liste aller Adressen
  3973.       # von Pointern auf diese Zelle, die aus einer Wurzel heraus,
  3974.       # aus einem Varobject heraus oder aus einem weiter rechts liegenden
  3975.       # Cons auf diese Zelle zeigen.)
  3976.       var reg4 aint p1 = page->page_end; # obere Grenze
  3977.       var reg3 aint p2 = p1 - page->gcpriv.d; # spätere obere Grenze
  3978.       var reg5 aint p1limit = page->page_start; # untere Grenze
  3979.       until (p1==p1limit) # stets p1limit <= p2 <= p1
  3980.         { # Beide Zellen eines Cons werden genau gleich behandelt.
  3981.           p1 -= sizeof(object);
  3982.          {var reg1 object obj = *(object*)p1;
  3983.           if (!eq(obj,nullobj))
  3984.             { p2 -= sizeof(object);
  3985.               # p1 wird nach p2 verschoben.
  3986.               # Die bisher registrierten Pointer auf diese Zelle werden aktualisiert:
  3987.               until ((as_oint(obj) & wbit(garcol_bit_o)) == 0) # Liste abarbeiten
  3988.                 { obj = without_mark_bit(obj);
  3989.                  {var reg2 object next_obj = *(object*)pointable(obj);
  3990.                   *(object*)pointable(obj) = as_object(p2);
  3991.                   obj = next_obj;
  3992.                 }}
  3993.               # obj = ursprünglicher Inhalt der Zelle p1.
  3994.               # Falls die Zelle einen Pointer "nach links" enthält, wird er umgedreht.
  3995.               if (is_cons_heap(typecode(obj))
  3996.                   && !in_old_generation(obj,typecode(obj),1)
  3997.                   && ((aint)pointable(obj) < p1)
  3998.                  )
  3999.                 { # Für spätere Aktualisierung
  4000.                   # p1 in die Liste der Pointer auf obj einhängen:
  4001.                   *(object*)p1 = *(object*)pointable(obj);
  4002.                   *(object*)pointable(obj) = with_mark_bit(as_object(p1));
  4003.                 }
  4004.                 else
  4005.                 { *(object*)p1 = obj; }
  4006.             }
  4007.         }}
  4008.       if (!(p2==p1limit)) abort();
  4009.     }
  4010.   local void gc_morris3 (Page* page);
  4011.   local void gc_morris3(page)
  4012.     var reg7 Page* page;
  4013.     { # Jede Zelle innerhalb eines Cons enthält nun wieder den ursprünglichen
  4014.       # Inhalt.
  4015.       #
  4016.       # Die nicht gelöschten Conses von links nach rechts durchlaufen
  4017.       # und dabei links kompaktieren:
  4018.       # (Zwischendurch enthält jede Zelle eine Liste aller Adressen
  4019.       # von Pointern auf diese Zelle, die aus einem weiter links liegenden
  4020.       # Cons auf diese Zelle zeigen.)
  4021.       var reg6 aint p1limit = page->page_end; # obere Grenze
  4022.       var reg4 aint p1 = page->page_start; # untere Grenze
  4023.       var reg3 aint p2 = p1; # untere Grenze
  4024.       until (p1==p1limit) # stets p1limit <= p1 <= p2
  4025.         { # Beide Zellen eines Cons werden genau gleich behandelt.
  4026.           var reg1 object obj = *(object*)p1;
  4027.           if (!eq(obj,nullobj))
  4028.             { # p1 wird nach p2 verschoben.
  4029.               # Die neu registrierten Pointer auf diese Zelle werden aktualisiert:
  4030.               until ((as_oint(obj) & wbit(garcol_bit_o)) == 0) # Liste abarbeiten
  4031.                 { obj = without_mark_bit(obj);
  4032.                  {var reg2 object next_obj = *(object*)pointable(obj);
  4033.                   *(object*)pointable(obj) = as_object(p2);
  4034.                   obj = next_obj;
  4035.                 }}
  4036.               # obj = richtiger Inhalt der Zelle p1.
  4037.               { var reg5 tint type = typecode(obj);
  4038.                 if (!is_unused_heap(type) && !in_old_generation(obj,type,?))
  4039.                   if (is_cons_heap(type))
  4040.                     # Zwei-Pointer-Objekt
  4041.                     { if ((aint)pointable(obj) > p1) # Pointer nach rechts?
  4042.                         { # Für spätere Aktualisierung
  4043.                           # p2 in die Liste der Pointer auf obj einhängen:
  4044.                           *(object*)p2 = *(object*)pointable(obj);
  4045.                           *(object*)pointable(obj) = with_mark_bit(as_object(p2));
  4046.                         }
  4047.                       elif ((aint)pointable(obj) == p1) # Pointer auf sich selbst?
  4048.                         { *(object*)p2 = as_object(p2); }
  4049.                       else
  4050.                         { *(object*)p2 = obj; }
  4051.                     }
  4052.                     else
  4053.                     # Objekt variabler Länge
  4054.                     { if (marked(ThePointer(obj))) # markiert?
  4055.                         *(object*)p2 = type_untype_object(type,untype(*(object*)ThePointer(obj)));
  4056.                         else
  4057.                         *(object*)p2 = obj;
  4058.                     }
  4059.                   else # unverschieblich oder Pointer in die alte Generation -> nichts tun
  4060.                   { *(object*)p2 = obj; }
  4061.               }
  4062.               p2 += sizeof(object);
  4063.             }
  4064.           p1 += sizeof(object);
  4065.         }
  4066.       # p2 = neue obere Grenze des Cons-Bereiches
  4067.       if (!(p2 == page->page_end - page->page_gcpriv.d)) abort();
  4068.       page->page_end = p2;
  4069.     }
  4070.  
  4071.  #endif
  4072.  
  4073. #endif
  4074.  
  4075. # Den Selbstpointer eines Objekts variabler Länge modifizieren:
  4076. # set_GCself(p,type,addr);
  4077. # setzt p->GCself auf type_pointer_object(type,addr).
  4078.   #if !(exact_uint_size_p(oint_type_len) && ((oint_type_shift%hfintsize)==0) && (tint_type_mask == bit(oint_type_len)-1))
  4079.     #ifdef MAP_MEMORY
  4080.       # addr enthält Typinfo
  4081.       #define set_GCself(p,type,addr)  \
  4082.         ((Varobject)(p))->GCself = type_pointer_object((type)&(tint_type_mask),(addr)&(oint_addr_mask))
  4083.     #else
  4084.       # addr enthält keine Typinfo
  4085.       #define set_GCself(p,type,addr)  \
  4086.         ((Varobject)(p))->GCself = type_pointer_object((type)&(tint_type_mask),addr)
  4087.     #endif
  4088.   #else # besser: zwar zwei Speicherzugriffe, jedoch weniger Arithmetik
  4089.     #define set_GCself(p,type,addr)  \
  4090.       ((Varobject)(p))->GCself = type_pointer_object(0,addr), \
  4091.       ((Varobject)(p))->header_flags = (type)
  4092.   #endif
  4093.  
  4094. # Objekte variabler Länge zwischen page->page_start und page->page_end zur
  4095. # Zusammenschiebung nach unten vorbereiten. Dabei wird in jedes markierte
  4096. # Objekt vorne der Pointer auf die Stelle eingetragen, wo das
  4097. # Objekt später stehen wird (samt Typinfo). Ist das darauffolgende
  4098. # Objekt unmarkiert, so wird in dessen erstem Pointer die Adresse
  4099. # des nächsten markierten Objekts eingetragen.
  4100.   #ifdef SPVW_PURE
  4101.   local aint gc_sweep1_varobject_page (uintL heapnr, aint start, aint end, object* firstmarked, aint dest);
  4102.   local aint gc_sweep1_varobject_page PARM5(heapnr,start,end,firstmarked,dest,
  4103.     var reg6 uintL heapnr,
  4104.     var aint start,
  4105.     var aint end,
  4106.     var object* firstmarked,
  4107.     var aint dest)
  4108.   #elif defined(GENERATIONAL_GC)
  4109.   local aint gc_sweep1_varobject_page (aint start, aint end, object* firstmarked, aint dest);
  4110.   local aint gc_sweep1_varobject_page PARM4(start,end,firstmarked,dest,
  4111.     var aint start,
  4112.     var aint end,
  4113.     var object* firstmarked,
  4114.     var aint dest)
  4115.   #else
  4116.   local void gc_sweep1_varobject_page (Page* page);
  4117.   local void gc_sweep1_varobject_page PARM1(page,
  4118.     var reg6 Page* page)
  4119.   #endif
  4120.     {
  4121.       #if defined(SPVW_PURE) || defined(GENERATIONAL_GC)
  4122.       var reg4 object* last_open_ptr = firstmarked;
  4123.       var reg2 aint p2 = start; # Source-Pointer
  4124.       var reg5 aint p2end = end; # obere Grenze des Source-Bereiches
  4125.       var reg3 aint p1 = dest; # Ziel-Pointer
  4126.       #else
  4127.       var reg4 object* last_open_ptr = &page->page_gcpriv.firstmarked;
  4128.         # In *last_open_ptr ist stets die Adresse des nächsten markierten
  4129.         # Objekts (als oint) einzutragen.
  4130.         # Durch verkettete-Liste-Mechanismus: Am Schluß enthält
  4131.         # page->gcpriv.firstmarked die Adresse des 1. markierten Objekts
  4132.       var reg2 aint p2 = page->page_start; # Source-Pointer
  4133.       var reg5 aint p2end = page->page_end; # obere Grenze des Source-Bereiches
  4134.       var reg3 aint p1 = p2; # Ziel-Pointer
  4135.       #endif
  4136.       # start <= p1 <= p2 <= end, p1 und p2 wachsen, p2 schneller als p1.
  4137.       var_speicher_laenge_;
  4138.       sweeploop1:
  4139.         # Nächstes markiertes Objekt suchen.
  4140.         # Adresse des nächsten markierten Objekts in *last_open_ptr eintragen.
  4141.         if (p2==p2end) goto sweepok1; # obere Grenze erreicht -> fertig
  4142.         { var reg2 tint flags = mtypecode(((Varobject)p2)->GCself);
  4143.           # Typinfo (und Flags bei Symbolen) retten
  4144.           var reg1 uintL laenge = calc_speicher_laenge(p2); # Byte-Länge bestimmen
  4145.           if (!marked(p2)) # Objekt unmarkiert?
  4146.             { p2 += laenge; goto sweeploop1; } # ja -> zum nächsten Objekt
  4147.           # Objekt markiert
  4148.           *last_open_ptr = type_pointer_object(0,p2); # Adresse ablegen
  4149.           set_GCself(p2, flags,p1); # neue Adresse eintragen, mit alter
  4150.                          # Typinfo (darin ist auch das Markierungsbit enthalten)
  4151.           p2 += laenge; # Sourceadresse für nächstes Objekt
  4152.           p1 += laenge; # Zieladresse für nächstes Objekt
  4153.         }
  4154.       sweeploop2:
  4155.         # Nächstes unmarkiertes Objekt suchen.
  4156.         if (p2==p2end) goto sweepok2; # obere Grenze erreicht -> fertig
  4157.         { var reg2 tint flags = mtypecode(((Varobject)p2)->GCself);
  4158.           # Typinfo (und Flags bei Symbolen) retten
  4159.           var reg1 uintL laenge = calc_speicher_laenge(p2); # Byte-Länge bestimmen
  4160.           if (!marked(p2)) # Objekt unmarkiert?
  4161.             { last_open_ptr = (object*)p2; # ja -> Hier den nächsten Pointer ablegen
  4162.               p2 += laenge; goto sweeploop1; # und zum nächsten Objekt
  4163.             }
  4164.           # Objekt markiert
  4165.           set_GCself(p2, flags,p1); # neue Adresse eintragen, mit alter
  4166.                          # Typinfo (darin ist auch das Markierungsbit enthalten)
  4167.           p2 += laenge; # Sourceadresse für nächstes Objekt
  4168.           p1 += laenge; # Zieladresse für nächstes Objekt
  4169.           goto sweeploop2;
  4170.         }
  4171.       sweepok1: *last_open_ptr = type_pointer_object(0,p2);
  4172.       sweepok2: ;
  4173.       #if defined(SPVW_PURE) || defined(GENERATIONAL_GC)
  4174.       return p1;
  4175.       #endif
  4176.     }
  4177.  
  4178. # Aktualisierungsphase:
  4179.   # Der gesamte LISP-Speicher wird durchgegangen und dabei alte durch
  4180.   # neue Adressen ersetzt.
  4181.   # Aktualisierung eines Objekts *objptr :
  4182.     #if !defined(MORRIS_GC)
  4183.       #define aktualisiere(objptr)  \
  4184.         { var reg2 tint type = mtypecode(*(object*)objptr);                     \
  4185.           if (!immediate_type_p(type)) # unverschieblich -> nichts tun          \
  4186.             { var reg1 object obj = *(object*)objptr; # fragliches Objekt       \
  4187.               if (!in_old_generation(obj,type,mem.heapnr_from_type[type]))      \
  4188.                 # ältere Generation -> nichts zu tun (Objekt blieb stehen)      \
  4189.                 if (marked(ThePointer(obj))) # markiert?                        \
  4190.                   # nein -> nichts zu tun (Objekt blieb stehen)                 \
  4191.                   # ja -> neue Adresse eintragen und Typinfobyte (incl.         \
  4192.                   #       evtl. Symbol-Bindungsflags) zurückschreiben           \
  4193.                   *(object*)objptr =                                            \
  4194.                     type_untype_object(type,untype(*(object*)ThePointer(obj))); \
  4195.         }   }
  4196.     #else # defined(MORRIS_GC)
  4197.       #if defined(SPVW_MIXED_BLOCKS)
  4198.         #define aktualisiere(objptr)  \
  4199.           { var reg2 tint type = mtypecode(*(object*)objptr);                     \
  4200.             if (!immediate_type_p(type)) # unverschieblich -> nichts tun          \
  4201.               switch (type)                                                       \
  4202.                 { default: # Objekt variabler Länge                               \
  4203.                     { var reg1 object obj = *(object*)objptr; # fragliches Objekt \
  4204.                       if (!in_old_generation(obj,type,0))                         \
  4205.                         if (marked(ThePointer(obj))) # markiert?                  \
  4206.                           *(object*)objptr = type_untype_object(type,untype(*(object*)ThePointer(obj))); \
  4207.                     }                                                             \
  4208.                     break;                                                        \
  4209.                   case_cons: case_ratio: case_complex: # Zwei-Pointer-Objekt      \
  4210.                     { var reg1 object obj = *(object*)objptr; # fragliches Objekt \
  4211.                       if (!in_old_generation(obj,type,1))                         \
  4212.                         { # Für spätere Aktualisierung in dessen Liste einhängen: \
  4213.                           *(object*)objptr = *(object*)ThePointer(obj);           \
  4214.                           *(object*)ThePointer(obj) = with_mark_bit(type_pointer_object(type,objptr)); \
  4215.                     }   }                                                         \
  4216.                     break;                                                        \
  4217.           }     }
  4218.       #else # defined(SPVW_PURE_BLOCKS) # && defined(SINGLEMAP_MEMORY)
  4219.         #define aktualisiere(objptr)  \
  4220.           { var reg2 tint type = mtypecode(*(object*)objptr);                 \
  4221.             if (!is_unused_heap(type)) # unverschieblich -> nichts tun        \
  4222.               { var reg1 object obj = *(object*)objptr; # fragliches Objekt   \
  4223.                 if (!in_old_generation(obj,type,?))                           \
  4224.                   # ältere Generation -> nichts zu tun (Objekt blieb stehen)  \
  4225.                   if (is_varobject_heap(type))                                \
  4226.                     # Objekt variabler Länge                                  \
  4227.                     { if (marked(ThePointer(obj))) # markiert?                \
  4228.                         *(object*)objptr = type_untype_object(type,untype(*(object*)ThePointer(obj))); \
  4229.                     }                                                         \
  4230.                     else                                                      \
  4231.                     # Zwei-Pointer-Objekt                                     \
  4232.                     { # Für spätere Aktualisierung in dessen Liste einhängen: \
  4233.                       *(object*)objptr = *(object*)ThePointer(obj);           \
  4234.                       *(object*)ThePointer(obj) = with_mark_bit(type_pointer_object(0,objptr)); \
  4235.                     }                                                         \
  4236.           }   }
  4237.       #endif
  4238.     #endif
  4239.   # Durchlaufen durch alle LISP-Objekte und aktualisieren:
  4240.     # Pointer im LISP-Stack aktualisieren:
  4241.       local void aktualisiere_STACK (void);
  4242.       local void aktualisiere_STACK()
  4243.         { var reg3 object* objptr = &STACK_0; # Pointer, der durch den STACK läuft
  4244.           until (eq(*objptr,nullobj)) # bis STACK zu Ende ist:
  4245.             { if ( *((oint*)objptr) & wbit(frame_bit_o) ) # Beginnt hier ein Frame?
  4246.                { if (( *((oint*)objptr) & wbit(skip2_bit_o) ) == 0) # Ohne skip2-Bit?
  4247.                   objptr skipSTACKop 2; # ja -> um 2 weiterrücken
  4248.                   else
  4249.                   objptr skipSTACKop 1; # nein -> um 1 weiterrücken
  4250.                }
  4251.                else
  4252.                { # normales Objekt, aktualisieren:
  4253.                  switch (mtypecode(*objptr))
  4254.                    { case_symbolflagged: # Symbol mit evtl. Flags
  4255.                        #ifndef NO_symbolflags
  4256.                        { var reg6 object obj1 = *objptr;
  4257.                          var reg4 object obj2 = symbol_without_flags(obj1);
  4258.                          var reg5 oint flags = as_oint(obj1) ^ as_oint(obj2);
  4259.                          *objptr = obj2; # vorerst Flags löschen
  4260.                          aktualisiere(objptr); # dann aktualisieren
  4261.                          *(oint*)objptr |= flags; # dann Flags wieder rein
  4262.                          break;
  4263.                        }
  4264.                        #endif
  4265.                      default: aktualisiere(objptr); break;
  4266.                    }
  4267.                  objptr skipSTACKop 1; # weiterrücken
  4268.         }   }  }
  4269.     # Die folgenden Macros rufen den Macro aktualisiere() auf.
  4270.     # Programmkonstanten aktualisieren:
  4271.       #define aktualisiere_subr_tab()  \
  4272.         for_all_subrs(                                                   \
  4273.           { var reg3 object* p = (object*)((aint)ptr+subr_const_offset); \
  4274.             var reg4 uintC c;                                            \
  4275.             dotimespC(c,subr_const_anz, { aktualisiere(p); p++; } );     \
  4276.           }                                                              \
  4277.           );
  4278.       #define aktualisiere_symbol_tab()  \
  4279.         for_all_constsyms( # symbol_tab durchgehen  \
  4280.           { var reg3 object* p;                     \
  4281.             p = &ptr->symvalue; aktualisiere(p);    \
  4282.             p = &ptr->symfunction; aktualisiere(p); \
  4283.             p = &ptr->proplist; aktualisiere(p);    \
  4284.             p = &ptr->pname; aktualisiere(p);       \
  4285.             p = &ptr->homepackage; aktualisiere(p); \
  4286.           }                                         \
  4287.           );
  4288.       #define aktualisiere_object_tab()  \
  4289.         for_all_constobjs( aktualisiere(objptr); ); # object_tab durchgehen
  4290.       #define aktualisiere_tab()  \
  4291.         { aktualisiere_subr_tab();   \
  4292.           aktualisiere_symbol_tab(); \
  4293.           aktualisiere_object_tab(); \
  4294.         }
  4295.     # Pointer in den Cons-Zellen aktualisieren:
  4296.       #define aktualisiere_conses()  \
  4297.         for_each_cons_page(page,                      \
  4298.           { var reg3 aint objptr = page->page_start;  \
  4299.             var reg4 aint objptrend = page->page_end; \
  4300.             # alle Pointer im (neuen) CONS-Bereich start <= Adresse < end aktualisieren: \
  4301.             until (objptr==objptrend)                 \
  4302.               { aktualisiere((object*)objptr);        \
  4303.                 objptr += sizeof(object);             \
  4304.                 aktualisiere((object*)objptr);        \
  4305.                 objptr += sizeof(object);             \
  4306.           }   }                                       \
  4307.           );
  4308.     # Pointer in den Objekten variabler Länge aktualisieren:
  4309.     #   #define aktualisiere_page ...
  4310.     #   aktualisiere_varobjects();
  4311.     #   #undef aktualisiere_page
  4312.       #define aktualisiere_page_normal(page,aktualisierer)  \
  4313.         { var reg2 aint ptr = page->page_start;                        \
  4314.           var reg6 aint ptrend = page->page_end;                       \
  4315.           # alle Objekte mit Adresse >=ptr, <ptrend durchgehen:        \
  4316.           until (ptr==ptrend) # solange bis ptr am Ende angekommen ist \
  4317.             { # nächstes Objekt mit Adresse ptr (< ptrend) durchgehen: \
  4318.               aktualisierer(typecode_at(ptr)); # und weiterrücken      \
  4319.         }   }
  4320.       # aktualisiert das Objekt bei 'ptr', dessen Typcode durch 'type_expr'
  4321.       # gegeben wird, und rückt ptr weiter:
  4322.       #ifdef SPVW_MIXED
  4323.       #define aktualisiere_varobject(type_expr)  \
  4324.         { var reg5 tint type = (type_expr); # Typinfo                                         \
  4325.           var reg7 uintL laenge = calc_speicher_laenge(ptr); # Länge bestimmen                \
  4326.           var reg8 aint newptr = ptr+laenge; # Zeiger auf nächstes Objekt                     \
  4327.           # Fallunterscheidung nach:                                                          \
  4328.             # Symbol; Simple-Vector; Nicht-simpler Array;                                     \
  4329.             # Record (insbes. Hash-Table); Rest.                                              \
  4330.           switch (type)                                                                       \
  4331.             { case_symbolwithflags:                                                           \
  4332.                 # Symbol: alle Pointer innerhalb eines Symbols aktualisieren                  \
  4333.                 { var reg3 object* p = (object*)pointerplus(ptr,symbol_objects_offset);       \
  4334.                   var reg4 uintC count;                                                       \
  4335.                   dotimespC(count,((sizeof(symbol_)-symbol_objects_offset)/sizeof(object)),   \
  4336.                     { aktualisiere(p); p++; } );                                              \
  4337.                 }                                                                             \
  4338.                 break;                                                                        \
  4339.               case_svector:                                                                   \
  4340.                 # Simple-vector: alle Pointer innerhalb eines Simple-vector aktualisieren     \
  4341.                 { var reg3 uintL count = ((Svector)ptr)->length;                              \
  4342.                   if (!(count==0))                                                            \
  4343.                     {var reg4 object* p = &((Svector)ptr)->data[0];                           \
  4344.                      dotimespL(count,count, { aktualisiere(p); p++; } );                      \
  4345.                 }   }                                                                         \
  4346.                 break;                                                                        \
  4347.               case_array1: case_obvector: case_ostring: case_ovector:                         \
  4348.                 # nicht-simpler Array: Datenvektor aktualisieren                              \
  4349.                 { var reg3 object* p = &((Array)ptr)->data;                                   \
  4350.                   aktualisiere(p);                                                            \
  4351.                 }                                                                             \
  4352.                 break;                                                                        \
  4353.               case_record:                                                                    \
  4354.                 # Record: alle Pointer innerhalb eines Record aktualisieren                   \
  4355.                 { # Beim Aktualisieren von Pointern verliert der Aufbau von                   \
  4356.                   # Hash-Tables seine Gültigkeit (denn die Hashfunktion eines                 \
  4357.                   # Objekts hängt von seiner Adresse ab, die sich ja jetzt                    \
  4358.                   # verändert).                                                               \
  4359.                   if (((Record)ptr)->rectype == Rectype_Hashtable) # eine Hash-Table ?        \
  4360.                     { mark_ht_invalid((Hashtable)ptr); } # ja -> für Reorganisation vormerken \
  4361.                   elif (aktualisiere_fpointer_invalid && (((Record)ptr)->rectype == Rectype_Fpointer)) # Foreign-Pointer ? \
  4362.                     { mark_fp_invalid((Record)ptr); } # ja -> evtl. ungültig machen           \
  4363.                  {var reg3 uintC count = (((Record)ptr)->rectype < 0 ? ((Srecord)ptr)->reclength : ((Xrecord)ptr)->reclength); \
  4364.                   if (!(count==0))                                                            \
  4365.                     { var reg4 object* p = &((Record)ptr)->recdata[0];                        \
  4366.                       dotimespC(count,count, { aktualisiere(p); p++; } );                     \
  4367.                 }}  }                                                                         \
  4368.                 break;                                                                        \
  4369.               default:                                                                        \
  4370.                 break; # alle anderen enthalten keine zu aktualisierenden Pointer             \
  4371.                        # -> nichts tun                                                        \
  4372.             }                                                                                 \
  4373.           # zum nächsten Objekt weiterrücken                                                  \
  4374.           ptr = newptr;                                                                       \
  4375.         }
  4376.       #define aktualisiere_varobjects()  \
  4377.         for_each_varobject_page(page,                    \
  4378.           aktualisiere_page(page,aktualisiere_varobject) \
  4379.           );
  4380.       #endif
  4381.       #ifdef SPVW_PURE
  4382.       #define aktualisiere_symbol(type_expr)  # ignoriert type_expr \
  4383.         { var reg7 uintL laenge = speicher_laenge_symbol((void*)ptr); # Länge bestimmen \
  4384.           var reg8 aint newptr = ptr+laenge; # Zeiger auf nächstes Objekt               \
  4385.           # Symbol: alle Pointer innerhalb eines Symbols aktualisieren                  \
  4386.           { var reg3 object* p = (object*)pointerplus(ptr,symbol_objects_offset);       \
  4387.             var reg4 uintC count;                                                       \
  4388.             dotimespC(count,((sizeof(symbol_)-symbol_objects_offset)/sizeof(object)),   \
  4389.               { aktualisiere(p); p++; } );                                              \
  4390.           }                                                                             \
  4391.           ptr = newptr; # zum nächsten Objekt weiterrücken                              \
  4392.         }
  4393.       #define aktualisiere_svector(type_expr)  # ignoriert type_expr \
  4394.         { var reg7 uintL laenge = speicher_laenge_svector((void*)ptr); # Länge bestimmen \
  4395.           var reg8 aint newptr = ptr+laenge; # Zeiger auf nächstes Objekt                \
  4396.           # Simple-vector: alle Pointer innerhalb eines Simple-vector aktualisieren      \
  4397.           { var reg3 uintL count = ((Svector)ptr)->length;                               \
  4398.             if (!(count==0))                                                             \
  4399.               {var reg4 object* p = &((Svector)ptr)->data[0];                            \
  4400.                dotimespL(count,count, { aktualisiere(p); p++; } );                       \
  4401.           }   }                                                                          \
  4402.           ptr = newptr; # zum nächsten Objekt weiterrücken                               \
  4403.         }
  4404.       #define aktualisiere_array(type_expr)  # ignoriert type_expr \
  4405.         { var reg7 uintL laenge = speicher_laenge_array((void*)ptr); # Länge bestimmen \
  4406.           var reg8 aint newptr = ptr+laenge; # Zeiger auf nächstes Objekt              \
  4407.           # nicht-simpler Array: Datenvektor aktualisieren                             \
  4408.           { var reg3 object* p = &((Array)ptr)->data;                                  \
  4409.             aktualisiere(p);                                                           \
  4410.           }                                                                            \
  4411.           ptr = newptr; # zum nächsten Objekt weiterrücken                             \
  4412.         }
  4413.       #define aktualisiere_record(type_expr)  # ignoriert type_expr \
  4414.         { var reg7 uintL laenge = speicher_laenge_record((void*)ptr); # Länge bestimmen \
  4415.           var reg8 aint newptr = ptr+laenge; # Zeiger auf nächstes Objekt               \
  4416.           # Record: alle Pointer innerhalb eines Record aktualisieren                   \
  4417.           { # Beim Aktualisieren von Pointern verliert der Aufbau von                   \
  4418.             # Hash-Tables seine Gültigkeit (denn die Hashfunktion eines                 \
  4419.             # Objekts hängt von seiner Adresse ab, die sich ja jetzt                    \
  4420.             # verändert).                                                               \
  4421.             if (((Record)ptr)->rectype == Rectype_Hashtable) # eine Hash-Table ?        \
  4422.               { mark_ht_invalid((Hashtable)ptr); } # ja -> für Reorganisation vormerken \
  4423.             elif (aktualisiere_fpointer_invalid && (((Record)ptr)->rectype == Rectype_Fpointer)) # Foreign-Pointer ? \
  4424.               { mark_fp_invalid((Record)ptr); } # ja -> evtl. ungültig machen           \
  4425.            {var reg3 uintC count = (((Record)ptr)->rectype < 0 ? ((Srecord)ptr)->reclength : ((Xrecord)ptr)->reclength); \
  4426.             if (!(count==0))                                                            \
  4427.               { var reg4 object* p = &((Record)ptr)->recdata[0];                        \
  4428.                 dotimespC(count,count, { aktualisiere(p); p++; } );                     \
  4429.           }}  }                                                                         \
  4430.           ptr = newptr; # zum nächsten Objekt weiterrücken                              \
  4431.         }
  4432.       #define aktualisiere_varobjects()  \
  4433.         for_each_varobject_page(page,                                               \
  4434.           { # Fallunterscheidung nach:                                              \
  4435.               # Symbol; Simple-Vector; Nicht-simpler Array;                         \
  4436.               # Record (insbes. Hash-Table); Rest.                                  \
  4437.             switch (heapnr)                                                         \
  4438.               { case_symbol:                                                        \
  4439.                   aktualisiere_page(page,aktualisiere_symbol); break;               \
  4440.                 case_svector:                                                       \
  4441.                   aktualisiere_page(page,aktualisiere_svector); break;              \
  4442.                 case_array1: case_obvector: case_ostring: case_ovector:             \
  4443.                   aktualisiere_page(page,aktualisiere_array); break;                \
  4444.                 case_record:                                                        \
  4445.                   aktualisiere_page(page,aktualisiere_record); break;               \
  4446.                 default:                                                            \
  4447.                   break; # alle anderen enthalten keine zu aktualisierenden Pointer \
  4448.                          # -> nichts tun                                            \
  4449.           }   }                                                                     \
  4450.           );
  4451.       #endif
  4452.     #ifdef GENERATIONAL_GC
  4453.     # Pointer in den Objekten der alten Generation aktualisieren:
  4454.       local void aktualisiere_old_generation (void);
  4455.       local void aktualisiere_at (object* ptr);
  4456.       local void aktualisiere_at(ptr)
  4457.         var reg3 object* ptr;
  4458.         { aktualisiere(ptr); }
  4459.       local void aktualisiere_old_generation()
  4460.         { var reg7 uintL heapnr;
  4461.           for (heapnr=0; heapnr<heapcount; heapnr++)
  4462.             if (is_heap_containing_objects(heapnr)) # Objekte, die keine Pointer enthalten,
  4463.                                                     # braucht man nicht zu durchlaufen.
  4464.               { var reg6 Heap* heap = &mem.heaps[heapnr];
  4465.                 var reg4 aint gen0_start = heap->heap_gen0_start;
  4466.                 var reg5 aint gen0_end = heap->heap_gen0_end;
  4467.                 if (gen0_start < gen0_end)
  4468.                   if (heap->physpages==NULL)
  4469.                     { walk_area_(heapnr,gen0_start,gen0_end,aktualisiere_at); } # fallback
  4470.                     else
  4471.                     { var reg3 physpage_state* physpage = heap->physpages;
  4472.                       gen0_start &= -physpagesize;
  4473.                       do { if ((physpage->protection == PROT_NONE)
  4474.                                || (physpage->protection == PROT_READ)
  4475.                               )
  4476.                              # Cache ausnutzen, gecachte Pointer aktualisieren:
  4477.                              { var reg2 uintL count = physpage->cache_size;
  4478.                                if (count > 0)
  4479.                                  { var reg1 old_new_pointer* ptr = physpage->cache;
  4480.                                    dotimespL(count,count, { aktualisiere(&ptr->o); ptr++; } );
  4481.                                    if (!(physpage->protection == PROT_NONE))
  4482.                                      { xmmprotect(gen0_start,physpagesize,PROT_NONE);
  4483.                                        physpage->protection = PROT_NONE;
  4484.                              }   }   }
  4485.                              else
  4486.                              # ganzen Page-Inhalt aktualisieren:
  4487.                              { walk_physpage_(heapnr,physpage,gen0_start+physpagesize,gen0_end,aktualisiere_at); }
  4488.                            gen0_start += physpagesize;
  4489.                            physpage++;
  4490.                          }
  4491.                          while (gen0_start < gen0_end);
  4492.         }     }     }
  4493.       #undef aktualisiere_at
  4494.     #endif
  4495.  
  4496. # Zweite SWEEP-Phase:
  4497.   # Verschiebung eines Objekts variabler Länge, p1 und p2 weiterrücken:
  4498.   # move_aligned_p1_p2(count);
  4499.   #if (varobject_alignment==1)
  4500.     #define uintV  uintB
  4501.   #elif (varobject_alignment==2)
  4502.     #define uintV  uintW
  4503.   #elif (varobject_alignment==4)
  4504.     #define uintV  uintL
  4505.   #elif (varobject_alignment==8)
  4506.     #define uintV  uintL2
  4507.   #else
  4508.     #error "Unbekannter Wert von 'varobject_alignment'!"
  4509.   #endif
  4510.   #ifdef GNU # so läßt sich's besser optimieren
  4511.     #ifdef fast_dotimesL
  4512.       #define move_aligned_p1_p2(count)  \
  4513.         dotimespL(count,count/varobject_alignment, *((uintV*)p2)++ = *((uintV*)p1)++; )
  4514.     #else
  4515.       #define move_aligned_p1_p2(count)  \
  4516.         do { *((uintV*)p2)++ = *((uintV*)p1)++; count -= varobject_alignment; } until (count==0)
  4517.     #endif
  4518.   #else # andere Compiler akzeptieren ((type*)p)++ nicht.
  4519.     # Wie effizient ist das hier ??
  4520.     #define move_aligned_p1_p2(count)  \
  4521.       do { *(uintV*)p2 = *(uintV*)p1;                            \
  4522.            p1 += varobject_alignment; p2 += varobject_alignment; \
  4523.            count -= varobject_alignment;                         \
  4524.          }                                                                              \
  4525.          until (count==0)
  4526.   #endif
  4527.   # Die Objekte variabler Länge werden an die vorher berechneten
  4528.   # neuen Plätze geschoben.
  4529.   #ifdef SPVW_PURE
  4530.   local void gc_sweep2_varobject_page (Page* page, uintL heapnr);
  4531.   local void gc_sweep2_varobject_page PARM2(page,heapnr,
  4532.     var reg5 Page* page,
  4533.     var reg6 uintL heapnr)
  4534.   #else
  4535.   local void gc_sweep2_varobject_page (Page* page);
  4536.   local void gc_sweep2_varobject_page PARM1(page,
  4537.     var reg5 Page* page)
  4538.   #endif
  4539.     # Von unten nach oben durchgehen und dabei runterschieben:
  4540.     { var reg1 aint p1 = (aint)type_pointable(0,page->page_gcpriv.firstmarked); # Source-Pointer, erstes markiertes Objekt
  4541.       var reg4 aint p1end = page->page_end;
  4542.       var reg2 aint p2 = page->page_start; # Ziel-Pointer
  4543.       var_speicher_laenge_;
  4544.       until (p1==p1end) # obere Grenze erreicht -> fertig
  4545.         { # nächstes Objekt hat Adresse p1
  4546.           if (marked(p1)) # markiert?
  4547.             { unmark(p1); # Markierung löschen
  4548.               # Objekt behalten und verschieben:
  4549.              {var reg3 uintL count = calc_speicher_laenge(p1); # Länge (durch varobject_alignment teilbar, >0)
  4550.               if (!(p1==p2)) # falls Verschiebung nötig
  4551.                 { move_aligned_p1_p2(count); } # verschieben und weiterrücken
  4552.                 else # sonst nur weiterrücken:
  4553.                 { p1 += count; p2 += count; }
  4554.             }}
  4555.             else
  4556.             { p1 = (aint)type_pointable(0,*(object*)p1); } # mit Pointer (Typinfo=0) zum nächsten markierten Objekt
  4557.         }
  4558.       page->page_end = p2; # obere Grenze der Objekte variabler Länge neu setzen
  4559.     }
  4560.  
  4561. #ifdef GENERATIONAL_GC
  4562.  
  4563.   # Baut einen Cache aller Pointer in der alten Generation.
  4564.   # Die neue Generation ist leer; Pointer in die neue Generation gibt es daher keine!
  4565.   local void build_old_generation_cache (uintL heapnr);
  4566.   local void build_old_generation_cache(heapnr)
  4567.     var reg10 uintL heapnr;
  4568.     { if (is_heap_containing_objects(heapnr)) # Objekte, die keine Pointer enthalten, brauchen keinen Cache.
  4569.         { var reg8 Heap* heap = &mem.heaps[heapnr];
  4570.           var reg6 aint gen0_start = heap->heap_gen0_start;
  4571.           var reg7 aint gen0_end = heap->heap_gen0_end;
  4572.           var reg10 aint gen0_start_pa = gen0_start & -physpagesize; # page-aligned
  4573.           var reg10 aint gen0_end_pa = (gen0_end + (physpagesize-1)) & -physpagesize; # page-aligned
  4574.          {var reg9 uintL physpage_count = (gen0_end_pa - gen0_start_pa) >> physpageshift;
  4575.           if (physpage_count==0)
  4576.             { xfree(heap->physpages); heap->physpages = NULL; }
  4577.             else
  4578.             { heap->physpages = xrealloc(heap->physpages,physpage_count*sizeof(physpage_state));
  4579.               if (!(heap->physpages==NULL))
  4580.                 { # Wenn wir fertig sind, wird sowohl Cache als auch Speicherinhalt
  4581.                   # gültig sein:
  4582.                   xmmprotect(gen0_start_pa, gen0_end_pa-gen0_start_pa, PROT_READ);
  4583.                   # heap->physpages[0..physpage_count-1] füllen:
  4584.                   { var reg1 physpage_state* physpage = heap->physpages;
  4585.                     var reg2 uintL count;
  4586.                     dotimespL(count,physpage_count,
  4587.                       { physpage->protection = PROT_READ;
  4588.                         physpage->cache_size = 0; physpage->cache = NULL;
  4589.                         physpage++;
  4590.                       });
  4591.                   }
  4592.                   if (is_cons_heap(heapnr))
  4593.                     # Conses u.ä.
  4594.                     { # Von gen0_start bis gen0_end sind alles Pointer.
  4595.                       var reg1 physpage_state* physpage = heap->physpages;
  4596.                       var reg2 uintL count;
  4597.                       #ifndef SPVW_MIXED_BLOCKS_OPPOSITE
  4598.                       # Alle Seiten bis auf die letzte voll, die letzte teilweise voll.
  4599.                       dotimesL(count,physpage_count-1,
  4600.                         { # für i=0,1,...:
  4601.                           #   gen0_start = heap->heap_gen0_start + i*physpagesize
  4602.                           #   physpage = &heap->physpages[i]
  4603.                           physpage->continued_addr = (object*)gen0_start;
  4604.                           physpage->continued_count = physpagesize/sizeof(object);
  4605.                           gen0_start += physpagesize;
  4606.                           physpage->firstobject = gen0_start;
  4607.                           physpage++;
  4608.                         });
  4609.                       physpage->continued_addr = (object*)gen0_start;
  4610.                       physpage->continued_count = (gen0_end-gen0_start)/sizeof(object);
  4611.                       physpage->firstobject = gen0_end;
  4612.                       #else
  4613.                       # Alle Seiten bis auf die erste voll, die erste teilweise voll.
  4614.                       physpage->continued_addr = (object*)gen0_start;
  4615.                       physpage->continued_count = ((gen0_start_pa+physpagesize)-gen0_start)/sizeof(object);
  4616.                       physpage->firstobject = gen0_start = gen0_start_pa+physpagesize;
  4617.                       dotimesL(count,physpage_count-1,
  4618.                         { physpage++;
  4619.                           # für i=1,...:
  4620.                           #   gen0_start = (heap->heap_gen0_start & -physpagesize) + i*physpagesize
  4621.                           #   physpage = &heap->physpages[i]
  4622.                           physpage->continued_addr = (object*)gen0_start;
  4623.                           physpage->continued_count = physpagesize/sizeof(object);
  4624.                           gen0_start += physpagesize;
  4625.                           physpage->firstobject = gen0_start;
  4626.                         });
  4627.                       #endif
  4628.                     }
  4629.                     else
  4630.                     # is_varobject_heap(heapnr), Objekte variabler Länge
  4631.                     { var reg1 physpage_state* physpage = heap->physpages;
  4632.                       var reg5 aint objptr = gen0_start;
  4633.                       # Für i=0,1,... ist
  4634.                       #   gen0_start = heap->heap_gen0_start + i*physpagesize
  4635.                       #   physpage = &heap->physpages[i]
  4636.                       # Mit wachsendem i geht man von einer Seite zur nächsten.
  4637.                       # Gleichzeitig geht man von einem Objekt zum nächsten und markiert
  4638.                       # alle Pointer zwischen objptr (Pointer auf das aktuelle Objekt)
  4639.                       # und nextptr (Pointer auf das nächste Objekt). Glücklicherweise
  4640.                       # kommen in allen unseren Objekten die Pointer am Stück:
  4641.                       # ab ptr kommen count Pointer.
  4642.                       # Das Intervall ptr...ptr+count*sizeof(object) wird nun zerlegt.
  4643.                       #ifdef SPVW_PURE
  4644.                       switch (heapnr)
  4645.                         { case_symbol: # Symbol
  4646.                             physpage->continued_addr = (object*)gen0_start; # irrelevant
  4647.                             physpage->continued_count = 0;
  4648.                             physpage->firstobject = gen0_start;
  4649.                             gen0_start += physpagesize; physpage++;
  4650.                             while (objptr < gen0_end)
  4651.                               { var reg4 aint nextptr = objptr + size_symbol();
  4652.                                 # Hier ist gen0_start-physpagesize <= objptr < gen0_start.
  4653.                                 if (nextptr >= gen0_start)
  4654.                                   { var reg2 aint ptr = objptr+symbol_objects_offset;
  4655.                                     var reg3 uintC count = (sizeof(symbol_)-symbol_objects_offset)/sizeof(object);
  4656.                                     if (ptr < gen0_start)
  4657.                                       { physpage->continued_addr = (object*)gen0_start;
  4658.                                         physpage->continued_count = count - (gen0_start-ptr)/sizeof(object);
  4659.                                       }
  4660.                                       else
  4661.                                       { physpage->continued_addr = (object*)ptr;
  4662.                                         physpage->continued_count = count;
  4663.                                       }
  4664.                                     physpage->firstobject = nextptr;
  4665.                                     # Man überquert höchstens eine Seitengrenze auf einmal.
  4666.                                     gen0_start += physpagesize; physpage++;
  4667.                                   }
  4668.                                 objptr = nextptr;
  4669.                               }
  4670.                             if (!(objptr == gen0_end)) abort();
  4671.                             break;
  4672.                           case_array1: case_obvector: case_ostring: case_ovector: # nicht-simple Arrays:
  4673.                             physpage->continued_addr = (object*)gen0_start; # irrelevant
  4674.                             physpage->continued_count = 0;
  4675.                             physpage->firstobject = gen0_start;
  4676.                             gen0_start += physpagesize; physpage++;
  4677.                             while (objptr < gen0_end)
  4678.                               { var reg3 aint nextptr = objptr + speicher_laenge_array((Array)objptr);
  4679.                                 # Hier ist gen0_start-physpagesize <= objptr < gen0_start.
  4680.                                 if (nextptr >= gen0_start)
  4681.                                   { var reg2 aint ptr = (aint)&((Array)objptr)->data;
  4682.                                     # count = 1;
  4683.                                     if (ptr < gen0_start)
  4684.                                       { physpage->continued_addr = (object*)gen0_start; # irrelevant
  4685.                                         physpage->continued_count = 0;
  4686.                                       }
  4687.                                       else
  4688.                                       { physpage->continued_addr = (object*)ptr;
  4689.                                         physpage->continued_count = 1;
  4690.                                       }
  4691.                                     # Man überquerte höchstens eine Seitengrenze.
  4692.                                     # Danach kommen (bis nextptr) keine Pointer mehr.
  4693.                                     loop
  4694.                                       { physpage->firstobject = nextptr;
  4695.                                         gen0_start += physpagesize; physpage++;
  4696.                                         if (nextptr < gen0_start) break;
  4697.                                         physpage->continued_addr = (object*)gen0_start; # irrelevant
  4698.                                         physpage->continued_count = 0;
  4699.                                       }
  4700.                                   }
  4701.                                 objptr = nextptr;
  4702.                               }
  4703.                             if (!(objptr == gen0_end)) abort();
  4704.                             break;
  4705.                           case_svector: # simple-vector
  4706.                             physpage->continued_addr = (object*)gen0_start; # irrelevant
  4707.                             physpage->continued_count = 0;
  4708.                             physpage->firstobject = gen0_start;
  4709.                             gen0_start += physpagesize; physpage++;
  4710.                             while (objptr < gen0_end)
  4711.                               { var reg3 uintL count = ((Svector)objptr)->length;
  4712.                                 var reg4 aint nextptr = objptr + size_svector(count);
  4713.                                 # Hier ist gen0_start-physpagesize <= objptr < gen0_start.
  4714.                                 if (nextptr >= gen0_start)
  4715.                                   { var reg2 aint ptr = (aint)&((Svector)objptr)->data[0];
  4716.                                     if (ptr < gen0_start)
  4717.                                       { var reg3 uintL count_thispage = (gen0_start-ptr)/sizeof(object);
  4718.                                         if ((varobject_alignment == sizeof(object)) # das erzwingt count >= count_thispage
  4719.                                             || (count >= count_thispage)
  4720.                                            )
  4721.                                           { count -= count_thispage; }
  4722.                                           else
  4723.                                           { count = 0; }
  4724.                                         ptr = gen0_start;
  4725.                                       }
  4726.                                     do { physpage->continued_addr = (object*)ptr;
  4727.                                          gen0_start += physpagesize;
  4728.                                         {var reg3 uintL count_thispage = (gen0_start-ptr)/sizeof(object);
  4729.                                          if (count >= count_thispage)
  4730.                                            { physpage->continued_count = count_thispage;
  4731.                                              count -= count_thispage;
  4732.                                            }
  4733.                                            else
  4734.                                            { physpage->continued_count = count; count = 0; }
  4735.                                          physpage->firstobject = nextptr;
  4736.                                          physpage++;
  4737.                                          ptr = gen0_start;
  4738.                                        }}
  4739.                                        until (nextptr < gen0_start);
  4740.                                   }
  4741.                                 objptr = nextptr;
  4742.                               }
  4743.                             if (!(objptr == gen0_end)) abort();
  4744.                             break;
  4745.                           case_record: # Record
  4746.                             physpage->continued_addr = (object*)gen0_start; # irrelevant
  4747.                             physpage->continued_count = 0;
  4748.                             physpage->firstobject = gen0_start;
  4749.                             gen0_start += physpagesize; physpage++;
  4750.                             while (objptr < gen0_end)
  4751.                               { var reg3 uintC count;
  4752.                                 var reg4 aint nextptr;
  4753.                                 if (((Record)objptr)->rectype < 0)
  4754.                                   { count = ((Srecord)objptr)->reclength; nextptr = objptr + size_srecord(count); }
  4755.                                   else
  4756.                                   { count = ((Xrecord)objptr)->reclength; nextptr = objptr + size_xrecord(count,((Xrecord)objptr)->recxlength); }
  4757.                                 if (nextptr >= gen0_start)
  4758.                                   { var reg2 aint ptr = (aint)&((Record)objptr)->recdata[0];
  4759.                                     if (ptr < gen0_start)
  4760.                                       { var reg3 uintL count_thispage = (gen0_start-ptr)/sizeof(object);
  4761.                                         if ((varobject_alignment == sizeof(object)) # das erzwingt count >= count_thispage
  4762.                                             || (count >= count_thispage)
  4763.                                            )
  4764.                                           { count -= count_thispage; }
  4765.                                           else
  4766.                                           { count = 0; }
  4767.                                         ptr = gen0_start;
  4768.                                       }
  4769.                                     do { physpage->continued_addr = (object*)ptr;
  4770.                                          gen0_start += physpagesize;
  4771.                                         {var reg3 uintL count_thispage = (gen0_start-ptr)/sizeof(object);
  4772.                                          if (count >= count_thispage)
  4773.                                            { physpage->continued_count = count_thispage;
  4774.                                              count -= count_thispage;
  4775.                                            }
  4776.                                            else
  4777.                                            { physpage->continued_count = count; count = 0; }
  4778.                                          physpage->firstobject = nextptr;
  4779.                                          physpage++;
  4780.                                          ptr = gen0_start;
  4781.                                        }}
  4782.                                        until (nextptr < gen0_start);
  4783.                                   }
  4784.                                 objptr = nextptr;
  4785.                               }
  4786.                             if (!(objptr == gen0_end)) abort();
  4787.                             break;
  4788.                           default:
  4789.                             # Solche Objekte kommen nicht vor.
  4790.                             abort();
  4791.                         }
  4792.                       #else # SPVW_MIXED
  4793.                       physpage->continued_addr = (object*)gen0_start; # irrelevant
  4794.                       physpage->continued_count = 0;
  4795.                       physpage->firstobject = gen0_start;
  4796.                       gen0_start += physpagesize; physpage++;
  4797.                       while (objptr < gen0_end)
  4798.                         { switch (typecode_at(objptr)) # Typ des nächsten Objekts
  4799.                             { case_symbolwithflags: # Symbol
  4800.                                 { var reg4 aint nextptr = objptr + size_symbol();
  4801.                                   # Hier ist gen0_start-physpagesize <= objptr < gen0_start.
  4802.                                   if (nextptr >= gen0_start)
  4803.                                     { var reg2 aint ptr = objptr+symbol_objects_offset;
  4804.                                       var reg3 uintC count = (sizeof(symbol_)-symbol_objects_offset)/sizeof(object);
  4805.                                       if (ptr < gen0_start)
  4806.                                         { physpage->continued_addr = (object*)gen0_start;
  4807.                                           physpage->continued_count = count - (gen0_start-ptr)/sizeof(object);
  4808.                                         }
  4809.                                         else
  4810.                                         { physpage->continued_addr = (object*)ptr;
  4811.                                           physpage->continued_count = count;
  4812.                                         }
  4813.                                       physpage->firstobject = nextptr;
  4814.                                       # Man überquert höchstens eine Seitengrenze auf einmal.
  4815.                                       gen0_start += physpagesize; physpage++;
  4816.                                     }
  4817.                                   objptr = nextptr;
  4818.                                 }
  4819.                                 break;
  4820.                               case_array1: case_obvector: case_ostring: case_ovector: # nicht-simple Arrays:
  4821.                                 { var reg3 aint nextptr = objptr + speicher_laenge((Array)objptr);
  4822.                                   # Hier ist gen0_start-physpagesize <= objptr < gen0_start.
  4823.                                   if (nextptr >= gen0_start)
  4824.                                     { var reg2 aint ptr = (aint)&((Array)objptr)->data;
  4825.                                       # count = 1;
  4826.                                       if (ptr < gen0_start)
  4827.                                         { physpage->continued_addr = (object*)gen0_start; # irrelevant
  4828.                                           physpage->continued_count = 0;
  4829.                                         }
  4830.                                         else
  4831.                                         { physpage->continued_addr = (object*)ptr;
  4832.                                           physpage->continued_count = 1;
  4833.                                         }
  4834.                                       # Man überquerte höchstens eine Seitengrenze.
  4835.                                       # Danach kommen (bis nextptr) keine Pointer mehr.
  4836.                                       loop
  4837.                                         { physpage->firstobject = nextptr;
  4838.                                           gen0_start += physpagesize; physpage++;
  4839.                                           if (nextptr < gen0_start) break;
  4840.                                           physpage->continued_addr = (object*)gen0_start; # irrelevant
  4841.                                           physpage->continued_count = 0;
  4842.                                         }
  4843.                                     }
  4844.                                   objptr = nextptr;
  4845.                                 }
  4846.                                 break;
  4847.                               case_svector: # simple-vector
  4848.                                 { var reg3 uintL count = ((Svector)objptr)->length;
  4849.                                   var reg4 aint nextptr = objptr + size_svector(count);
  4850.                                   # Hier ist gen0_start-physpagesize <= objptr < gen0_start.
  4851.                                   if (nextptr >= gen0_start)
  4852.                                     { var reg2 aint ptr = (aint)&((Svector)objptr)->data[0];
  4853.                                       if (ptr < gen0_start)
  4854.                                         { var reg3 uintL count_thispage = (gen0_start-ptr)/sizeof(object);
  4855.                                           if ((varobject_alignment == sizeof(object)) # das erzwingt count >= count_thispage
  4856.                                               || (count >= count_thispage)
  4857.                                              )
  4858.                                             { count -= count_thispage; }
  4859.                                             else
  4860.                                             { count = 0; }
  4861.                                           ptr = gen0_start;
  4862.                                         }
  4863.                                       do { physpage->continued_addr = (object*)ptr;
  4864.                                            gen0_start += physpagesize;
  4865.                                           {var reg3 uintL count_thispage = (gen0_start-ptr)/sizeof(object);
  4866.                                            if (count >= count_thispage)
  4867.                                              { physpage->continued_count = count_thispage;
  4868.                                                count -= count_thispage;
  4869.                                              }
  4870.                                              else
  4871.                                              { physpage->continued_count = count; count = 0; }
  4872.                                            physpage->firstobject = nextptr;
  4873.                                            physpage++;
  4874.                                            ptr = gen0_start;
  4875.                                          }}
  4876.                                          until (nextptr < gen0_start);
  4877.                                     }
  4878.                                   objptr = nextptr;
  4879.                                 }
  4880.                                 break;
  4881.                               case_record: # Record
  4882.                                 { var reg3 uintC count;
  4883.                                   var reg4 aint nextptr;
  4884.                                   if (((Record)objptr)->rectype < 0)
  4885.                                     { count = ((Srecord)objptr)->reclength; nextptr = objptr + size_srecord(count); }
  4886.                                     else
  4887.                                     { count = ((Xrecord)objptr)->reclength; nextptr = objptr + size_xrecord(count,((Xrecord)objptr)->recxlength); }
  4888.                                   if (nextptr >= gen0_start)
  4889.                                     { var reg2 aint ptr = (aint)&((Record)objptr)->recdata[0];
  4890.                                       if (ptr < gen0_start)
  4891.                                         { var reg3 uintL count_thispage = (gen0_start-ptr)/sizeof(object);
  4892.                                           if ((varobject_alignment == sizeof(object)) # das erzwingt count >= count_thispage
  4893.                                               || (count >= count_thispage)
  4894.                                              )
  4895.                                             { count -= count_thispage; }
  4896.                                             else
  4897.                                             { count = 0; }
  4898.                                           ptr = gen0_start;
  4899.                                         }
  4900.                                       do { physpage->continued_addr = (object*)ptr;
  4901.                                            gen0_start += physpagesize;
  4902.                                           {var reg3 uintL count_thispage = (gen0_start-ptr)/sizeof(object);
  4903.                                            if (count >= count_thispage)
  4904.                                              { physpage->continued_count = count_thispage;
  4905.                                                count -= count_thispage;
  4906.                                              }
  4907.                                              else
  4908.                                              { physpage->continued_count = count; count = 0; }
  4909.                                            physpage->firstobject = nextptr;
  4910.                                            physpage++;
  4911.                                            ptr = gen0_start;
  4912.                                          }}
  4913.                                          until (nextptr < gen0_start);
  4914.                                     }
  4915.                                   objptr = nextptr;
  4916.                                 }
  4917.                                 break;
  4918.                               default: # simple-bit-vector, simple-string, bignum, float
  4919.                                 # Keine Pointer.
  4920.                                 objptr += speicher_laenge((Varobject)objptr);
  4921.                                 while (objptr >= gen0_start)
  4922.                                   { physpage->continued_addr = (object*)gen0_start; # irrelevant
  4923.                                     physpage->continued_count = 0;
  4924.                                     physpage->firstobject = objptr;
  4925.                                     gen0_start += physpagesize; physpage++;
  4926.                                   }
  4927.                                 break;
  4928.                         }   }
  4929.                       if (!(objptr == gen0_end)) abort();
  4930.                       #endif
  4931.                     }
  4932.                 }
  4933.     }   }}  }
  4934.  
  4935.   # Baut einen Cache aller Pointer von der alten in die neue Generation.
  4936.   local void rebuild_old_generation_cache (uintL heapnr);
  4937.   local void rebuild_old_generation_cache(heapnr)
  4938.     var reg10 uintL heapnr;
  4939.     { if (is_heap_containing_objects(heapnr)) # Objekte, die keine Pointer enthalten, brauchen keinen Cache.
  4940.         { var reg9 Heap* heap = &mem.heaps[heapnr];
  4941.           var reg6 aint gen0_start = heap->heap_gen0_start;
  4942.           var reg7 aint gen0_end = heap->heap_gen0_end;
  4943.           if ((gen0_start < gen0_end) && !(heap->physpages==NULL))
  4944.             { var reg5 physpage_state* physpage = heap->physpages;
  4945.               gen0_start &= -physpagesize;
  4946.               do { if (physpage->protection == PROT_READ_WRITE)
  4947.                      { var DYNAMIC_ARRAY(reg8,cache_buffer,old_new_pointer,physpagesize/sizeof(object));
  4948.                        var reg4 old_new_pointer* cache_ptr = &cache_buffer[0];
  4949.                        #define cache_at(obj)  \
  4950.                          { var reg1 tint type = mtypecode(obj);                              \
  4951.                            if (!immediate_type_p(type)) # unverschieblich?                   \
  4952.                              if (!in_old_generation(obj,type,mem.heapnr_from_type[type]))    \
  4953.                                # obj ist ein Pointer in die neue Generation -> merken        \
  4954.                                { cache_ptr->p = &(obj); cache_ptr->o = (obj); cache_ptr++; } \
  4955.                          }
  4956.                        walk_physpage(heapnr,physpage,gen0_start+physpagesize,gen0_end,cache_at);
  4957.                        #undef cache_at
  4958.                       {var reg3 uintL cache_size = cache_ptr - &cache_buffer[0];
  4959.                        if (cache_size <= (physpagesize/sizeof(object))/4)
  4960.                          # Wir cachen eine Seite nur, falls maximal 25% mit Pointern auf
  4961.                          # die neue Generation belegt ist. Sonst ist das Anlegen eines Cache
  4962.                          # Platzverschwendung.
  4963.                          { physpage->cache_size = cache_size;
  4964.                            if (cache_size == 0)
  4965.                              { xfree(physpage->cache); physpage->cache = NULL; }
  4966.                              else
  4967.                              { physpage->cache = (old_new_pointer*) xrealloc(physpage->cache,cache_size*sizeof(old_new_pointer));
  4968.                                if (physpage->cache == NULL)
  4969.                                  goto no_cache;
  4970.                                { var reg2 old_new_pointer* ptr1 = &cache_buffer[0];
  4971.                                  var reg1 old_new_pointer* ptr2 = physpage->cache;
  4972.                                  dotimespL(cache_size,cache_size, { *ptr2++ = *ptr1++; } );
  4973.                              } }
  4974.                            xmmprotect(gen0_start,physpagesize,PROT_READ);
  4975.                            physpage->protection = PROT_READ;
  4976.                          }
  4977.                          else
  4978.                          { xfree(physpage->cache); physpage->cache = NULL;
  4979.                            no_cache: ;
  4980.                          }
  4981.                        FREE_DYNAMIC_ARRAY(cache_buffer);
  4982.                      }}
  4983.                    gen0_start += physpagesize;
  4984.                    physpage++;
  4985.                  }
  4986.                  while (gen0_start < gen0_end);
  4987.     }   }   }
  4988.  
  4989. #endif
  4990.  
  4991. #if defined(DEBUG_SPVW) && defined(GENERATIONAL_GC)
  4992.   # Kontrolle des Cache der old_new_pointer:
  4993.   #define CHECK_GC_CACHE()  gc_cache_check()
  4994.   local void gc_cache_check (void);
  4995.   local void gc_cache_check()
  4996.     { var reg10 uintL heapnr;
  4997.       for (heapnr=0; heapnr<heapcount; heapnr++)
  4998.         if (is_heap_containing_objects(heapnr))
  4999.           { var reg7 Heap* heap = &mem.heaps[heapnr];
  5000.             var reg3 aint gen0_start = heap->heap_gen0_start;
  5001.             var reg5 aint gen0_end = heap->heap_gen0_end;
  5002.             var reg8 aint gen0_start_pa = gen0_start & -physpagesize; # page-aligned
  5003.             var reg9 aint gen0_end_pa = (gen0_end + (physpagesize-1)) & -physpagesize; # page-aligned
  5004.             var reg6 uintL physpage_count = (gen0_end_pa - gen0_start_pa) >> physpageshift;
  5005.             if (physpage_count > 0)
  5006.               { var reg1 physpage_state* physpage = heap->physpages;
  5007.                 if (!(physpage==NULL))
  5008.                   { var reg4 uintL count;
  5009.                     dotimespL(count,physpage_count,
  5010.                       { var reg2 aint end = (gen0_start & -physpagesize) + physpagesize;
  5011.                         if (gen0_end < end) { end = gen0_end; }
  5012.                         if (physpage->firstobject < end) { end = physpage->firstobject; }
  5013.                         if (!(gen0_start <= (aint)physpage->continued_addr)) abort();
  5014.                         if (!((aint)physpage->continued_addr + physpage->continued_count*sizeof(object) <= end)) abort();
  5015.                         gen0_start &= -physpagesize;
  5016.                         gen0_start += physpagesize;
  5017.                         physpage++;
  5018.                       });
  5019.     }     }   }   }
  5020.   # Kontrolle, ob alle Pointer im Cache aufgeführt sind und nicht in den Wald zeigen.
  5021.   #define CHECK_GC_GENERATIONAL()  gc_overall_check()
  5022.   local void gc_overall_check (void);
  5023.     # Kontrolle eines einzelnen Pointers:
  5024.     local boolean gc_check_at (object* objptr);
  5025.     local boolean gc_check_at(objptr)
  5026.       var reg5 object* objptr;
  5027.       { var reg4 object obj = *objptr;
  5028.         var reg3 tint type = typecode(obj);
  5029.         #ifdef SPVW_PURE
  5030.         if (is_unused_heap(type))
  5031.           return FALSE;
  5032.         #else
  5033.         if (immediate_type_p(type))
  5034.           return FALSE;
  5035.         #endif
  5036.        {var reg2 aint addr = canonaddr(obj);
  5037.         var reg1 Heap* heap;
  5038.         #ifdef SPVW_PURE
  5039.         heap = &mem.heaps[type];
  5040.         #else # SPVW_MIXED
  5041.         heap = &mem.heaps[mem.heapnr_from_type[type]];
  5042.         #endif
  5043.         if ((addr >= heap->heap_gen0_start) && (addr < heap->heap_gen0_end))
  5044.           return FALSE;
  5045.         #ifdef SPVW_MIXED_BLOCKS_OPPOSITE
  5046.         if (is_cons_heap(mem.heapnr_from_type[type]))
  5047.           { if ((addr >= heap->heap_start) && (addr < heap->heap_gen1_end))
  5048.               return TRUE; # Pointer in die neue Generation
  5049.           }
  5050.           else
  5051.         #endif
  5052.           { if ((addr >= heap->heap_gen1_start) && (addr < heap->heap_end))
  5053.               return TRUE; # Pointer in die neue Generation
  5054.           }
  5055.         if ((type == symbol_type)
  5056.             && (as_oint(obj) - as_oint(symbol_tab_ptr_as_object(&symbol_tab))
  5057.                 < (sizeof(symbol_tab)<<(oint_addr_shift-addr_shift))
  5058.            )   )
  5059.           return FALSE;
  5060.         abort();
  5061.       }}
  5062.   local void gc_overall_check()
  5063.     { var reg8 uintL heapnr;
  5064.       for (heapnr=0; heapnr<heapcount; heapnr++)
  5065.         if (is_heap_containing_objects(heapnr))
  5066.           { var reg6 Heap* heap = &mem.heaps[heapnr];
  5067.             var reg5 aint gen0_start = heap->heap_gen0_start;
  5068.             var reg7 aint gen0_end = heap->heap_gen0_end;
  5069.             if (gen0_start < gen0_end)
  5070.               if (heap->physpages==NULL)
  5071.                 { walk_area_(heapnr,gen0_start,gen0_end,gc_check_at); } # fallback
  5072.                 else
  5073.                 { var reg4 physpage_state* physpage = heap->physpages;
  5074.                   gen0_start &= -physpagesize;
  5075.                   do { if (physpage->protection == PROT_READ)
  5076.                          # Stimmen die Pointer im Cache und in der Seite überein?
  5077.                          { var reg3 uintL count = physpage->cache_size;
  5078.                            if (count > 0)
  5079.                              { var reg1 old_new_pointer* ptr = physpage->cache;
  5080.                                var reg2 aint last_p = gen0_start-1;
  5081.                                dotimespL(count,count,
  5082.                                  { if (!eq(*(ptr->p),ptr->o))
  5083.                                      abort();
  5084.                                    if (!(last_p < (aint)ptr->p))
  5085.                                      abort();
  5086.                                    last_p = (aint)ptr->p;
  5087.                                    ptr++;
  5088.                                  });
  5089.                          }   }
  5090.                        gen0_start += physpagesize;
  5091.                        if (physpage->protection == PROT_NONE)
  5092.                          # Cache ausnutzen, gecachte Pointer durchlaufen:
  5093.                          { var reg2 uintL count = physpage->cache_size;
  5094.                            if (count > 0)
  5095.                              { var reg1 old_new_pointer* ptr = physpage->cache;
  5096.                                dotimespL(count,count, { gc_check_at(&ptr->o); ptr++; } );
  5097.                          }   }
  5098.                          else
  5099.                          # ganzen Page-Inhalt durchlaufen:
  5100.                          { walk_physpage_(heapnr,physpage,gen0_start,gen0_end,gc_check_at); }
  5101.                        physpage++;
  5102.                      }
  5103.                      while (gen0_start < gen0_end);
  5104.     }     }     }
  5105.   # Zur Fehlersuche: Verwaltungsdaten vor und nach der GC retten.
  5106.   #define SAVE_GC_DATA()  save_gc_data()
  5107.   local void save_gc_data (void);
  5108.   typedef struct gc_data { struct gc_data * next; Heap heaps[heapcount]; } *
  5109.           gc_data_list;
  5110.   local var gc_data_list gc_history;
  5111.   local void save_gc_data()
  5112.     { # Kopiere die aktuellen GC-Daten an den Kopf der Liste gc_history :
  5113.       var reg10 gc_data_list new_data = (struct gc_data *) malloc(sizeof(struct gc_data));
  5114.       if (!(new_data==NULL))
  5115.         { var reg9 uintL heapnr;
  5116.           for (heapnr=0; heapnr<heapcount; heapnr++)
  5117.             { var reg8 Heap* heap = &new_data->heaps[heapnr];
  5118.               *heap = mem.heaps[heapnr];
  5119.               if (!(heap->physpages==NULL))
  5120.                 { var reg7 uintL physpagecount =
  5121.                     (((heap->heap_gen0_end + (physpagesize-1)) & -physpagesize)
  5122.                      - (heap->heap_gen0_start & -physpagesize)
  5123.                     ) >> physpageshift;
  5124.                   var reg6 physpage_state* physpages = NULL;
  5125.                   if (physpagecount > 0)
  5126.                     physpages = (physpage_state*) malloc(physpagecount*sizeof(physpage_state));
  5127.                   if (!(physpages==NULL))
  5128.                     { var reg5 uintL i;
  5129.                       for (i=0; i<physpagecount; i++)
  5130.                         { physpages[i] = heap->physpages[i];
  5131.                           if (!(physpages[i].cache==NULL))
  5132.                             { var reg4 uintC cache_size = physpages[i].cache_size;
  5133.                               if (cache_size > 0)
  5134.                                 { var reg2 old_new_pointer* cache = (old_new_pointer*) malloc(cache_size*sizeof(old_new_pointer));
  5135.                                   if (!(cache==NULL))
  5136.                                     { var reg3 old_new_pointer* old_cache = physpages[i].cache;
  5137.                                       var reg1 uintC j;
  5138.                                       for (j=0; j<cache_size; j++)
  5139.                                         { cache[j] = old_cache[j]; }
  5140.                                     }
  5141.                                   physpages[i].cache = cache;
  5142.                     }   }   }   }
  5143.                   heap->physpages = physpages;
  5144.             }   }
  5145.           new_data->next = gc_history;
  5146.           gc_history = new_data;
  5147.     }   }
  5148. #else
  5149.   #define CHECK_GC_CACHE()
  5150.   #define CHECK_GC_GENERATIONAL()
  5151.   #define SAVE_GC_DATA()
  5152. #endif
  5153.  
  5154. #if defined(DEBUG_SPVW) && !defined(GENERATIONAL_GC)
  5155.   # Kontrolle, ob auch alles unmarkiert ist:
  5156.   #define CHECK_GC_UNMARKED()  gc_unmarkcheck()
  5157.   local void gc_unmarkcheck (void);
  5158.   local void gc_unmarkcheck()
  5159.     { for_each_varobject_page(page,
  5160.         # Von unten nach oben durchgehen:
  5161.         { var reg1 aint p1 = page->page_start;
  5162.           var reg4 aint p1end = page->page_end;
  5163.           var_speicher_laenge_;
  5164.           until (p1==p1end) # obere Grenze erreicht -> fertig
  5165.             { # nächstes Objekt hat Adresse p1
  5166.               if (marked(p1)) # markiert?
  5167.                 { 
  5168.                   asciz_out(NLstring);
  5169.                   //: DEUTSCH "Objekt"
  5170.                   //: ENGLISH "Objekt"
  5171.                   //: FRANCAIS "Objekt"
  5172.                   asciz_out(GETTEXT("Objekt"));
  5173.                   asciz_out(" 0x");
  5174.                   hex_out(p1);
  5175.                   //: DEUTSCH " markiert!!"
  5176.                   //: ENGLISH " markiert!!"
  5177.                   //: FRANCAIS " markiert!!"
  5178.                   asciz_out(GETTEXT(" markiert!!"));
  5179.                   asciz_out(NLstring);
  5180.                   abort();
  5181.                 }
  5182.               p1 += calc_speicher_laenge(p1);
  5183.         }   }
  5184.         );
  5185.       for_each_cons_page(page,
  5186.         # Von unten nach oben durchgehen:
  5187.         { var reg1 aint p1 = page->page_start;
  5188.           var reg4 aint p1end = page->page_end;
  5189.           until (p1==p1end) # obere Grenze erreicht -> fertig
  5190.             { # nächstes Objekt hat Adresse p1
  5191.               if (marked(p1)) # markiert?
  5192.                 { asciz_out(NLstring);
  5193.                   //: DEUTSCH "Objekt"
  5194.                   //: ENGLISH "Objekt"
  5195.                   //: FRANCAIS "Objekt"
  5196.                   asciz_out(GETTEXT("Objekt"));
  5197.                   asciz_out(" 0x"); 
  5198.                   hex_out(p1);
  5199.                   //: DEUTSCH " markiert!!"
  5200.                   //: ENGLISH " markiert!!"
  5201.                   //: FRANCAIS " markiert!!"
  5202.                   asciz_out(GETTEXT(" markiert!!"));
  5203.                   asciz_out(NLstring);
  5204.                   abort();
  5205.                 }
  5206.               p1 += sizeof(cons_);
  5207.         }   }
  5208.         );
  5209.     }
  5210. #else
  5211.   #define CHECK_GC_UNMARKED()
  5212. #endif
  5213.  
  5214. #ifdef DEBUG_SPVW
  5215.   # Kontrolle gegen Nullpointer:
  5216.   #define CHECK_NULLOBJ()  nullobjcheck(FALSE)
  5217.   local void nullobjcheck (boolean in_gc);
  5218.   local void nullobjcheck_range (aint p1, aint p1end, boolean in_gc);
  5219.   local void nullobjcheck_range(p1,p1end,in_gc)
  5220.     var reg1 aint p1;
  5221.     var reg2 aint p1end;
  5222.     var reg3 boolean in_gc;
  5223.     { until (p1==p1end) # obere Grenze erreicht -> fertig
  5224.         { # nächstes Objekt hat Adresse p1
  5225.           if (eq(((Cons)p1)->cdr,nullobj) || eq(((Cons)p1)->car,nullobj))
  5226.             if (!(in_gc && eq(((Cons)p1)->cdr,nullobj) && eq(((Cons)p1)->car,nullobj)))
  5227.               abort();
  5228.           p1 += sizeof(cons_);
  5229.     }   }
  5230.   local void nullobjcheck(in_gc)
  5231.     var reg4 boolean in_gc;
  5232.     { # Von unten nach oben durchgehen:
  5233.       #ifdef GENERATIONAL_GC
  5234.       #ifdef SPVW_MIXED_BLOCKS_OPPOSITE
  5235.       for_each_cons_heap(heap,
  5236.         { nullobjcheck_range(heap->heap_start,heap->heap_gen1_end,in_gc);
  5237.           nullobjcheck_range(heap->heap_gen0_start,heap->heap_gen0_end,in_gc);
  5238.         });
  5239.       #else
  5240.       for_each_cons_heap(heap,
  5241.         { nullobjcheck_range(heap->heap_gen0_start,heap->heap_gen0_end,in_gc);
  5242.           nullobjcheck_range(heap->heap_gen1_start,heap->heap_end,in_gc);
  5243.         });
  5244.       #endif
  5245.       #else
  5246.       for_each_cons_page(page,
  5247.         { nullobjcheck_range(page->page_start,page->page_end,in_gc); });
  5248.       #endif
  5249.     }
  5250. #else
  5251.   #define CHECK_NULLOBJ()
  5252. #endif
  5253.  
  5254. #ifdef SPVW_PAGES
  5255.   # Überflüssige Pages freigeben:
  5256.   # Falls nach einer GC der Platz, der uns in mem.free_pages zur Verfügung
  5257.   # steht, mehr als 25% dessen ausmacht, was wir momentan brauchen, wird der
  5258.   # Rest ans Betriebssystem zurückgegeben.
  5259.   local void free_some_unused_pages (void);
  5260.   local void free_some_unused_pages()
  5261.     { var reg5 uintL needed_space = floor(mem.last_gcend_space,4); # 25%
  5262.       var reg4 uintL accu_space = 0;
  5263.       var reg2 Pages* pageptr = &mem.free_pages;
  5264.       var reg1 Pages page = *pageptr;
  5265.       until (page==NULL)
  5266.         { var reg3 Pages nextpage = page->page_gcpriv.next;
  5267.           if (accu_space < needed_space)
  5268.             # page behalten
  5269.             { accu_space += page->page_room;
  5270.               pageptr = (Pages*)&page->page_gcpriv.next; page = nextpage;
  5271.             }
  5272.             else
  5273.             # page freigeben
  5274.             { free_page(page); page = *pageptr = nextpage; }
  5275.     }   }
  5276. #endif
  5277.  
  5278. # GC-Timer ein- und ausschalten: gc_timer_on(); ... gc_timer_off();
  5279. # Die dazwischen verstrichene Zeit wird auf gc_time addiert.
  5280.   #define gc_timer_on()  \
  5281.     { var internal_time gcstart_time; \
  5282.       get_running_time(gcstart_time); # aktuelle verbrauchte Zeit abfragen und retten
  5283.   #define gc_timer_off()  \
  5284.      {var internal_time gcend_time;                           \
  5285.       get_running_time(gcend_time);                           \
  5286.       # Differenz von gcend_time und gcstart_time bilden:     \
  5287.       sub_internal_time(gcend_time,gcstart_time, gcend_time); \
  5288.       # diese Differenz zu gc_time addieren:                  \
  5289.       add_internal_time(gc_time,gcend_time, gc_time);         \
  5290.     }}
  5291.  
  5292. # GC-bedingt Signale disablen: gc_signalblock_on(); ... gc_signalblock_off();
  5293.   #if defined(HAVE_SIGNALS) && defined(SIGWINCH) && !defined(NO_ASYNC_INTERRUPTS)
  5294.     # Signal SIGWINCH blockieren, denn eine Veränderung des Wertes von
  5295.     # SYS::*PRIN-LINELENGTH* können wir während der GC nicht brauchen.
  5296.     # Dann Signal SIGWINCH wieder freigeben.
  5297.     #define gc_signalblock_on()  signalblock_on(SIGWINCH)
  5298.     #define gc_signalblock_off()  signalblock_off(SIGWINCH)
  5299.   #else
  5300.     #define gc_signalblock_on()
  5301.     #define gc_signalblock_off()
  5302.   #endif
  5303.  
  5304. # GC-bedingt Immutabilität von Objekten aufheben:
  5305.   #ifndef MULTIMAP_MEMORY
  5306.     #define immutable_off()
  5307.     #define immutable_on()
  5308.   #endif
  5309.  
  5310. #if (defined(SPVW_PURE_BLOCKS) || defined(TRIVIALMAP_MEMORY)) && defined(VIRTUAL_MEMORY) && defined(HAVE_MUNMAP)
  5311.   nonreturning_function(local, fehler_munmap_failed, (void));
  5312.   local void fehler_munmap_failed()
  5313.     {
  5314.       //: DEUTSCH "munmap() klappt nicht."
  5315.       //: ENGLISH "munmap() failed."
  5316.       //: FRANCAIS "munmap() ne fonctionne pas."
  5317.       asciz_out(GETTEXT("munmap() failed"));
  5318.       errno_out(errno);
  5319.       abort();
  5320.     }
  5321. #endif
  5322.  
  5323.  
  5324. # Normale Garbage Collection durchführen:
  5325.   local void gar_col_normal(void);
  5326.   local void gar_col_normal()
  5327.     { var uintL gcstart_space; # belegter Speicher bei GC-Start
  5328.       var uintL gcend_space; # belegter Speicher bei GC-Ende
  5329.       var object all_finalizers; # Liste der Finalisierer
  5330.       #ifdef GC_CLOSES_FILES
  5331.       var object files_to_close; # Liste der zu schließenden Files
  5332.       #endif
  5333.       set_break_sem_1(); # BREAK während Garbage Collection sperren
  5334.       gc_signalblock_on(); # Signale während Garbage Collection sperren
  5335.       gc_timer_on();
  5336.       gcstart_space = used_space(); # belegten Speicherplatz ermitteln
  5337.       #ifdef WINDOWS
  5338.       windows_note_gc_start();
  5339.       #endif
  5340.       #ifdef HAVE_VADVISE
  5341.         begin_system_call();
  5342.         vadvise(VA_ANOM); # Paging-Verhalten wird jetzt etwas ungewöhnlich
  5343.         end_system_call();
  5344.       #endif
  5345.       immutable_off(); # immutable Objekte werden jetzt modifizierbar
  5346.       CHECK_GC_UNMARKED(); CHECK_NULLOBJ(); CHECK_GC_CACHE(); CHECK_GC_GENERATIONAL(); SAVE_GC_DATA();
  5347.       #ifdef SPVW_PAGES
  5348.         { var reg4 uintL heapnr;
  5349.           for (heapnr=0; heapnr<heapcount; heapnr++)
  5350.             { AVL_map(mem.heaps[heapnr].inuse,page,
  5351.                       page->page_room += page->page_end;
  5352.                      );
  5353.               # In page_room steht jetzt jeweils das Ende des benutzbaren Speichers.
  5354.         }   }
  5355.       #endif
  5356.       #ifdef GENERATIONAL_GC
  5357.       if (generation == 0)
  5358.         # Alte Generation mit Hilfe des Cache auf den aktuellen Stand bringen:
  5359.         { prepare_old_generation(); }
  5360.         else
  5361.         # Nur die neue Generation behandeln. Alte Generation verstecken:
  5362.         #ifdef SPVW_MIXED_BLOCKS_OPPOSITE
  5363.         { mem.varobjects.heap_start = mem.varobjects.heap_gen1_start;
  5364.           mem.conses.heap_end = mem.conses.heap_gen1_end;
  5365.         }
  5366.         #else
  5367.         { var reg4 uintL heapnr;
  5368.           for (heapnr=0; heapnr<heapcount; heapnr++)
  5369.             mem.heaps[heapnr].heap_start = mem.heaps[heapnr].heap_gen1_start;
  5370.         }
  5371.         #endif
  5372.       #endif
  5373.       CHECK_GC_GENERATIONAL();
  5374.       # Markierungsphase:
  5375.         all_finalizers = O(all_finalizers); O(all_finalizers) = NIL;
  5376.         #ifdef GC_CLOSES_FILES
  5377.         files_to_close = O(open_files); O(open_files) = NIL; # O(files_to_close) = NIL;
  5378.         #endif
  5379.         gc_markphase();
  5380.         # (noch unmarkierte Liste all_finalizers aufspalten in zwei Listen:
  5381.         { var reg1 object Lu = all_finalizers;
  5382.           var reg3 object* L1 = &O(all_finalizers);
  5383.           var reg2 object* L2 = &O(pending_finalizers);
  5384.           until (msymbolp(*L2)) # eigentlich: until (nullp(*L2))
  5385.             { L2 = &TheFinalizer(*L2)->fin_cdr; }
  5386.           until (symbolp(Lu)) # eigentlich: until (nullp(Lu))
  5387.             { # Wenn fin_alive tot ist, wird der Finalisierer weggeworfen,
  5388.               # ohne ausgeführt zu werden:
  5389.               if (!alive(TheFinalizer(Lu)->fin_alive))
  5390.                 { Lu = TheFinalizer(Lu)->fin_cdr; }
  5391.                 else
  5392.                 { # Wenn fin_trigger stirbt, wird der Finalisierer ausgeführt:
  5393.                   if (alive(TheFinalizer(Lu)->fin_trigger)) # Lebt fin_trigger noch?
  5394.                     # ja -> in O(all_finalizers) übernehmen:
  5395.                     { *L1 = Lu; L1 = &TheFinalizer(Lu)->fin_cdr; Lu = *L1; }
  5396.                     else
  5397.                     # nein -> in O(pending_finalizers) übernehmen:
  5398.                     { *L2 = Lu; L2 = &TheFinalizer(Lu)->fin_cdr; Lu = *L2; }
  5399.                 }
  5400.             }
  5401.           *L1 = NIL; *L2 = NIL;
  5402.         }
  5403.         gc_mark(O(all_finalizers)); gc_mark(O(pending_finalizers)); # Beide Listen jetzt markieren
  5404.         #ifdef GC_CLOSES_FILES
  5405.         # (noch unmarkierte) Liste files_to_close aufspalten in zwei Listen:
  5406.         { var reg1 object Lu = files_to_close;
  5407.           var reg2 object* L1 = &O(open_files);
  5408.           var reg3 object* L2 = &O(files_to_close);
  5409.           while (consp(Lu))
  5410.             { if (in_old_generation(Car(Lu),stream_type,0)
  5411.                   || marked(TheStream(Car(Lu))) # (car Lu) markiert?
  5412.                  )
  5413.                 # ja -> in O(open_files) übernehmen:
  5414.                 { *L1 = Lu; L1 = &Cdr(Lu); Lu = *L1; }
  5415.                 else
  5416.                 # nein -> in O(files_to_close) übernehmen:
  5417.                 { *L2 = Lu; L2 = &Cdr(Lu); Lu = *L2; }
  5418.             }
  5419.           *L1 = NIL; *L2 = NIL;
  5420.         }
  5421.         gc_mark(O(open_files)); gc_mark(O(files_to_close)); # Beide Listen jetzt markieren
  5422.         #endif
  5423.       # Jetzt sind alle aktiven Objekte markiert:
  5424.       # Aktive Objekte variabler Länge wie auch aktive Zwei-Pointer-Objekte tragen
  5425.       # in ihrem ersten Byte ein gesetztes Markierungsbit, aktive SUBRs tragen
  5426.       # in ihrem ersten Konstantenpointer ein gesetztes Markierungsbit, sonst sind
  5427.       # alle Markierungsbits gelöscht.
  5428.       # "Sweep"-Phase:
  5429.         # Die CONSes u.ä. (Objekte mit 2 Pointern) werden kompaktiert.
  5430.         # Von den Objekten variabler Länge werden die Zielplätze für die
  5431.         # Phase 4 errechnet und abgespeichert.
  5432.         # SUBRs und feste Symbole (sie sind alle aktiv) werden als erstes demarkiert:
  5433.           unmark_fixed_varobjects();
  5434.         #ifndef MORRIS_GC
  5435.         # CONS-Zellen kompaktieren:
  5436.         for_each_cons_page(page, { gc_compact_cons_page(page); } );
  5437.         #endif
  5438.         # Objekte variabler Länge zur Zusammenschiebung nach unten vorbereiten:
  5439.           #ifdef SPVW_PURE
  5440.           #ifdef GENERATIONAL_GC
  5441.           if (generation == 0)
  5442.             { for_each_varobject_heap(heap,
  5443.                 { if (heap->heap_gen0_end < heap->heap_gen1_start)
  5444.                     # Lücke durch einen Pointer überspringen
  5445.                     { var object secondmarked;
  5446.                       var reg1 aint tmp =
  5447.                         gc_sweep1_varobject_page(heapnr,
  5448.                                                  heap->heap_gen0_start,heap->heap_gen0_end,
  5449.                                                  &heap->pages.page_gcpriv.firstmarked,
  5450.                                                  heap->heap_gen0_start);
  5451.                       gc_sweep1_varobject_page(heapnr,
  5452.                                                heap->heap_gen1_start,heap->heap_end,
  5453.                                                (object*)(heap->heap_gen0_end),
  5454.                                                tmp);
  5455.                     }
  5456.                     else
  5457.                     # keine Lücke
  5458.                     { gc_sweep1_varobject_page(heapnr,
  5459.                                                heap->heap_gen0_start,heap->heap_end,
  5460.                                                &heap->pages.page_gcpriv.firstmarked,
  5461.                                                heap->heap_gen0_start);
  5462.                     }
  5463.                 });
  5464.             }
  5465.             else
  5466.           #endif
  5467.           for_each_varobject_page(page,
  5468.             { gc_sweep1_varobject_page(heapnr,
  5469.                                        page->page_start,page->page_end,
  5470.                                        &page->page_gcpriv.firstmarked,
  5471.                                        page->page_start);
  5472.             });
  5473.           #else # SPVW_MIXED
  5474.           #ifdef GENERATIONAL_GC
  5475.           if (generation == 0)
  5476.             { for_each_varobject_heap(heap,
  5477.                 { if (heap->heap_gen0_end < heap->heap_gen1_start)
  5478.                     # Lücke durch einen Pointer überspringen
  5479.                     { var object secondmarked;
  5480.                       var reg1 aint tmp =
  5481.                         gc_sweep1_varobject_page(heap->heap_gen0_start,heap->heap_gen0_end,
  5482.                                                  &heap->pages.page_gcpriv.firstmarked,
  5483.                                                  heap->heap_gen0_start);
  5484.                       gc_sweep1_varobject_page(heap->heap_gen1_start,heap->heap_end,
  5485.                                                (object*)(heap->heap_gen0_end),
  5486.                                                tmp);
  5487.                     }
  5488.                     else
  5489.                     # keine Lücke
  5490.                     { gc_sweep1_varobject_page(heap->heap_gen0_start,heap->heap_end,
  5491.                                                &heap->pages.page_gcpriv.firstmarked,
  5492.                                                heap->heap_gen0_start);
  5493.                     }
  5494.                 });
  5495.             }
  5496.             else
  5497.             for_each_varobject_page(page,
  5498.               { gc_sweep1_varobject_page(page->page_start,page->page_end,
  5499.                                          &page->page_gcpriv.firstmarked,
  5500.                                          page->page_start);
  5501.               });
  5502.           #else
  5503.           for_each_varobject_page(page, { gc_sweep1_varobject_page(page); } );
  5504.           #endif
  5505.           #endif
  5506.       # Jetzt sind alle aktiven Objekte für die Aktualisierung vorbereitet:
  5507.       # Bei aktiven Objekten variabler Länge A2 ist (A2).L die Adresse, wo das
  5508.       # Objekt nach der GC stehen wird (incl. Typinfo und Markierungsbit und evtl.
  5509.       # Symbol-Flags). Bei aktiven Zwei-Pointer-Objekten A2 bleibt entweder A2
  5510.       # stehen (dann ist das Markierungsbit in (A2) gelöscht), oder A2 wird
  5511.       # verschoben (dann ist (A2).L die neue Adresse, ohne Typinfo, aber incl.
  5512.       # Markierungsbit).
  5513.       # Aktualisierungsphase:
  5514.         # Der gesamte LISP-Speicher wird durchgegangen und dabei alte durch
  5515.         # neue Adressen ersetzt.
  5516.         #ifdef MORRIS_GC
  5517.          for_each_cons_page(page, { gc_morris1(page); } );
  5518.         #endif
  5519.         # Durchlaufen durch alle LISP-Objekte und aktualisieren:
  5520.           # Pointer im LISP-Stack aktualisieren:
  5521.             aktualisiere_STACK();
  5522.           # Programmkonstanten aktualisieren:
  5523.             aktualisiere_tab();
  5524.           #ifndef MORRIS_GC
  5525.           # Pointer in den Cons-Zellen aktualisieren:
  5526.             aktualisiere_conses();
  5527.           #endif
  5528.           # Pointer in den Objekten variabler Länge aktualisieren:
  5529.             #define aktualisiere_page(page,aktualisierer)  \
  5530.               { var reg2 aint ptr = (aint)type_pointable(0,page->page_gcpriv.firstmarked); \
  5531.                 var reg6 aint ptrend = page->page_end;                                     \
  5532.                 # alle Objekte mit Adresse >=ptr, <ptrend durchgehen:                      \
  5533.                 until (ptr==ptrend) # solange bis ptr am Ende angekommen ist               \
  5534.                   { # nächstes Objekt mit Adresse ptr (< ptrend) durchgehen:               \
  5535.                     if (marked(ptr)) # markiert?                                           \
  5536.                       # Typinfo ohne Markierungsbit nehmen!                                \
  5537.                       { aktualisierer(typecode_at(ptr) & ~bit(garcol_bit_t)); }            \
  5538.                       else                                                                 \
  5539.                       # mit Pointer (Typinfo=0) zum nächsten markierten Objekt             \
  5540.                       { ptr = (aint)type_pointable(0,*(object*)ptr); }                     \
  5541.               }   }
  5542.             #define aktualisiere_fpointer_invalid  FALSE
  5543.             aktualisiere_varobjects();
  5544.             #undef aktualisiere_fpointer_invalid
  5545.             #undef aktualisiere_page
  5546.           #ifdef GENERATIONAL_GC
  5547.           # Pointer in den Objekten der alten Generation aktualisieren:
  5548.             if (generation > 0)
  5549.               { aktualisiere_old_generation(); }
  5550.           #endif
  5551.         #ifdef MORRIS_GC
  5552.         # Zum Schluß werden die Conses verschoben und gleichzeitig alle
  5553.         # Pointer auf sie (z.Zt. in Listen geführt!) aktualisiert.
  5554.         for_each_cons_page_reversed(page, { gc_morris2(page); } );
  5555.         for_each_cons_page(page, { gc_morris3(page); } );
  5556.         #endif
  5557.       # Jetzt sind alle aktiven Objekte mit korrektem Inhalt versehen (alle darin
  5558.       # vorkommenden Pointer zeigen auf die nach der GC korrekten Adressen).
  5559.       # Die aktiven Zwei-Pointer-Objekte sind bereits am richtigen Ort und
  5560.       # unmarkiert; die Objekte variabler Länge sind noch am alten Ort und
  5561.       # markiert, falls aktiv.
  5562.       # Zweite SWEEP-Phase:
  5563.         # Die Objekte variabler Länge werden an die vorher berechneten
  5564.         # neuen Plätze geschoben.
  5565.         #if !defined(GENERATIONAL_GC)
  5566.         #ifdef SPVW_MIXED
  5567.         for_each_varobject_page(page, { gc_sweep2_varobject_page(page); } );
  5568.         #else # SPVW_PURE
  5569.         for_each_varobject_page(page, { gc_sweep2_varobject_page(page,heapnr); } );
  5570.         #endif
  5571.         #else # defined(GENERATIONAL_GC)
  5572.         { var reg4 uintL heapnr;
  5573.           for (heapnr=0; heapnr<heapcount; heapnr++)
  5574.             { var reg3 Heap* heap = &mem.heaps[heapnr];
  5575.               if (!is_unused_heap(heapnr))
  5576.                 { if (is_varobject_heap(heapnr))
  5577.                     {
  5578.                       #ifdef SPVW_MIXED
  5579.                       gc_sweep2_varobject_page(&heap->pages);
  5580.                       #else # SPVW_PURE
  5581.                       gc_sweep2_varobject_page(&heap->pages,heapnr);
  5582.                       #endif
  5583.                     }
  5584.                   if (generation == 0)
  5585.                     { # Alles Übriggebliebene bildet die neue Generation 0.
  5586.                       #ifdef SPVW_MIXED_BLOCKS_OPPOSITE
  5587.                       if (is_cons_heap(heapnr))
  5588.                         { var reg1 aint start = heap->heap_start;
  5589.                           heap->heap_gen0_start = start;
  5590.                           start = start & -physpagesize;
  5591.                           heap->heap_start = heap->heap_gen1_end = start;
  5592.                         }
  5593.                         else
  5594.                       #endif
  5595.                         { var reg1 aint end = heap->heap_end;
  5596.                           heap->heap_gen0_end = end;
  5597.                           end = (end + (physpagesize-1)) & -physpagesize;
  5598.                           heap->heap_gen1_start = heap->heap_end = end;
  5599.                         }
  5600.                       build_old_generation_cache(heapnr);
  5601.                     }
  5602.                     else
  5603.                     { rebuild_old_generation_cache(heapnr); }
  5604.                 }
  5605.               #ifdef SPVW_MIXED_BLOCKS_OPPOSITE
  5606.               if (is_cons_heap(heapnr))
  5607.                 { heap->heap_end = heap->heap_gen0_end; }
  5608.                 else
  5609.               #endif
  5610.                 { heap->heap_start = heap->heap_gen0_start; }
  5611.         }   }
  5612.         #endif
  5613.       # Jetzt sind alle aktiven Objekte mit korrektem Inhalt versehen, am richtigen
  5614.       # Ort und wieder unmarkiert.
  5615.       #ifdef SPVW_PAGES
  5616.         { var reg5 uintL heapnr;
  5617.           for (heapnr=0; heapnr<heapcount; heapnr++)
  5618.             { var reg4 Pages* heapptr = &mem.heaps[heapnr].inuse;
  5619.               AVL_map(*heapptr,page,
  5620.                       page->page_room -= page->page_end;
  5621.                      );
  5622.               # In page_room steht jetzt jeweils wieder der verfügbare Platz.
  5623.               # Pages wieder nach dem verfügbaren Platz sortieren:
  5624.               *heapptr = AVL(AVLID,sort)(*heapptr);
  5625.         }   }
  5626.         for_each_cons_heap(heap, { heap->lastused = dummy_lastused; } );
  5627.         # .reserve behandeln??
  5628.       #endif
  5629.       CHECK_AVL_CONSISTENCY();
  5630.       CHECK_GC_CONSISTENCY();
  5631.       CHECK_GC_UNMARKED(); CHECK_NULLOBJ(); CHECK_GC_CACHE(); CHECK_GC_GENERATIONAL(); SAVE_GC_DATA();
  5632.       CHECK_PACK_CONSISTENCY();
  5633.       # Ende der Garbage Collection.
  5634.       #ifdef HAVE_VADVISE
  5635.         begin_system_call();
  5636.         vadvise(VA_NORM); # Paging-Verhalten wird ab jetzt wieder normal
  5637.         end_system_call();
  5638.       #endif
  5639.       #ifdef WINDOWS
  5640.       windows_note_gc_end();
  5641.       #endif
  5642.       gc_count += 1; # GCs mitzählen
  5643.       # belegten Speicherplatz ermitteln:
  5644.       #ifdef SPVW_PAGES
  5645.       recalc_space(FALSE);
  5646.       #endif
  5647.       gcend_space = used_space();
  5648.       #ifdef SPVW_PAGES
  5649.       mem.last_gcend_space = gcend_space;
  5650.       # Um bis zu 25% lassen wir den benutzten Platz anwachsen, dann erst
  5651.       # kommt die nächste GC:
  5652.       { var reg1 uintL total_room = floor(mem.last_gcend_space,4);
  5653.         if (total_room < 512*1024) { total_room = 512*1024; } # mindestens 512 KB
  5654.         mem.gctrigger_space = mem.last_gcend_space + total_room;
  5655.       }
  5656.       #endif
  5657.       #if (defined(SPVW_PURE_BLOCKS) || defined(TRIVIALMAP_MEMORY)) && !defined(GENERATIONAL_GC)
  5658.       # Um bis zu 50% lassen wir den benutzten Platz anwachsen, dann erst
  5659.       # kommt die nächste GC:
  5660.       #define set_total_room(space_used_now)  \
  5661.         { mem.total_room = floor(space_used_now,2); # 50% des jetzt benutzten Platzes       \
  5662.           if (mem.total_room < 512*1024) { mem.total_room = 512*1024; } # mindestens 512 KB \
  5663.         }
  5664.       set_total_room(gcend_space);
  5665.       #endif
  5666.       #if defined(GENERATIONAL_GC)
  5667.       # Um bis zu 25% lassen wir den benutzten Platz anwachsen, dann erst
  5668.       # kommt die nächste GC:
  5669.       #define set_total_room_(space_used_now)  \
  5670.         { mem.total_room = floor(space_used_now,4); # 25% des jetzt benutzten Platzes       \
  5671.           if (mem.total_room < 512*1024) { mem.total_room = 512*1024; } # mindestens 512 KB \
  5672.         }
  5673.       #ifdef SPVW_MIXED_BLOCKS_OPPOSITE
  5674.       # make_space() erwartet, daß mem.total_room <= Länge der großen Lücke.
  5675.       #define set_total_room(space_used_now)  \
  5676.         { set_total_room_(space_used_now);                                      \
  5677.           if (mem.total_room > mem.conses.heap_start-mem.varobjects.heap_end)   \
  5678.             { mem.total_room = mem.conses.heap_start-mem.varobjects.heap_end; } \
  5679.         }
  5680.       #else
  5681.       #define set_total_room  set_total_room_
  5682.       #endif
  5683.       { var reg4 uintL gen0_sum = 0; # momentane Größe der alten Generation
  5684.         var reg4 uintL gen1_sum = 0; # momentane Größe der neuen Generation
  5685.         for_each_heap(heap,
  5686.           { gen0_sum += heap->heap_gen0_end - heap->heap_gen0_start; });
  5687.         #ifdef SPVW_MIXED_BLOCKS_OPPOSITE
  5688.         gen1_sum += mem.varobjects.heap_end - mem.varobjects.heap_gen1_start;
  5689.         gen1_sum += mem.conses.heap_gen1_end - mem.conses.heap_start;
  5690.         #else
  5691.         for_each_heap(heap,
  5692.           { gen1_sum += heap->heap_end - heap->heap_gen1_start; });
  5693.         #endif
  5694.         # NB: gcend_space == gen0_sum + gen1_sum.
  5695.         set_total_room(gen0_sum);
  5696.         mem.last_gcend_space0 = gen0_sum;
  5697.         mem.last_gcend_space1 = gen1_sum;
  5698.       }
  5699.       #endif
  5700.       { var reg1 uintL freed = gcstart_space - gcend_space; # von dieser GC
  5701.                                        # wiederbeschaffter Speicherplatz
  5702.         # dies zum 64-Bit-Akku gc_space addieren:
  5703.         #ifdef intQsize
  5704.         gc_space += freed;
  5705.         #else
  5706.         gc_space.lo += freed;
  5707.         if (gc_space.lo < freed) # Übertrag?
  5708.           gc_space.hi += 1;
  5709.         #endif
  5710.       }
  5711.       #ifdef SPVW_PAGES
  5712.       free_some_unused_pages();
  5713.       #endif
  5714.       #if (defined(SPVW_PURE_BLOCKS) || defined(TRIVIALMAP_MEMORY)) && defined(VIRTUAL_MEMORY) && defined(HAVE_MUNMAP)
  5715.       # Ungebrauchte, leere Seiten freigeben, damit sie vom Betriebssystem
  5716.       # nicht irgendwann auf den Swapspace verbracht werden müssen:
  5717.       for_each_heap(heap,
  5718.         { var reg1 aint needed_limit = round_up(heap->heap_end,map_pagesize);
  5719.           if (needed_limit > heap->heap_limit)
  5720.             abort();
  5721.           if (needed_limit < heap->heap_limit)
  5722.             { if (munmap((MMAP_ADDR_T)needed_limit,heap->heap_limit-needed_limit) < 0)
  5723.                 fehler_munmap_failed();
  5724.               heap->heap_limit = needed_limit;
  5725.         }   });
  5726.       #endif
  5727.       immutable_on();
  5728.       # von dieser GC benötigte Zeit zur GC-Gesamtzeit addieren:
  5729.       gc_timer_off();
  5730.       #ifdef GC_CLOSES_FILES
  5731.       close_some_files(O(files_to_close)); # vorher unmarkierte Files schließen
  5732.       O(files_to_close) = NIL;
  5733.       #endif
  5734.       #ifdef GENERATIONAL_GC
  5735.       O(gc_count) = fixnum_inc(O(gc_count),1); # GCs mitzählen
  5736.       #endif
  5737.       gc_signalblock_off(); # Signale wieder freigeben
  5738.       clr_break_sem_1(); # BREAK wieder ermöglichen
  5739.     }
  5740.  
  5741. # Ende einer Garbage Collection.
  5742. # kann GC auslösen!
  5743.   local void gar_col_done (void);
  5744.   local void gar_col_done()
  5745.     { # Finalisierer-Funktionen abarbeiten:
  5746.       until (msymbolp(O(pending_finalizers))) # eigentlich: until (nullp(...))
  5747.         { var reg1 object obj = O(pending_finalizers);
  5748.           O(pending_finalizers) = TheFinalizer(obj)->fin_cdr;
  5749.           pushSTACK(TheFinalizer(obj)->fin_trigger);
  5750.           if (eq(TheFinalizer(obj)->fin_alive,unbound))
  5751.             { funcall(TheFinalizer(obj)->fin_function,1); } # (FUNCALL function trigger)
  5752.             else
  5753.             { pushSTACK(TheFinalizer(obj)->fin_alive);
  5754.               funcall(TheFinalizer(obj)->fin_function,2); # (FUNCALL function trigger alive)
  5755.         }   }
  5756.     }
  5757.  
  5758. #ifdef SPVW_PAGES
  5759.  
  5760. # Eine kleine Sortier-Routine:
  5761. #define SORTID  spvw
  5762. #define SORT_ELEMENT  Pages
  5763. #define SORT_KEY  uintL
  5764. #define SORT_KEYOF(page)  (page)->page_gcpriv.l
  5765. #define SORT_COMPARE(key1,key2)  (sintL)((key1)-(key2))
  5766. #define SORT_LESS(key1,key2)  ((key1) < (key2))
  5767. #include "sort.c"
  5768.  
  5769. # Kompaktierung einer Page durch Umfüllen in andere Pages derselben Art:
  5770.   #ifdef SPVW_PURE
  5771.   local void gc_compact_from_varobject_page (Heap* heapptr, Page* page, uintL heapnr);
  5772.   local void gc_compact_from_varobject_page(heapptr,page,heapnr)
  5773.     var reg9 Heap* heapptr;
  5774.     var reg8 Page* page;
  5775.     var reg10 uintL heapnr;
  5776.   #else
  5777.   local void gc_compact_from_varobject_page (Heap* heapptr, Page* page);
  5778.   local void gc_compact_from_varobject_page(heapptr,page)
  5779.     var reg9 Heap* heapptr;
  5780.     var reg8 Page* page;
  5781.   #endif
  5782.     { var reg1 aint p1 = page->page_start;
  5783.       var reg7 aint p1end = page->page_end;
  5784.       var_speicher_laenge_;
  5785.      {var reg4 Pages new_page = EMPTY; # Page, in die gefüllt wird
  5786.       var AVL(AVLID,stack) stack; # Weg von der Wurzel bis zu ihr
  5787.       var reg2 aint p2; # Cache von new_page->page_end
  5788.       var reg5 uintL l2; # Cache von new_page->page_room
  5789.       # Versuche alle Objekte zwischen p1 und p1end zu kopieren:
  5790.       loop
  5791.         { if (p1==p1end) break; # obere Grenze erreicht -> fertig
  5792.          {var reg3 uintL laenge = calc_speicher_laenge(p1); # Byte-Länge bestimmen
  5793.           # Suche eine Page, die noch mindestens laenge Bytes frei hat:
  5794.           if ((new_page == EMPTY) || (l2 < laenge))
  5795.             { if (!(new_page == EMPTY)) # Cache leeren?
  5796.                 { new_page->page_end = p2;
  5797.                   new_page->page_room = l2;
  5798.                   AVL(AVLID,move)(&stack);
  5799.                 }
  5800.               new_page = AVL(AVLID,least)(laenge,&heapptr->inuse,&stack);
  5801.               if (new_page==EMPTY) break;
  5802.               new_page->page_gcpriv.d = -1L; # new_page als "zu füllend" kennzeichnen
  5803.               p2 = new_page->page_end;
  5804.               l2 = new_page->page_room;
  5805.             }
  5806.           {var reg6 aint old_p1 = p1;
  5807.            var reg6 aint old_p2 = p2;
  5808.            # Kopiere das Objekt:
  5809.            l2 -= laenge; move_aligned_p1_p2(laenge);
  5810.            # Hinterlasse einen Pointer auf die neue Position:
  5811.            *(object*)old_p1 = with_mark_bit(type_pointer_object(0,old_p2));
  5812.            # p1 = Sourceadresse für nächstes Objekt
  5813.         }}}
  5814.       if (!(new_page == EMPTY)) # Cache leeren?
  5815.         { new_page->page_end = p2;
  5816.           new_page->page_room = l2;
  5817.           AVL(AVLID,move)(&stack);
  5818.         }
  5819.      }
  5820.      # Die nicht kopierten Objekte erfahren eine konstante Verschiebung nach unten:
  5821.      {var reg4 aint p2 = page->page_start;
  5822.       page->page_gcpriv.d = p1 - p2; # Verschiebung
  5823.       page->page_start = p1; # jetziger Anfang der Page
  5824.       if (!(p1==p2)) # falls Verschiebung nötig
  5825.         until (p1==p1end) # obere Grenze erreicht -> fertig
  5826.           { var reg3 uintL laenge = calc_speicher_laenge(p1); # Byte-Länge bestimmen
  5827.             var reg2 tint flags = mtypecode(((Varobject)p1)->GCself); # Typinfo (und Flags bei Symbolen) retten
  5828.             set_GCself(p1, flags,p2); # neue Adresse eintragen, mit alter Typinfo
  5829.             mark(p1); # mit Markierungsbit
  5830.             p1 += laenge; p2 += laenge;
  5831.           }
  5832.     }}
  5833.   local void gc_compact_from_cons_page (Heap* heapptr, Page* page);
  5834.   local void gc_compact_from_cons_page(heapptr,page)
  5835.     var reg7 Heap* heapptr;
  5836.     var reg6 Page* page;
  5837.     { var reg1 aint p1 = page->page_end;
  5838.       var reg5 aint p1start = page->page_start;
  5839.      {var reg3 Pages new_page = EMPTY; # Page, in die gefüllt wird
  5840.       var AVL(AVLID,stack) stack; # Weg von der Wurzel bis zu ihr
  5841.       var reg2 aint p2; # Cache von new_page->page_end
  5842.       var reg4 uintL l2; # Cache von new_page->page_room
  5843.       # Versuche alle Objekte zwischen p1start und p1 zu kopieren:
  5844.       loop
  5845.         { if (p1==p1start) break; # untere Grenze erreicht -> fertig
  5846.           # Suche eine Page, die noch mindestens sizeof(cons_) Bytes frei hat:
  5847.           if ((new_page == EMPTY) || (l2 == 0)) # l2 < sizeof(cons_) bedeutet l2 = 0
  5848.             { if (!(new_page == EMPTY)) # Cache leeren?
  5849.                 { new_page->page_end = p2;
  5850.                   new_page->page_room = l2;
  5851.                   AVL(AVLID,move)(&stack);
  5852.                 }
  5853.               new_page = AVL(AVLID,least)(sizeof(cons_),&heapptr->inuse,&stack);
  5854.               if (new_page==EMPTY) break;
  5855.               new_page->page_gcpriv.d = -1L; # new_page als "zu füllend" kennzeichnen
  5856.               p2 = new_page->page_end;
  5857.               l2 = new_page->page_room;
  5858.             }
  5859.           p1 -= sizeof(cons_); # p1 = Sourceadresse für nächstes Objekt
  5860.           # Kopiere das Objekt:
  5861.           ((object*)p2)[0] = ((object*)p1)[0];
  5862.           ((object*)p2)[1] = ((object*)p1)[1];
  5863.           # Hinterlasse einen Pointer auf die neue Position:
  5864.           *(object*)p1 = with_mark_bit(type_pointer_object(0,p2));
  5865.           p2 += sizeof(cons_); l2 -= sizeof(cons_);
  5866.         }
  5867.       if (!(new_page == EMPTY)) # Cache leeren?
  5868.         { new_page->page_end = p2;
  5869.           new_page->page_room = l2;
  5870.           AVL(AVLID,move)(&stack);
  5871.         }
  5872.      }
  5873.      # Die nicht kopierten Objekte bleiben an Ort und Stelle.
  5874.      page->page_gcpriv.d = page->page_end - p1; # Zugewinn
  5875.      page->page_end = p1; # jetziges Ende der Page
  5876.     }
  5877.  
  5878. # Kompaktierung aller Pages einer bestimmten Art:
  5879.   #ifdef SPVW_PURE
  5880.   local void gc_compact_heap (Heap* heapptr, sintB heaptype, uintL heapnr);
  5881.   local void gc_compact_heap(heapptr,heaptype,heapnr)
  5882.     var reg4 Heap* heapptr;
  5883.     var reg5 sintB heaptype;
  5884.     var reg5 uintL heapnr;
  5885.   #else
  5886.   local void gc_compact_heap (Heap* heapptr, sintB heaptype);
  5887.   local void gc_compact_heap(heapptr,heaptype)
  5888.     var reg4 Heap* heapptr;
  5889.     var reg5 sintB heaptype;
  5890.   #endif
  5891.     { # Erst eine Liste aller Pages erstellen, aufsteigend sortiert
  5892.       # nach der Anzahl der belegten Bytes:
  5893.       var reg10 uintL pagecount = 0;
  5894.       map_heap(*heapptr,page,
  5895.                { page->page_gcpriv.l = page->page_end - page->page_start; # Anzahl der belegten Bytes
  5896.                  pagecount++;
  5897.                }
  5898.               );
  5899.       # pagecount = Anzahl der Pages.
  5900.      {var DYNAMIC_ARRAY(reg6,pages_sorted,Pages,pagecount);
  5901.       {var reg4 uintL index = 0;
  5902.        map_heap(*heapptr,page, { pages_sorted[index++] = page; } );
  5903.       }
  5904.       # pages_sorted = Array der Pages.
  5905.       SORT(SORTID,sort)(pages_sorted,pagecount);
  5906.       # pages_sorted = Array der Pages, sortiert nach der Anzahl der belegten Bytes.
  5907.       # In jeder Page bedeutet page_gcpriv.d die Verschiebung nach unten,
  5908.       # die der Page in Phase 3 zuteil werden muß (>=0).
  5909.       # page_gcpriv.d = -1L für die zu füllenden Pages.
  5910.       # page_gcpriv.d = -2L für die noch unbehandelten Pages.
  5911.       map_heap(*heapptr,page, { page->page_gcpriv.d = -2L; } ); # alle Pages noch unbehandelt
  5912.       {var reg3 uintL index;
  5913.        for (index=0; index<pagecount; index++) # Durch alle Pages durchlaufen
  5914.          { var reg2 Pages page = pages_sorted[index]; # nächste Page
  5915.            if (page->page_gcpriv.d == -2L) # noch unbehandelt und
  5916.                                            # noch nicht als "zu füllend" markiert?
  5917.              { # page wird geleert.
  5918.                heapptr->inuse = AVL(AVLID,delete1)(page,heapptr->inuse); # page herausnehmen
  5919.                # page leeren:
  5920.                if (heaptype==0)
  5921.                  { gc_compact_from_cons_page(heapptr,page); }
  5922.                  else
  5923.                  #ifdef SPVW_PURE
  5924.                  { gc_compact_from_varobject_page(heapptr,page,heapnr); }
  5925.                  #else
  5926.                  { gc_compact_from_varobject_page(heapptr,page); }
  5927.                  #endif
  5928.       }  }   }
  5929.       CHECK_AVL_CONSISTENCY();
  5930.       CHECK_GC_CONSISTENCY_2();
  5931.       {var reg2 uintL index;
  5932.        for (index=0; index<pagecount; index++) # Durch alle Pages durchlaufen
  5933.          { var reg1 Pages page = pages_sorted[index]; # nächste Page
  5934.            if (!(page->page_gcpriv.d == -1L)) # eine zu leerende Page
  5935.              { page->page_room += page->page_gcpriv.d; # So viel Platz haben wir nun gemacht
  5936.                if (page->page_start == page->page_end)
  5937.                  # Page ganz geleert
  5938.                  { # Page freigeben:
  5939.                    if (page->m_length > min_page_size_brutto)
  5940.                      # Übergroße Page
  5941.                      { free_page(page); } # ans Betriebssystem zurückgeben
  5942.                      else
  5943.                      # Normalgroße Page
  5944.                      { # wieder initialisieren (page->page_room bleibt gleich!):
  5945.                        page->page_start = page->page_end = page_start0(page);
  5946.                        # in den Pool mem.free_pages einhängen:
  5947.                        page->page_gcpriv.next = mem.free_pages;
  5948.                        mem.free_pages = page;
  5949.                  }   }
  5950.                  else
  5951.                  # Page konnte nicht ganz geleert werden
  5952.                  { heapptr->inuse = AVL(AVLID,insert1)(page,heapptr->inuse); } # Page wieder rein
  5953.       }  }   }
  5954.       FREE_DYNAMIC_ARRAY(pages_sorted);
  5955.       CHECK_AVL_CONSISTENCY();
  5956.       CHECK_GC_CONSISTENCY_2();
  5957.     }}
  5958.  
  5959. # Kompaktierende Garbage Collection durchführen.
  5960. # Wird aufgerufen, nachdem gar_col_simple() nicht genügend Platz am Stück
  5961. # besorgen konnte.
  5962.   local void gar_col_compact (void);
  5963.   local void gar_col_compact()
  5964.     { # Es werden Lisp-Objekte von fast leeren Pages in andere Pages
  5965.       # umgefüllt, um die ganz leer machen und zurückgeben zu können.
  5966.       # 1. Für jede Page-Art:
  5967.       #    Pages unterteilen in zu leerende und zu füllende Pages und dabei
  5968.       #    soviel Daten wie möglich von den zu leerenden in die zu füllenden
  5969.       #    Pages umkopieren. Kann eine Page nicht ganz geleert werden, so
  5970.       #    wird sie so gelassen, wie sie ist, und in ihr werden dann nachher
  5971.       #    die übrigen Daten nur nach unten geschoben.
  5972.       #    Rückgabe der ganz geleerten Pages.
  5973.       # 2. Aktualisierung der Pointer.
  5974.       # 3. Durchführung der Verschiebungen in den nicht ganz geleerten Pages.
  5975.       set_break_sem_1(); # BREAK während Garbage Collection sperren
  5976.       gc_signalblock_on(); # Signale während Garbage Collection sperren
  5977.       gc_timer_on();
  5978.       immutable_off(); # immutable Objekte werden jetzt modifizierbar
  5979.       CHECK_GC_UNMARKED(); CHECK_NULLOBJ();
  5980.       { var reg1 uintL heapnr;
  5981.         for (heapnr=0; heapnr<heapcount; heapnr++)
  5982.           if (!is_unused_heap(heapnr))
  5983.             #ifdef SPVW_PURE
  5984.             { gc_compact_heap(&mem.heaps[heapnr],mem.heaptype[heapnr],heapnr); }
  5985.             #endif
  5986.             #ifdef SPVW_MIXED
  5987.             { gc_compact_heap(&mem.heaps[heapnr],1-heapnr); }
  5988.             #endif
  5989.       }
  5990.       # Aktualisierungsphase:
  5991.         # Der gesamte LISP-Speicher wird durchgegangen und dabei alte durch
  5992.         # neue Adressen ersetzt.
  5993.         # Durchlaufen durch alle LISP-Objekte und aktualisieren:
  5994.           # Pointer im LISP-Stack aktualisieren:
  5995.             aktualisiere_STACK();
  5996.           # Programmkonstanten aktualisieren:
  5997.             aktualisiere_tab();
  5998.           # Pointer in den Cons-Zellen aktualisieren:
  5999.             aktualisiere_conses();
  6000.           # Pointer in den Objekten variabler Länge aktualisieren:
  6001.             #define aktualisiere_page(page,aktualisierer)  \
  6002.               { var reg2 aint ptr = page->page_start;                        \
  6003.                 var reg6 aint ptrend = page->page_end;                       \
  6004.                 # alle Objekte mit Adresse >=ptr, <ptrend durchgehen:        \
  6005.                 until (ptr==ptrend) # solange bis ptr am Ende angekommen ist \
  6006.                   { # nächstes Objekt mit Adresse ptr (< ptrend) durchgehen: \
  6007.                     aktualisierer(typecode_at(ptr) & ~bit(garcol_bit_t)); # und weiterrücken \
  6008.               }   }
  6009.             #define aktualisiere_fpointer_invalid  FALSE
  6010.             aktualisiere_varobjects();
  6011.             #undef aktualisiere_fpointer_invalid
  6012.             #undef aktualisiere_page
  6013.       # Durchführung der Verschiebungen in den nicht ganz geleerten Pages:
  6014.         for_each_varobject_page(page,
  6015.           { if (!(page->page_gcpriv.d == -1L))
  6016.               { var reg2 aint p1 = page->page_start;
  6017.                 var reg4 aint p1end = page->page_end;
  6018.                 var reg1 aint p2 = p1 - page->page_gcpriv.d;
  6019.                 if (!(p1==p2)) # falls Verschiebung nötig
  6020.                   { var_speicher_laenge_;
  6021.                     page->page_start = p2;
  6022.                     until (p1==p1end) # obere Grenze erreicht -> fertig
  6023.                       { # nächstes Objekt hat Adresse p1, ist markiert
  6024.                         unmark(p1); # Markierung löschen
  6025.                         # Objekt behalten und verschieben:
  6026.                        {var reg3 uintL count = calc_speicher_laenge(p1); # Länge (durch varobject_alignment teilbar, >0)
  6027.                         move_aligned_p1_p2(count); # verschieben und weiterrücken
  6028.                       }}
  6029.                     page->page_end = p2;
  6030.           }   }   }
  6031.           );
  6032.       for_each_cons_heap(heap, { heap->lastused = dummy_lastused; } );
  6033.       recalc_space(TRUE);
  6034.       free_some_unused_pages();
  6035.       CHECK_AVL_CONSISTENCY();
  6036.       CHECK_GC_CONSISTENCY();
  6037.       CHECK_GC_UNMARKED(); CHECK_NULLOBJ();
  6038.       CHECK_PACK_CONSISTENCY();
  6039.       immutable_on();
  6040.       gc_timer_off();
  6041.       gc_signalblock_off(); # Signale wieder freigeben
  6042.       clr_break_sem_1(); # BREAK wieder ermöglichen
  6043.     }
  6044.  
  6045. #endif
  6046.  
  6047. # Garbage Collection durchführen:
  6048.   local void gar_col_simple (void);
  6049.   local void gar_col_simple()
  6050.     { var uintC saved_mv_count = mv_count; # mv_count retten
  6051.       pushSTACK(subr_self); # subr_self retten
  6052.       #if !defined(GENERATIONAL_GC)
  6053.       gar_col_normal();
  6054.       #ifdef SPVW_PAGES
  6055.       #if defined(UNIX) || defined(AMIGAOS) || defined(RISCOS) || defined(WIN32_UNIX)
  6056.       # Wenn der in Pages allozierte, aber unbelegte Speicherplatz
  6057.       # mehr als 25% dessen ausmacht, was belegt ist, lohnt sich wohl eine
  6058.       # Kompaktierung, denn fürs Betriebssystem kostet eine halbleere Page
  6059.       # genausoviel wie eine volle Page:
  6060.       if (free_space() > floor(mem.last_gcend_space,4))
  6061.         { gar_col_compact(); mem.last_gc_compacted = TRUE; }
  6062.         else
  6063.       #endif
  6064.         { mem.last_gc_compacted = FALSE; }
  6065.       #endif
  6066.       #else # defined(GENERATIONAL_GC)
  6067.       # Wenn nach der letzten GC die Objekte in der neuen Generation
  6068.       # mehr als 25% der Objekte in der alten Generation ausmachten,
  6069.       # dann machen wir diesmal eine volle Garbage-Collection (beide
  6070.       # Generationen auf einmal.)
  6071.       if (mem.last_gcend_space1 > floor(mem.last_gcend_space0,4))
  6072.         { generation = 0; gar_col_normal(); mem.last_gc_full = TRUE; }
  6073.         else
  6074.         { generation = 1; gar_col_normal(); mem.last_gc_full = FALSE; }
  6075.       #endif
  6076.       gar_col_done();
  6077.       subr_self = popSTACK(); # subr_self zurück
  6078.       mv_count = saved_mv_count; # mv_count zurück
  6079.     }
  6080.  
  6081. # Volle Garbage Collection durchführen:
  6082.   global void gar_col (void);
  6083.   global void gar_col()
  6084.     { var uintC saved_mv_count = mv_count; # mv_count retten
  6085.       pushSTACK(subr_self); # subr_self retten
  6086.       #if !defined(GENERATIONAL_GC)
  6087.       gar_col_normal();
  6088.       #ifdef SPVW_PAGES
  6089.       gar_col_compact(); mem.last_gc_compacted = TRUE;
  6090.       #endif
  6091.       #else # defined(GENERATIONAL_GC)
  6092.       generation = 0; gar_col_normal(); mem.last_gc_full = TRUE;
  6093.       #endif
  6094.       gar_col_done();
  6095.       subr_self = popSTACK(); # subr_self zurück
  6096.       mv_count = saved_mv_count; # mv_count zurück
  6097.     }
  6098.  
  6099. # Macro aktualisiere jetzt unnötig:
  6100.   #undef aktualisiere
  6101.  
  6102. #if defined(SPVW_MIXED_BLOCKS_OPPOSITE) && RESERVE
  6103.  
  6104. # Zur Reorganisation des Objektspeichers nach GC oder vor und nach EXECUTE:
  6105.   # Unterprogramm zum Verschieben der Conses.
  6106.   # move_conses(delta);
  6107.   # Der Reservespeicher wird um delta Bytes (durch varobject_alignment
  6108.   # teilbar) verkleinert, dabei die Conses um delta Bytes nach oben geschoben.
  6109.   local void move_conses (sintL delta);
  6110.   local void move_conses (delta)
  6111.     var reg4 sintL delta;
  6112.     { if (delta==0) return; # keine Verschiebung nötig?
  6113.       set_break_sem_1(); # BREAK währenddessen sperren
  6114.       gc_signalblock_on(); # Signale währenddessen sperren
  6115.       gc_timer_on();
  6116.       if (delta>0)
  6117.         # aufwärts schieben, von oben nach unten
  6118.         { var reg1 object* source = (object*) mem.conses.heap_end;
  6119.           var reg3 object* source_end = (object*) mem.conses.heap_start;
  6120.           #if !(defined(MIPS) && !defined(GNU))
  6121.           var reg2 object* dest = (object*) (mem.conses.heap_end += delta);
  6122.           #else # IRIX 4 "cc -ansi" Compiler-Bug umgehen ??
  6123.           var reg2 object* dest = (mem.conses.heap_end += delta, (object*)mem.conses.heap_end);
  6124.           #endif
  6125.           mem.conses.heap_start += delta;
  6126.           until (source==source_end)
  6127.             { *--dest = *--source; # ein ganzes Cons nach oben kopieren
  6128.               *--dest = *--source;
  6129.         }   }
  6130.         else # delta<0
  6131.         # abwärts schieben, von unten nach oben
  6132.         { var reg1 object* source = (object*) mem.conses.heap_start;
  6133.           var reg3 object* source_end = (object*) mem.conses.heap_end;
  6134.           #if !(defined(MIPS) && !defined(GNU))
  6135.           var reg2 object* dest = (object*) (mem.conses.heap_start += delta);
  6136.           #else # IRIX 4 "cc -ansi" Compiler-Bug umgehen ??
  6137.           var reg2 object* dest = (mem.conses.heap_start += delta, (object*)mem.conses.heap_start);
  6138.           #endif
  6139.           mem.conses.heap_end += delta;
  6140.           until (source==source_end)
  6141.             { *dest++ = *source++; # ein ganzes Cons nach oben kopieren
  6142.               *dest++ = *source++;
  6143.         }   }
  6144.       # Pointer auf Conses u.ä. aktualisieren:
  6145.       { var reg4 soint odelta = (soint)delta<<(oint_addr_shift-addr_shift); # Offset im oint
  6146.         # Der gesamte LISP-Speicher wird durchgegangen und dabei alte durch
  6147.         # neue Adressen ersetzt.
  6148.         # Aktualisierung eines Objekts *objptr :
  6149.           #define aktualisiere(objptr)  \
  6150.             { switch (mtypecode(*(object*)(objptr)))                          \
  6151.                 { case_cons: case_ratio: case_complex: # Zwei-Pointer-Objekt? \
  6152.                     *(oint*)(objptr) += odelta; break;                        \
  6153.                   default: break;                                             \
  6154.             }   }
  6155.         # Durchlaufen durch alle LISP-Objekte und aktualisieren:
  6156.           # Pointer im LISP-Stack aktualisieren:
  6157.             { var reg2 object* objptr = &STACK_0; # Pointer, der durch den STACK läuft
  6158.               until (eq(*objptr,nullobj)) # bis STACK zu Ende ist:
  6159.                 { if ( *((oint*)objptr) & wbit(frame_bit_o) ) # Beginnt hier ein Frame?
  6160.                    { if (( *((oint*)objptr) & wbit(skip2_bit_o) ) == 0) # Ohne skip2-Bit?
  6161.                       objptr skipSTACKop 2; # ja -> um 2 weiterrücken
  6162.                       else
  6163.                       objptr skipSTACKop 1; # nein -> um 1 weiterrücken
  6164.                    }
  6165.                    else
  6166.                    { aktualisiere(objptr); # normales Objekt, aktualisieren
  6167.                      objptr skipSTACKop 1; # weiterrücken
  6168.             }   }  }
  6169.           # Programmkonstanten aktualisieren:
  6170.             aktualisiere_tab();
  6171.           # Pointer in den Cons-Zellen aktualisieren:
  6172.             aktualisiere_conses();
  6173.           # Pointer in den Objekten variabler Länge aktualisieren:
  6174.             #define aktualisiere_page  aktualisiere_page_normal
  6175.             #define aktualisiere_fpointer_invalid  FALSE
  6176.             aktualisiere_varobjects();
  6177.             #undef aktualisiere_fpointer_invalid
  6178.             #undef aktualisiere_page
  6179.         # Macro aktualisiere jetzt unnötig:
  6180.           #undef aktualisiere
  6181.       }
  6182.       # Ende des Verschiebens und Aktualisierens.
  6183.       # benötigte Zeit zur GC-Gesamtzeit addieren:
  6184.       gc_timer_off();
  6185.       gc_signalblock_off(); # Signale wieder freigeben
  6186.       clr_break_sem_1(); # BREAK wieder ermöglichen
  6187.     }
  6188.  
  6189. #endif
  6190.  
  6191. # ------------------------------------------------------------------------------
  6192. #                 Speicherbereitstellungsfunktionen
  6193.  
  6194. # Fehlermeldung wegen vollen Speichers
  6195.   nonreturning_function(local, fehler_speicher_voll, (void));
  6196.   local void fehler_speicher_voll()
  6197.     { dynamic_bind(S(use_clcs),NIL); # SYS::*USE-CLCS* an NIL binden
  6198.       //: DEUTSCH "Speicherplatz für LISP-Objekte ist voll."
  6199.       //: ENGLISH "No more room for LISP objects"
  6200.       //: FRANCAIS "Il n'y a plus de place pour des objets LISP."
  6201.       fehler(storage_condition,GETTEXT("no more room for LISP objects"));
  6202.     }
  6203.  
  6204. # Stellt fest, ob eine Adresse im Intervall [0..2^oint_addr_len-1] liegt:
  6205.   #if (oint_addr_len==32) && !defined(WIDE_HARD) # d.h. defined(WIDE_SOFT)
  6206.     #define pointable_usable_test(a)  TRUE
  6207.   #else
  6208.     #define pointable_usable_test(a)  \
  6209.       ((void*)pointable(type_pointer_object(0,a)) == (void*)(a))
  6210.   #endif
  6211.  
  6212. # Holt Speicher vom Betriebssystem
  6213.   local void* mymalloc (uintL need);
  6214.   local void* mymalloc(need)
  6215.     var reg3 uintL need;
  6216.     {
  6217.       var reg1 void* addr;
  6218.       begin_system_call();
  6219.       addr = malloc(need);
  6220.       end_system_call();
  6221.       if (addr==NULL) return NULL;
  6222.       # Intervall [addr,addr+need-1] muß in [0..2^oint_addr_len-1] liegen:
  6223.       { var reg2 aint a = (aint)addr; # a = untere Intervallgrenze
  6224.         if (pointable_usable_test(a))
  6225.           { a = round_down(a + need-1,bit(addr_shift)); # a = obere Intervallgrenze
  6226.             if (pointable_usable_test(a))
  6227.               { return addr; }
  6228.       }   }
  6229.       # Mit diesem Stück Speicher können wir nichts anfangen, wieder zurückgeben:
  6230.       begin_system_call();
  6231.       free(addr);
  6232.       end_system_call();
  6233.       #if defined(AMIGAOS) && !(defined(WIDE) || defined(MC68000))
  6234.       # Wir machen einen zweiten Versuch mit veränderten Flags.
  6235.       if (!(default_allocmemflag == retry_allocmemflag))
  6236.         { addr = allocmem(need,retry_allocmemflag);
  6237.           if (addr==NULL) return NULL;
  6238.           # Intervall [addr,addr+need-1] muß in [0..2^oint_addr_len-1] liegen:
  6239.           { var reg2 aint a = (aint)addr; # a = untere Intervallgrenze
  6240.             if (pointable_usable_test(a))
  6241.               { a = round_down(a + need-1,bit(addr_shift)); # a = obere Intervallgrenze
  6242.                 if (pointable_usable_test(a))
  6243.                   { return addr; }
  6244.           }   }
  6245.           # Auch mit diesem Stück Speicher können wir nichts anfangen, wieder zurückgeben:
  6246.           freemem(addr);
  6247.         }
  6248.       #endif
  6249.       return NULL;
  6250.     }
  6251.  
  6252. #ifdef SPVW_MIXED_BLOCKS_OPPOSITE
  6253.  
  6254. # Schafft Platz für ein neues Objekt.
  6255. # Falls keiner vorhanden -> Fehlermeldung.
  6256. # make_space(need);
  6257. # > uintL need: angeforderter Platz in Bytes (eine Variable oder Konstante)
  6258.   # Der Test, ob Platz vorhanden ist, als Macro, der Rest als Funktion:
  6259.   #define make_space(need)  \
  6260.     { if (not_enough_room_p(need)) make_space_gc(need); }
  6261.   #if !defined(GENERATIONAL_GC)
  6262.     #define not_enough_room_p(need)  (mem.conses.heap_start-mem.varobjects.heap_end < (uintP)(need))
  6263.   #else
  6264.     #define not_enough_room_p(need)  (mem.total_room < (uintL)(need))
  6265.   #endif
  6266.   local void make_space_gc (uintL need);
  6267.   local void make_space_gc(need)
  6268.     var reg1 uintL need;
  6269.     { # (mem.conses.heap_start-mem.varobjects.heap_end < need)  bzw.
  6270.       # (mem.total_room < need)  ist schon abgeprüft, also
  6271.         # Nicht genügend Platz
  6272.         not_enough_room:
  6273.         { gar_col_simple(); # Garbage Collector aufrufen
  6274.           doing_gc:
  6275.           # Teste auf Tastatur-Unterbrechung
  6276.           interruptp(
  6277.             { pushSTACK(S(gc)); tast_break();
  6278.               if (not_enough_room_p(need)) goto not_enough_room;
  6279.                 else
  6280.                 return;
  6281.             });
  6282.           if (mem.conses.heap_start-mem.varobjects.heap_end < (uintP)(need)) # und wieder testen
  6283.             # Wirklich nicht genügend Platz da.
  6284.             # [Unter UNIX mit 'realloc' arbeiten??]
  6285.             # Abhilfe: man versucht eine volle GC.
  6286.             {
  6287.               #ifdef GENERATIONAL_GC
  6288.               if (!mem.last_gc_full)
  6289.                 { gar_col(); goto doing_gc; }
  6290.                 else
  6291.               #endif
  6292.                 # Abhilfe: Reservespeicher wird halbiert.
  6293.                 {
  6294.                   #if RESERVE
  6295.                   var reg1 uintL reserve = mem.MEMTOP - mem.MEMRES; # noch freie Reserve
  6296.                   if (reserve>=8) # Reservespeicher auch voll?
  6297.                     # nein -> Reservespeicher anzapfen und Fehlermeldung ausgeben
  6298.                     # halbe Reserve
  6299.                     { move_conses(round_down(floor(reserve,2),varobject_alignment));
  6300.                       # halbierte Reserve, aligned: um soviel die Conses nach oben schieben
  6301.                       fehler_speicher_voll();
  6302.                     }
  6303.                     else
  6304.                   #endif
  6305.                     # ja -> harte Fehlermeldung
  6306.                     { 
  6307.                       //: DEUTSCH "Speicherplatz für LISP-Objekte ist voll: RESET"
  6308.                       //: ENGLISH "No more room for LISP objects: RESET"
  6309.                       //: FRANCAIS "Il n'y a plus de place pour des objets LISP : RAZ"
  6310.                       err_asciz_out(GETTEXT("no more room for LISP objects"));
  6311.                       reset(); # und zum letzten Driver-Frame zurück
  6312.                     }
  6313.                 }
  6314.             }
  6315.             else
  6316.             # Jetzt ist genügend Platz da. Vielleicht sogar genug, den
  6317.             # Reservespeicher auf normale Größe zu bringen?
  6318.             {
  6319.               #if RESERVE
  6320.               var reg2 uintL free = (mem.conses.heap_start-mem.varobjects.heap_end) - need;
  6321.                                 # soviel Bytes noch frei
  6322.               var reg2 uintL free_reserve = mem.MEMTOP-mem.MEMRES;
  6323.                                 # soviel Bytes noch in der Reserve frei, <=RESERVE
  6324.               var reg2 uintL free_total = free + free_reserve;
  6325.                                 # freier Objektspeicher + freie Reserve
  6326.               if (free_total >= RESERVE) # mindestens Normalwert RESERVE ?
  6327.                 # ja -> Reservespeicher auf normale Größe bringen, indem
  6328.                 # die Conses um (RESERVE - free_reserve) nach unten geschoben
  6329.                 # werden:
  6330.                 move_conses(free_reserve-RESERVE);
  6331.                 # Dadurch bleibt genügend für need frei.
  6332.               #endif
  6333.               # Jetzt ist sicher (mem.conses.heap_start-mem.varobjects.heap_end >= need).
  6334.               #ifdef GENERATIONAL_GC
  6335.               # Falls (mem.total_room < need), ignorieren wir das:
  6336.               if (mem.total_room < need) { mem.total_room = need; }
  6337.               #endif
  6338.             }
  6339.     }   }
  6340.  
  6341. #endif
  6342.  
  6343. #if defined(SPVW_PURE_BLOCKS) || defined(TRIVIALMAP_MEMORY) # <==> SINGLEMAP_MEMORY || TRIVIALMAP_MEMORY
  6344.  
  6345. # Schafft Platz für ein neues Objekt.
  6346. # Falls keiner vorhanden -> Fehlermeldung.
  6347. # make_space(need,heapptr);
  6348. # > uintL need: angeforderter Platz in Bytes (eine Variable oder Konstante)
  6349. # > Heap* heapptr: Pointer auf den Heap, dem der Platz entnommen werden soll
  6350.   # Der Test, ob Platz vorhanden ist, als Macro, der Rest als Funktion:
  6351.   #define make_space(need,heapptr)  \
  6352.     { if ((mem.total_room < (uintL)(need))                                 \
  6353.           || ((heapptr)->heap_limit - (heapptr)->heap_end < (uintP)(need)) \
  6354.          )                                                                 \
  6355.         make_space_gc(need,heapptr);                                       \
  6356.     }
  6357.   local void make_space_gc (uintL need, Heap* heapptr);
  6358.   local void make_space_gc(need,heapptr)
  6359.     var reg2 uintL need;
  6360.     var reg1 Heap* heapptr;
  6361.     { # (mem.total_room < need) || (heapptr->heap_limit - heapptr->heap_end < need)
  6362.       # ist schon abgeprüft, also nicht genügend Platz.
  6363.       not_enough_room:
  6364.      {var reg4 boolean done_gc = FALSE;
  6365.       if (mem.total_room < need)
  6366.         do_gc:
  6367.         { gar_col_simple(); # Garbage Collector aufrufen
  6368.           doing_gc:
  6369.           # Teste auf Tastatur-Unterbrechung
  6370.           interruptp(
  6371.             { pushSTACK(S(gc)); tast_break();
  6372.               if ((mem.total_room < need) || (heapptr->heap_limit - heapptr->heap_end < need))
  6373.                 goto not_enough_room;
  6374.                 else
  6375.                 return;
  6376.             });
  6377.           done_gc = TRUE;
  6378.         }
  6379.       # Entweder ist jetzt (mem.total_room >= need), oder aber wir haben gerade
  6380.       # eine GC durchgeführt. In beiden Fällen konzentrieren wir uns nun
  6381.       # darauf, heapptr->heap_limit zu vergrößern.
  6382.       { var reg3 aint needed_limit = heapptr->heap_end + need;
  6383.         if (needed_limit <= heapptr->heap_limit) # hat die GC ihre Arbeit getan?
  6384.           return; # ja -> fertig
  6385.         # Aufrunden bis zur nächsten Seitengrenze:
  6386.         #ifndef GENERATIONAL_GC
  6387.         needed_limit = round_up(needed_limit,map_pagesize); # sicher > heapptr->heap_limit
  6388.         #else # map_pagesize bekanntermaßen eine Zweierpotenz
  6389.         needed_limit = (needed_limit + map_pagesize-1) & -map_pagesize; # sicher > heapptr->heap_limit
  6390.         #endif
  6391.         # neuen Speicher allozieren:
  6392.         if (zeromap((void*)(heapptr->heap_limit),needed_limit - heapptr->heap_limit) <0)
  6393.           { if (!done_gc)
  6394.               goto do_gc;
  6395.             #ifdef GENERATIONAL_GC
  6396.             if (!mem.last_gc_full)
  6397.               { gar_col(); goto doing_gc; }
  6398.             #endif
  6399.             fehler_speicher_voll();
  6400.           }
  6401.         heapptr->heap_limit = needed_limit;
  6402.       }
  6403.       # Jetzt ist sicher (heapptr->heap_limit - heapptr->heap_end >= need).
  6404.       # Falls (mem.total_room < need), ignorieren wir das:
  6405.       if (mem.total_room < need) { mem.total_room = need; }
  6406.     }}
  6407.  
  6408. #endif
  6409.  
  6410. #ifdef SPVW_PAGES
  6411.  
  6412. # Schafft Platz für ein neues Objekt.
  6413. # Falls keiner vorhanden -> Fehlermeldung.
  6414. # make_space(need,heap_ptr,stack_ptr, page);
  6415. # > uintL need: angeforderter Platz in Bytes (eine Variable oder Konstante)
  6416. # > Heap* heap_ptr: Adresse des Heaps, aus dem der Platz genommen werden soll
  6417. # > AVL(AVLID,stack) * stack_ptr: Adressen eines lokalen Stacks,
  6418. #   für ein späteres AVL(AVLID,move)
  6419. # < Pages page: gefundene Page, wo der Platz ist
  6420.   # Der Test, ob Platz vorhanden ist, als Macro, der Rest als Funktion:
  6421.   #define make_space(need,heap_ptr,stack_ptr,pagevar)  \
  6422.     { pagevar = AVL(AVLID,least)(need,&(heap_ptr)->inuse,stack_ptr);    \
  6423.       if (pagevar==EMPTY)                                               \
  6424.         { pagevar = make_space_gc(need,&(heap_ptr)->inuse,stack_ptr); } \
  6425.     }
  6426.   local Pages make_space_gc (uintL need, Pages* pages_ptr, AVL(AVLID,stack) * stack_ptr);
  6427.   local Pages make_space_gc(need,pages_ptr,stack_ptr)
  6428.     var reg2 uintL need;
  6429.     var reg3 Pages* pages_ptr;
  6430.     var reg4 AVL(AVLID,stack) * stack_ptr;
  6431.     { # AVL(AVLID,least)(need,pages_ptr,stack_ptr) == EMPTY
  6432.       # ist schon abgeprüft, also
  6433.         # Nicht genügend Platz
  6434.         not_enough_room:
  6435.         #define handle_interrupt_after_gc()  \
  6436.           { # Teste auf Tastatur-Unterbrechung                                    \
  6437.             interruptp(                                                           \
  6438.               { pushSTACK(S(gc)); tast_break();                                   \
  6439.                {var reg1 Pages page = AVL(AVLID,least)(need,pages_ptr,stack_ptr); \
  6440.                 if (page==EMPTY) goto not_enough_room;                            \
  6441.                   else                                                            \
  6442.                   return page;                                                    \
  6443.               }});                                                                \
  6444.           }
  6445.         #if !defined(AVL_SEPARATE)
  6446.         #define make_space_using_malloc()  \
  6447.           # versuche, beim Betriebssystem Platz zu bekommen:                        \
  6448.           { var reg5 uintL size1 = round_up(need,sizeof(cons_));                    \
  6449.             if (size1 < std_page_size) { size1 = std_page_size; }                   \
  6450.            {var reg7 uintL size2 = size1 + sizeof(NODE) + (varobject_alignment-1);  \
  6451.             var reg6 aint addr = (aint)mymalloc(size2);                             \
  6452.             if (!((void*)addr == NULL))                                             \
  6453.               { # Page vom Betriebssystem bekommen.                                 \
  6454.                 var reg1 Pages page = (Pages)addr;                                  \
  6455.                 page->m_start = addr; page->m_length = size2;                       \
  6456.                 # Initialisieren:                                                   \
  6457.                 page->page_start = page->page_end = page_start0(page);              \
  6458.                 page->page_room = size1;                                            \
  6459.                 # Diesem Heap zuschlagen:                                           \
  6460.                 *pages_ptr = AVL(AVLID,insert1)(page,*pages_ptr);                   \
  6461.                 if (!(AVL(AVLID,least)(need,pages_ptr,stack_ptr) == page)) abort(); \
  6462.                 mem.total_space += size1;                                           \
  6463.                 return page;                                                        \
  6464.           }}  }
  6465.         #else # AVL_SEPARATE
  6466.         #define make_space_using_malloc()  \
  6467.           # versuche, beim Betriebssystem Platz zu bekommen:                            \
  6468.           { var reg5 uintL size1 = round_up(need,sizeof(cons_));                        \
  6469.             if (size1 < std_page_size) { size1 = std_page_size; }                       \
  6470.             begin_system_call();                                                        \
  6471.            {var reg1 Pages page = (NODE*)malloc(sizeof(NODE));                          \
  6472.             end_system_call();                                                          \
  6473.             if (!(page == NULL))                                                        \
  6474.               { var reg7 uintL size2 = size1 + (varobject_alignment-1);                 \
  6475.                 var reg6 aint addr = (aint)mymalloc(size2);                             \
  6476.                 if (!((void*)addr == NULL))                                             \
  6477.                   { # Page vom Betriebssystem bekommen.                                 \
  6478.                     page->m_start = addr; page->m_length = size2;                       \
  6479.                     # Initialisieren:                                                   \
  6480.                     page->page_start = page->page_end = page_start0(page);              \
  6481.                     page->page_room = size1;                                            \
  6482.                     # Diesem Heap zuschlagen:                                           \
  6483.                     *pages_ptr = AVL(AVLID,insert1)(page,*pages_ptr);                   \
  6484.                     if (!(AVL(AVLID,least)(need,pages_ptr,stack_ptr) == page)) abort(); \
  6485.                     mem.total_space += size1;                                           \
  6486.                     return page;                                                        \
  6487.                   }                                                                     \
  6488.                   else                                                                  \
  6489.                   { begin_system_call(); free(page); end_system_call(); }               \
  6490.           }}  }
  6491.         #endif
  6492.         if ((need <= std_page_size) && !(mem.free_pages == NULL))
  6493.           { # Eine normalgroße Page aus dem allgemeinen Pool entnehmen:
  6494.             var reg1 Pages page = mem.free_pages;
  6495.             mem.free_pages = page->page_gcpriv.next;
  6496.             # page ist bereits korrekt initialisiert:
  6497.             # page->page_start = page->page_end = page_start0(page);
  6498.             # page->page_room =
  6499.             #   round_down(page->m_start + page->m_length,varobject_alignment)
  6500.             # und diesem Heap zuschlagen:
  6501.             *pages_ptr = AVL(AVLID,insert1)(page,*pages_ptr);
  6502.             if (!(AVL(AVLID,least)(need,pages_ptr,stack_ptr) == page)) abort();
  6503.             mem.total_space += page->page_room;
  6504.             return page;
  6505.           }
  6506.         if (used_space()+need < mem.gctrigger_space)
  6507.           # Benutzter Platz ist seit der letzten GC noch nicht einmal um 25%
  6508.           # angewachsen -> versuche es erstmal beim Betriebssystem;
  6509.           # die GC machen wir, wenn die 25%-Grenze erreicht ist.
  6510.           { make_space_using_malloc(); }
  6511.         { gar_col_simple(); # Garbage Collector aufrufen
  6512.           handle_interrupt_after_gc();
  6513.           # und wieder testen:
  6514.          {var reg1 Pages page = AVL(AVLID,least)(need,pages_ptr,stack_ptr);
  6515.           if (page==EMPTY)
  6516.             { if (!mem.last_gc_compacted)
  6517.                 { gar_col_compact(); # kompaktierenden Garbage Collector aufrufen
  6518.                   handle_interrupt_after_gc();
  6519.                   page = AVL(AVLID,least)(need,pages_ptr,stack_ptr);
  6520.                 }
  6521.               if (page==EMPTY)
  6522.                 # versuche es nun doch beim Betriebssystem:
  6523.                 { make_space_using_malloc();
  6524.                   fehler_speicher_voll();
  6525.             }   }
  6526.           # .reserve behandeln??
  6527.           return page;
  6528.         }}
  6529.         #undef make_space_using_malloc
  6530.         #undef handle_interrupt_after_gc
  6531.     }
  6532.  
  6533. #endif
  6534.  
  6535. # Macro zur Speicher-Allozierung eines Lisp-Objekts:
  6536. # allocate(type,flag,size,ptrtype,ptr,statement)
  6537. # > type: Expression, die den Typcode liefert
  6538. # > flag: ob Objekt variabler Länge oder nicht
  6539. # > size: Expression (constant oder var), die die Größe des benötigten
  6540. #         Speicherstücks angibt
  6541. # ptrtype: C-Typ von ptr
  6542. # ptr: C-Variable
  6543. # Ein Speicherstück der Länge size, passend zu einem Lisp-Objekt vom Typ type,
  6544. # wird geholt und ptr auf seine Anfangsadresse gesetzt. Dann wird statement
  6545. # ausgeführt (Initialisierung des Speicherstücks) und schließlich ptr,
  6546. # mit der korrekten Typinfo versehen, als Ergebnis geliefert.
  6547.   #ifdef SPVW_BLOCKS
  6548.    #if defined(SPVW_PURE_BLOCKS) || defined(TRIVIALMAP_MEMORY) || defined(GENERATIONAL_GC)
  6549.     #define decrement_total_room(amount)  mem.total_room -= (amount);
  6550.    #else
  6551.     #define decrement_total_room(amount)
  6552.    #endif
  6553.    #ifdef SPVW_MIXED_BLOCKS_OPPOSITE
  6554.     #define allocate(type_expr,flag,size_expr,ptrtype,ptrvar,statement)  \
  6555.       allocate_##flag (type_expr,size_expr,ptrtype,ptrvar,statement)
  6556.     # Objekt variabler Länge:
  6557.     #define allocate_TRUE(type_expr,size_expr,ptrtype,ptrvar,statement)  \
  6558.       { make_space(size_expr);                                                        \
  6559.         set_break_sem_1(); # Break sperren                                            \
  6560.        {var reg1 ptrtype ptrvar;                                                      \
  6561.         var reg4 object obj;                                                          \
  6562.         ptrvar = (ptrtype) mem.varobjects.heap_end; # Pointer auf Speicherstück       \
  6563.         mem.varobjects.heap_end += (size_expr); # Speicheraufteilung berichtigen      \
  6564.         decrement_total_room(size_expr);                                              \
  6565.         ptrvar->GCself = obj = type_pointer_object(type_expr,ptrvar); # Selbstpointer \
  6566.         statement; # Speicherstück initialisieren                                     \
  6567.         clr_break_sem_1(); # Break ermöglichen                                        \
  6568.         CHECK_GC_CONSISTENCY();                                                       \
  6569.         return obj;                                                                   \
  6570.       }}
  6571.     # Cons o.ä.:
  6572.     #define allocate_FALSE(type_expr,size_expr,ptrtype,ptrvar,statement)  \
  6573.       { make_space(size_expr);                                                              \
  6574.         set_break_sem_1(); # Break sperren                                                  \
  6575.        {var reg1 ptrtype ptrvar;                                                            \
  6576.         ptrvar = (ptrtype)(mem.conses.heap_start -= size_expr); # Pointer auf Speicherstück \
  6577.         decrement_total_room(size_expr);                                                    \
  6578.         statement; # Speicherstück initialisieren                                           \
  6579.         clr_break_sem_1(); # Break ermöglichen                                              \
  6580.         CHECK_GC_CONSISTENCY();                                                             \
  6581.         return type_pointer_object(type_expr,ptrvar);                                       \
  6582.       }}
  6583.    #endif
  6584.    #if defined(SPVW_MIXED_BLOCKS) && defined(TRIVIALMAP_MEMORY)
  6585.     #define allocate(type_expr,flag,size_expr,ptrtype,ptrvar,statement)  \
  6586.       allocate_##flag (type_expr,size_expr,ptrtype,ptrvar,statement)
  6587.     # Objekt variabler Länge:
  6588.     #define allocate_TRUE(type_expr,size_expr,ptrtype,ptrvar,statement)  \
  6589.       { make_space(size_expr,&mem.varobjects);                                        \
  6590.         set_break_sem_1(); # Break sperren                                            \
  6591.        {var reg1 ptrtype ptrvar;                                                      \
  6592.         var reg4 object obj;                                                          \
  6593.         ptrvar = (ptrtype) mem.varobjects.heap_end; # Pointer auf Speicherstück       \
  6594.         mem.varobjects.heap_end += (size_expr); # Speicheraufteilung berichtigen      \
  6595.         decrement_total_room(size_expr);                                              \
  6596.         ptrvar->GCself = obj = type_pointer_object(type_expr,ptrvar); # Selbstpointer \
  6597.         statement; # Speicherstück initialisieren                                     \
  6598.         clr_break_sem_1(); # Break ermöglichen                                        \
  6599.         CHECK_GC_CONSISTENCY();                                                       \
  6600.         return obj;                                                                   \
  6601.       }}
  6602.     # Cons o.ä.:
  6603.     #define allocate_FALSE(type_expr,size_expr,ptrtype,ptrvar,statement)  \
  6604.       { make_space(size_expr,&mem.conses);                                                   \
  6605.         set_break_sem_1(); # Break sperren                                                   \
  6606.        {var reg1 ptrtype ptrvar = (ptrtype) mem.conses.heap_end; # Pointer auf Speicherstück \
  6607.         mem.conses.heap_end += (size_expr); # Speicheraufteilung berichtigen                 \
  6608.         decrement_total_room(size_expr);                                                     \
  6609.         statement; # Speicherstück initialisieren                                            \
  6610.         clr_break_sem_1(); # Break ermöglichen                                               \
  6611.         CHECK_GC_CONSISTENCY();                                                              \
  6612.         return type_pointer_object(type_expr,ptrvar);                                        \
  6613.       }}
  6614.    #endif
  6615.    #ifdef SPVW_PURE
  6616.     #define allocate(type_expr,flag,size_expr,ptrtype,ptrvar,statement)  \
  6617.       { var reg4 tint _type = (type_expr);                                 \
  6618.         var reg3 Heap* heapptr = &mem.heaps[_type];                        \
  6619.         make_space(size_expr,heapptr);                                     \
  6620.         set_break_sem_1(); # Break sperren                                 \
  6621.        {var reg1 ptrtype ptrvar = (ptrtype)(heapptr->heap_end); # Pointer auf Speicherstück \
  6622.         heapptr->heap_end += (size_expr); # Speicheraufteilung berichtigen \
  6623.         decrement_total_room(size_expr);                                   \
  6624.         allocate_##flag (ptrvar);                                          \
  6625.         statement; # Speicherstück initialisieren                          \
  6626.         clr_break_sem_1(); # Break ermöglichen                             \
  6627.         CHECK_GC_CONSISTENCY();                                            \
  6628.         return as_object((oint)ptrvar);                                    \
  6629.       }}
  6630.     # Objekt variabler Länge:
  6631.     #define allocate_TRUE(ptrvar)  \
  6632.       ptrvar->GCself = as_object((oint)ptrvar); # Selbstpointer eintragen
  6633.     # Cons o.ä.:
  6634.     #define allocate_FALSE(ptrvar)
  6635.    #endif
  6636.   #endif
  6637.   #ifdef SPVW_PAGES
  6638.     #define allocate(type_expr,flag,size_expr,ptrtype,ptrvar,statement)  \
  6639.       allocate_##flag (type_expr,size_expr,ptrtype,ptrvar,statement)
  6640.    #ifdef SPVW_MIXED
  6641.     # Objekt variabler Länge:
  6642.     #define allocate_TRUE(type_expr,size_expr,ptrtype,ptrvar,statement)  \
  6643.       { # Suche nach der Page mit dem kleinsten page_room >= size_expr:               \
  6644.         var AVL(AVLID,stack) stack;                                                   \
  6645.         var reg2 Pages page;                                                          \
  6646.         make_space(size_expr,&mem.varobjects,&stack, page);                           \
  6647.         set_break_sem_1(); # Break sperren                                            \
  6648.        {var reg1 ptrtype ptrvar =                                                     \
  6649.           (ptrtype)(page->page_end); # Pointer auf Speicherstück                      \
  6650.         var reg4 object obj;                                                          \
  6651.         ptrvar->GCself = obj = type_pointer_object(type_expr,ptrvar); # Selbstpointer \
  6652.         statement; # Speicherstück initialisieren                                     \
  6653.         page->page_room -= (size_expr); # Speicheraufteilung berichtigen              \
  6654.         page->page_end += (size_expr);                                                \
  6655.         mem.used_space += (size_expr);                                                \
  6656.         AVL(AVLID,move)(&stack); # Page wieder an die richtige Position hängen        \
  6657.         clr_break_sem_1(); # Break ermöglichen                                        \
  6658.         CHECK_AVL_CONSISTENCY();                                                      \
  6659.         CHECK_GC_CONSISTENCY();                                                       \
  6660.         return obj;                                                                   \
  6661.       }}
  6662.     # Cons o.ä.:
  6663.     #define allocate_FALSE(type_expr,size_expr,ptrtype,ptrvar,statement)  \
  6664.       { # Suche nach der Page mit dem kleinsten page_room >= size_expr = 8: \
  6665.         var reg2 Pages page;                                                \
  6666.         # 1. Versuch: letzte benutzte Page                                  \
  6667.         page = mem.conses.lastused;                                         \
  6668.         if (page->page_room == 0) # Test auf page->page_room < size_expr = sizeof(cons_) \
  6669.           { var AVL(AVLID,stack) stack;                                     \
  6670.             # 2. Versuch:                                                   \
  6671.             make_space(size_expr,&mem.conses,&stack, page);                 \
  6672.             mem.conses.lastused = page;                                     \
  6673.           }                                                                 \
  6674.         set_break_sem_1(); # Break sperren                                  \
  6675.        {var reg1 ptrtype ptrvar =                                           \
  6676.           (ptrtype)(page->page_end); # Pointer auf Speicherstück            \
  6677.         statement; # Speicherstück initialisieren                           \
  6678.         page->page_room -= (size_expr); # Speicheraufteilung berichtigen    \
  6679.         page->page_end += (size_expr);                                      \
  6680.         mem.used_space += (size_expr);                                      \
  6681.         # Da page_room nun =0 geworden oder >=sizeof(cons_) geblieben ist,  \
  6682.         # ist die Sortierreihenfolge der Pages unverändert geblieben.       \
  6683.         clr_break_sem_1(); # Break ermöglichen                              \
  6684.         CHECK_AVL_CONSISTENCY();                                            \
  6685.         CHECK_GC_CONSISTENCY();                                             \
  6686.         return type_pointer_object(type_expr,ptrvar);                       \
  6687.       }}
  6688.    #endif
  6689.    #ifdef SPVW_PURE
  6690.     # Objekt variabler Länge:
  6691.     #define allocate_TRUE(type_expr,size_expr,ptrtype,ptrvar,statement)  \
  6692.       { # Suche nach der Page mit dem kleinsten page_room >= size_expr:           \
  6693.         var AVL(AVLID,stack) stack;                                               \
  6694.         var reg2 Pages page;                                                      \
  6695.         var reg4 tint _type = (type_expr);                                        \
  6696.         make_space(size_expr,&mem.heaps[_type],&stack, page);                     \
  6697.         set_break_sem_1(); # Break sperren                                        \
  6698.        {var reg1 ptrtype ptrvar =                                                 \
  6699.           (ptrtype)(page->page_end); # Pointer auf Speicherstück                  \
  6700.         var reg5 object obj;                                                      \
  6701.         ptrvar->GCself = obj = type_pointer_object(_type,ptrvar); # Selbstpointer \
  6702.         statement; # Speicherstück initialisieren                                 \
  6703.         page->page_room -= (size_expr); # Speicheraufteilung berichtigen          \
  6704.         page->page_end += (size_expr);                                            \
  6705.         mem.used_space += (size_expr);                                            \
  6706.         AVL(AVLID,move)(&stack); # Page wieder an die richtige Position hängen    \
  6707.         clr_break_sem_1(); # Break ermöglichen                                    \
  6708.         CHECK_AVL_CONSISTENCY();                                                  \
  6709.         CHECK_GC_CONSISTENCY();                                                   \
  6710.         return obj;                                                               \
  6711.       }}
  6712.     # Cons o.ä.:
  6713.     #define allocate_FALSE(type_expr,size_expr,ptrtype,ptrvar,statement)  \
  6714.       { # Suche nach der Page mit dem kleinsten page_room >= size_expr = 8: \
  6715.         var reg2 Pages page;                                                \
  6716.         var reg4 tint _type = (type_expr);                                  \
  6717.         var reg3 Heap* heapptr = &mem.heaps[_type];                         \
  6718.         # 1. Versuch: letzte benutzte Page                                  \
  6719.         page = heapptr->lastused;                                           \
  6720.         if (page->page_room == 0) # Test auf page->page_room < size_expr = sizeof(cons_) \
  6721.           { var AVL(AVLID,stack) stack;                                     \
  6722.             # 2. Versuch:                                                   \
  6723.             make_space(size_expr,heapptr,&stack, page);                     \
  6724.             heapptr->lastused = page;                                       \
  6725.           }                                                                 \
  6726.         set_break_sem_1(); # Break sperren                                  \
  6727.        {var reg1 ptrtype ptrvar =                                           \
  6728.           (ptrtype)(page->page_end); # Pointer auf Speicherstück            \
  6729.         statement; # Speicherstück initialisieren                           \
  6730.         page->page_room -= (size_expr); # Speicheraufteilung berichtigen    \
  6731.         page->page_end += (size_expr);                                      \
  6732.         mem.used_space += (size_expr);                                      \
  6733.         # Da page_room nun =0 geworden oder >=sizeof(cons_) geblieben ist,  \
  6734.         # ist die Sortierreihenfolge der Pages unverändert geblieben.       \
  6735.         clr_break_sem_1(); # Break ermöglichen                              \
  6736.         CHECK_AVL_CONSISTENCY();                                            \
  6737.         CHECK_GC_CONSISTENCY();                                             \
  6738.         return type_pointer_object(_type,ptrvar);                           \
  6739.       }}
  6740.    #endif
  6741.   #endif
  6742.  
  6743. # UP, beschafft ein Cons
  6744. # allocate_cons()
  6745. # < ergebnis: Pointer auf neues CONS, mit CAR und CDR =NIL
  6746. # kann GC auslösen
  6747.   global object allocate_cons (void);
  6748.   global object allocate_cons()
  6749.     { allocate(cons_type,FALSE,sizeof(cons_),Cons,ptr,
  6750.                { ptr->cdr = NIL; ptr->car = NIL; }
  6751.               )
  6752.     }
  6753.  
  6754. # UP: Liefert ein neu erzeugtes uninterniertes Symbol mit gegebenem Printnamen.
  6755. # make_symbol(string)
  6756. # > string: Simple-String
  6757. # < ergebnis: neues Symbol mit diesem Namen, mit Home-Package=NIL.
  6758. # kann GC auslösen
  6759.   global object make_symbol (object string);
  6760.   global object make_symbol(string)
  6761.     var reg3 object string;
  6762.     {
  6763.       #ifdef IMMUTABLE_ARRAY
  6764.       string = make_imm_array(string); # String immutabel machen
  6765.       #endif
  6766.       pushSTACK(string); # String retten
  6767.       allocate(symbol_type,TRUE,size_symbol(),Symbol,ptr,
  6768.                { ptr->symvalue = unbound; # leere Wertzelle
  6769.                  ptr->symfunction = unbound; # leere Funktionszelle
  6770.                  ptr->proplist = NIL; # leere Propertyliste
  6771.                  ptr->pname = popSTACK(); # Namen eintragen
  6772.                  ptr->homepackage = NIL; # keine Home-Package
  6773.                }
  6774.               )
  6775.     }
  6776.  
  6777. # UP, beschafft Vektor
  6778. # allocate_vector(len)
  6779. # > len: Länge des Vektors
  6780. # < ergebnis: neuer Vektor (Elemente werden mit NIL initialisiert)
  6781. # kann GC auslösen
  6782.   global object allocate_vector (uintL len);
  6783.   global object allocate_vector (len)
  6784.     var reg2 uintL len;
  6785.     { var reg3 uintL need = size_svector(len); # benötigter Speicherplatz
  6786.       allocate(svector_type,TRUE,need,Svector,ptr,
  6787.                { ptr->length = len;
  6788.                 {var reg1 object* p = &ptr->data[0];
  6789.                  dotimesL(len,len, { *p++ = NIL; } ); # Elemente mit NIL vollschreiben
  6790.                }}
  6791.               )
  6792.     }
  6793.  
  6794. # UP, beschafft Bit-Vektor
  6795. # allocate_bit_vector(len)
  6796. # > len: Länge des Bitvektors (in Bits)
  6797. # < ergebnis: neuer Bitvektor (LISP-Objekt)
  6798. # kann GC auslösen
  6799.   global object allocate_bit_vector (uintL len);
  6800.   global object allocate_bit_vector (len)
  6801.     var reg2 uintL len;
  6802.     { var reg3 uintL need = size_sbvector(len); # benötigter Speicherplatz in Bytes
  6803.       allocate(sbvector_type,TRUE,need,Sbvector,ptr,
  6804.                { ptr->length = len; } # Keine weitere Initialisierung
  6805.               )
  6806.     }
  6807.  
  6808. # UP, beschafft String
  6809. # allocate_string(len)
  6810. # > len: Länge des Strings (in Bytes)
  6811. # < ergebnis: neuer Simple-String (LISP-Objekt)
  6812. # kann GC auslösen
  6813.   global object allocate_string (uintL len);
  6814.   global object allocate_string (len)
  6815.     var reg2 uintL len;
  6816.     { var reg4 uintL need = size_sstring(len); # benötigter Speicherplatz in Bytes
  6817.       allocate(sstring_type,TRUE,need,Sstring,ptr,
  6818.                { ptr->length = len; } # Keine weitere Initialisierung
  6819.               )
  6820.     }
  6821.  
  6822. # UP, beschafft Array
  6823. # allocate_array(flags,rank,type)
  6824. # > uintB flags: Flags
  6825. # > uintC rank: Rang
  6826. # > tint type: Typinfo
  6827. # < ergebnis: LISP-Objekt Array
  6828. # kann GC auslösen
  6829.   global object allocate_array (uintB flags, uintC rank, tint type);
  6830.   global object allocate_array(flags,rank,type)
  6831.     var reg3 uintB flags;
  6832.     var reg5 uintC rank;
  6833.     var reg6 tint type;
  6834.     { var reg2 uintL need = rank;
  6835.       if (flags & bit(arrayflags_fillp_bit)) { need += 1; }
  6836.       if (flags & bit(arrayflags_dispoffset_bit)) { need += 1; }
  6837.       need = size_array(need);
  6838.       allocate(type,TRUE,need,Array,ptr,
  6839.                { ptr->flags = flags; ptr->rank = rank; # Flags und Rang eintragen
  6840.                  ptr->data = NIL; # Datenvektor mit NIL initialisieren
  6841.                }
  6842.               )
  6843.     }
  6844.  
  6845. # UP, beschafft Simple-Record
  6846. # allocate_srecord_(flags_rectype,reclen,type)
  6847. # > uintW flags_rectype: Flags, nähere Typinfo
  6848. # > uintC reclen: Länge
  6849. # > tint type: Typinfo
  6850. # < ergebnis: LISP-Objekt Record (Elemente werden mit NIL initialisiert)
  6851. # kann GC auslösen
  6852.   global object allocate_srecord_ (uintW flags_rectype, uintC reclen, tint type);
  6853.   global object allocate_srecord_(flags_rectype,reclen,type)
  6854.     var reg3 uintW flags_rectype;
  6855.     var reg2 uintC reclen;
  6856.     var reg5 tint type;
  6857.     { ASSERT(!((flags_rectype & bit(BIG_ENDIAN_P ? intBsize-1 : 2*intBsize-1)) == 0)); # rectype < 0
  6858.      {var reg2 uintL need = size_srecord(reclen);
  6859.       allocate(type,TRUE,need,Srecord,ptr,
  6860.                { *(uintW*)pointerplus(ptr,offsetof(record_,recflags)) = flags_rectype; # Flags, Typ eintragen
  6861.                  ptr->reclength = reclen; # Länge eintragen
  6862.                 {var reg1 object* p = &ptr->recdata[0];
  6863.                  dotimespC(reclen,reclen, { *p++ = NIL; } ); # Elemente mit NIL vollschreiben
  6864.                }}
  6865.               )
  6866.     }}
  6867.  
  6868. # UP, beschafft Extended-Record
  6869. # allocate_xrecord_(flags_rectype,reclen,recxlen,type)
  6870. # > uintW flags_rectype: Flags, nähere Typinfo
  6871. # > uintC reclen: Länge
  6872. # > uintC recxlen: Extra-Länge
  6873. # > tint type: Typinfo
  6874. # < ergebnis: LISP-Objekt Record (Elemente werden mit NIL bzw. 0 initialisiert)
  6875. # kann GC auslösen
  6876.   global object allocate_xrecord_ (uintW flags_rectype, uintC reclen, uintC recxlen, tint type);
  6877.   global object allocate_xrecord_(flags_rectype,reclen,recxlen,type)
  6878.     var reg4 uintW flags_rectype;
  6879.     var reg2 uintC reclen;
  6880.     var reg3 uintC recxlen;
  6881.     var reg6 tint type;
  6882.     { ASSERT((flags_rectype & bit(BIG_ENDIAN_P ? intBsize-1 : 2*intBsize-1)) == 0); # rectype >= 0
  6883.      {var reg2 uintL need = size_xrecord(reclen,recxlen);
  6884.       allocate(type,TRUE,need,Xrecord,ptr,
  6885.                { *(uintW*)pointerplus(ptr,offsetof(record_,recflags)) = flags_rectype; # Flags, Typ eintragen
  6886.                  ptr->reclength = reclen; ptr->recxlength = recxlen; # Längen eintragen
  6887.                 {var reg1 object* p = &ptr->recdata[0];
  6888.                  dotimesC(reclen,reclen, { *p++ = NIL; } ); # Elemente mit NIL vollschreiben
  6889.                  {var reg1 uintB* q = (uintB*)p;
  6890.                   dotimesC(recxlen,recxlen, { *q++ = 0; } ); # Extra-Elemente mit 0 vollschreiben
  6891.                }}}
  6892.               )
  6893.     }}
  6894.  
  6895. #ifndef case_stream
  6896.  
  6897. # UP, beschafft Stream
  6898. # allocate_stream(strmflags,strmtype,reclen)
  6899. # > uintB strmflags: Flags
  6900. # > uintB strmtype: nähere Typinfo
  6901. # > uintC reclen: Länge
  6902. # < ergebnis: LISP-Objekt Stream (Elemente werden mit NIL initialisiert)
  6903. # kann GC auslösen
  6904.   global object allocate_stream (uintB strmflags, uintB strmtype, uintC reclen);
  6905.   global object allocate_stream(strmflags,strmtype,reclen)
  6906.     var reg3 uintB strmflags;
  6907.     var reg4 uintB strmtype;
  6908.     var reg2 uintC reclen;
  6909.     { var reg1 object obj = allocate_xrecord(0,Rectype_Stream,reclen,0,orecord_type);
  6910.       TheRecord(obj)->recdata[0] = Fixnum_0; # Fixnum als Platz für strmflags und strmtype
  6911.       TheStream(obj)->strmflags = strmflags; TheStream(obj)->strmtype = strmtype;
  6912.       return obj;
  6913.     }
  6914.  
  6915. #endif
  6916.  
  6917. #ifdef FOREIGN
  6918.  
  6919. # UP, beschafft Foreign-Pointer-Verpackung
  6920. # allocate_fpointer(foreign)
  6921. # > foreign: vom Typ FOREIGN
  6922. # < ergebnis: LISP-Objekt, das foreign enthält
  6923. # kann GC auslösen
  6924.   global object allocate_fpointer (FOREIGN foreign);
  6925.   global object allocate_fpointer(foreign)
  6926.     var reg2 FOREIGN foreign;
  6927.     { var reg1 object result = allocate_xrecord(0,Rectype_Fpointer,fpointer_length,fpointer_xlength,orecord_type);
  6928.       TheFpointer(result)->fp_pointer = foreign;
  6929.       return result;
  6930.     }
  6931.  
  6932. #endif
  6933.  
  6934. #ifdef FOREIGN_HANDLE
  6935.  
  6936. # UP, beschafft Handle-Verpackung
  6937. # allocate_handle(handle)
  6938. # < ergebnis: LISP-Objekt, das handle enthält
  6939.   global object allocate_handle (Handle handle);
  6940.   global object allocate_handle(handle)
  6941.     var reg2 Handle handle;
  6942.     { var reg1 object result = allocate_bit_vector(sizeof(Handle)*8);
  6943.       TheHandle(result) = handle;
  6944.       return result;
  6945.     }
  6946.  
  6947. #endif
  6948.  
  6949. # UP, beschafft Bignum
  6950. # allocate_bignum(len,sign)
  6951. # > uintC len: Länge der Zahl (in Digits)
  6952. # > sintB sign: Flag für Vorzeichen (0 = +, -1 = -)
  6953. # < ergebnis: neues Bignum (LISP-Objekt)
  6954. # kann GC auslösen
  6955.   global object allocate_bignum (uintC len, sintB sign);
  6956.   global object allocate_bignum(len,sign)
  6957.     var reg3 uintC len;
  6958.     var reg5 sintB sign;
  6959.     { var reg4 uintL need = size_bignum(len); # benötigter Speicherplatz in Bytes
  6960.       allocate(bignum_type | (sign & bit(sign_bit_t)),TRUE,need,Bignum,ptr,
  6961.                { ptr->length = len; } # Keine weitere Initialisierung
  6962.               )
  6963.     }
  6964.  
  6965. # UP, beschafft Single-Float
  6966. # allocate_ffloat(value)
  6967. # > ffloat value: Zahlwert (Bit 31 = Vorzeichen)
  6968. # < ergebnis: neues Single-Float (LISP-Objekt)
  6969. # kann GC auslösen
  6970.   global object allocate_ffloat (ffloat value);
  6971.   #ifndef WIDE
  6972.   global object allocate_ffloat(value)
  6973.     var reg3 ffloat value;
  6974.     { allocate(ffloat_type | ((sint32)value<0 ? bit(sign_bit_t) : 0) # Vorzeichenbit aus value
  6975.                ,TRUE,size_ffloat(),Ffloat,ptr,
  6976.                { ptr->float_value = value; }
  6977.               )
  6978.     }
  6979.   #else
  6980.   global object allocate_ffloat(value)
  6981.     var reg3 ffloat value;
  6982.     { return
  6983.         type_data_object(ffloat_type | ((sint32)value<0 ? bit(sign_bit_t) : 0), # Vorzeichenbit aus value
  6984.                          value
  6985.                         );
  6986.     }
  6987.   #endif
  6988.  
  6989. # UP, beschafft Double-Float
  6990. #ifdef intQsize
  6991. # allocate_dfloat(value)
  6992. # > dfloat value: Zahlwert (Bit 63 = Vorzeichen)
  6993. # < ergebnis: neues Double-Float (LISP-Objekt)
  6994. # kann GC auslösen
  6995.   global object allocate_dfloat (dfloat value);
  6996.   global object allocate_dfloat(value)
  6997.     var reg3 dfloat value;
  6998.     { allocate(dfloat_type | ((sint64)value<0 ? bit(sign_bit_t) : 0) # Vorzeichenbit aus value
  6999.                ,TRUE,size_dfloat(),Dfloat,ptr,
  7000.                { ptr->float_value = value; }
  7001.               )
  7002.     }
  7003. #else
  7004. # allocate_dfloat(semhi,mlo)
  7005. # > semhi,mlo: Zahlwert (Bit 31 von semhi = Vorzeichen)
  7006. # < ergebnis: neues Double-Float (LISP-Objekt)
  7007. # kann GC auslösen
  7008.   global object allocate_dfloat (uint32 semhi, uint32 mlo);
  7009.   global object allocate_dfloat(semhi,mlo)
  7010.     var reg3 uint32 semhi;
  7011.     var reg5 uint32 mlo;
  7012.     { allocate(dfloat_type | ((sint32)semhi<0 ? bit(sign_bit_t) : 0) # Vorzeichenbit aus value
  7013.                ,TRUE,size_dfloat(),Dfloat,ptr,
  7014.                { ptr->float_value.semhi = semhi; ptr->float_value.mlo = mlo; }
  7015.               )
  7016.     }
  7017. #endif
  7018.  
  7019. # UP, beschafft Long-Float
  7020. # allocate_lfloat(len,expo,sign)
  7021. # > uintC len: Länge der Mantisse (in Digits)
  7022. # > uintL expo: Exponent
  7023. # > signean sign: Vorzeichen (0 = +, -1 = -)
  7024. # < ergebnis: neues Long-Float, noch ohne Mantisse
  7025. # Ein LISP-Objekt liegt erst dann vor, wenn die Mantisse eingetragen ist!
  7026. # kann GC auslösen
  7027.   global object allocate_lfloat (uintC len, uintL expo, signean sign);
  7028.   global object allocate_lfloat(len,expo,sign)
  7029.     var reg3 uintC len;
  7030.     var reg6 uintL expo;
  7031.     var reg5 signean sign;
  7032.     { var reg4 uintL need = size_lfloat(len); # benötigter Speicherplatz in Bytes
  7033.       allocate(lfloat_type | ((tint)sign & bit(sign_bit_t))
  7034.                ,TRUE,need,Lfloat,ptr,
  7035.                { ptr->len = len; ptr->expo = expo; } # Keine weitere Initialisierung
  7036.               )
  7037.     }
  7038.  
  7039. # UP, erzeugt Bruch
  7040. # make_ratio(num,den)
  7041. # > object num: Zähler (muß Integer /= 0 sein, relativ prim zu den)
  7042. # > object den: Nenner (muß Integer > 1 sein)
  7043. # < ergebnis: Bruch
  7044. # kann GC auslösen
  7045.   global object make_ratio (object num, object den);
  7046.   global object make_ratio(num,den)
  7047.     var reg4 object num;
  7048.     var reg5 object den;
  7049.     { pushSTACK(den); pushSTACK(num); # Argumente sichern
  7050.      {var reg3 tint type = # Vorzeichen von num übernehmen
  7051.         #ifdef fast_mtypecode
  7052.         ratio_type | (mtypecode(STACK_0) & bit(sign_bit_t))
  7053.         #else
  7054.         ratio_type | (typecode(num) & bit(sign_bit_t))
  7055.         #endif
  7056.         ;
  7057.       allocate(type,FALSE,sizeof(ratio_),Ratio,ptr,
  7058.                { ptr->rt_num = popSTACK(); # Zähler eintragen
  7059.                  ptr->rt_den = popSTACK(); # Nenner eintragen
  7060.                }
  7061.               )
  7062.     }}
  7063.  
  7064. # UP, erzeugt komplexe Zahl
  7065. # make_complex(real,imag)
  7066. # > real: Realteil (muß reelle Zahl sein)
  7067. # > imag: Imaginärteil (muß reelle Zahl /= Fixnum 0 sein)
  7068. # < ergebnis: komplexe Zahl
  7069. # kann GC auslösen
  7070.   global object make_complex (object real, object imag);
  7071.   global object make_complex(real,imag)
  7072.     var reg4 object real;
  7073.     var reg5 object imag;
  7074.     { pushSTACK(imag); pushSTACK(real);
  7075.       allocate(complex_type,FALSE,sizeof(complex_),Complex,ptr,
  7076.                { ptr->c_real = popSTACK(); # Realteil eintragen
  7077.                  ptr->c_imag = popSTACK(); # Imaginärteil eintragen
  7078.                }
  7079.               )
  7080.     }
  7081.  
  7082. # ------------------------------------------------------------------------------
  7083. #                   Zirkularitätenfeststellung
  7084.  
  7085. # UP: Liefert eine Tabelle aller Zirkularitäten innerhalb eines Objekts.
  7086. # (Eine Zirkularität ist ein in diesem Objekt enthaltenes Teil-Objekt,
  7087. # auf den es mehr als einen Zugriffsweg gibt.)
  7088. # get_circularities(obj,pr_array,pr_closure)
  7089. # > object obj: Objekt
  7090. # > boolean pr_array: Flag, ob Arrayelemente rekursiv als Teilobjekte gelten
  7091. # > boolean pr_closure: Flag, ob Closurekomponenten rekursiv als Teilobjekte gelten
  7092. # < ergebnis: T falls Stacküberlauf eintrat,
  7093. #             NIL falls keine Zirkularitäten vorhanden,
  7094. #             #(0 ...) ein (n+1)-elementiger Vektor, der die Zahl 0 und die n
  7095. #                      Zirkularitäten als Elemente enthält, n>0.
  7096. # kann GC auslösen
  7097. # Methode:
  7098. # Markiere rekursiv das Objekt, lege dabei die Zirkularitäten auf den STACK,
  7099. # demarkiere rekursiv das Objekt,
  7100. # alloziere Vektor für die Zirkularitäten (kann GC auslösen!),
  7101. # fülle die Zirkularitäten vom STACK in den Vektor um.
  7102.   global object get_circularities (object obj, boolean pr_array, boolean pr_closure);
  7103.   typedef struct { boolean pr_array;
  7104.                    boolean pr_closure;
  7105.                    uintL counter;
  7106.                    jmp_buf abbruch_context;
  7107.                    object* abbruch_STACK;
  7108.                  }
  7109.           get_circ_global;
  7110.   # Darauf muß man aus den zwei lokalen Routinen heraus zugreifen.
  7111.   local void get_circ_mark (object obj, get_circ_global* env);
  7112.   local void get_circ_unmark (object obj, get_circ_global* env);
  7113.   global object get_circularities(obj,pr_array,pr_closure)
  7114.     var object obj;
  7115.     var boolean pr_array;
  7116.     var boolean pr_closure;
  7117.     { var get_circ_global my_global; # Zähler und Kontext (incl. STACK-Wert)
  7118.                                      # für den Fall eines Abbruchs
  7119.       set_break_sem_1(); # Break unmöglich machen
  7120.       if (!setjmp(my_global.abbruch_context)) # Kontext abspeichern
  7121.         { my_global.pr_array = pr_array;
  7122.           my_global.pr_closure = pr_closure;
  7123.           my_global.counter = 0; # Zähler := 0
  7124.           my_global.abbruch_STACK = STACK;
  7125.           # Die Kontext-Konserve my_global ist jetzt fertig.
  7126.           get_circ_mark(obj,&my_global); # Objekt markieren, mehrfache
  7127.                                          # Strukturen auf dem STACK ablegen
  7128.                                          # in my_global.counter zählen
  7129.           get_circ_unmark(obj,&my_global); # Markierungen wieder löschen
  7130.           clr_break_sem_1(); # Break wieder möglich
  7131.           { var reg2 uintL n = my_global.counter; # Anzahl der Objekte auf dem STACK
  7132.             if (n==0)
  7133.               return(NIL); # keine da -> NIL zurück und fertig
  7134.               else
  7135.               { var reg3 object vector = allocate_vector(n+1); # Vektor mit n+1 Elementen
  7136.                 # füllen:
  7137.                 var reg1 object* ptr = &TheSvector(vector)->data[0];
  7138.                 *ptr++ = Fixnum_0; # erstes Element = Fixnum 0
  7139.                 # restliche Elemente eintragen (mindestens eins):
  7140.                 dotimespL(n,n, { *ptr++ = popSTACK(); } );
  7141.                 return(vector); # Vektor als Ergebnis
  7142.         } }   }
  7143.         else
  7144.         # nach Abbruch wegen SP- oder STACK-Überlauf
  7145.         { setSTACK(STACK = my_global.abbruch_STACK); # STACK wieder zurücksetzen
  7146.           # Der Kontext ist jetzt wiederhergestellt.
  7147.           get_circ_unmark(obj,&my_global); # Markierungen wieder löschen
  7148.           clr_break_sem_1(); # Break wieder möglich
  7149.           return(T); # T als Ergebnis
  7150.         }
  7151.     }
  7152. # UP: markiert das Objekt obj, legt auftretende Zirkularitäten auf den STACK
  7153. # und zählt sie in env->counter mit.
  7154.   local void get_circ_mark(obj,env)
  7155.     var reg3 object obj;
  7156.     var reg4 get_circ_global* env;
  7157.     { entry:
  7158.       switch (typecode(obj)) # je nach Typ
  7159.         { case cons_type:
  7160.             if (marked(TheCons(obj))) goto m_schon_da; # markiert?
  7161.             { var reg2 object obj_cdr = Cdr(obj); # Komponenten (ohne Markierungsbit)
  7162.               var reg1 object obj_car = Car(obj);
  7163.               mark(TheCons(obj)); # markieren
  7164.               if (SP_overflow()) # SP-Tiefe überprüfen
  7165.                 longjmp(env->abbruch_context,TRUE); # Abbruch
  7166.               get_circ_mark(obj_car,env); # CAR markieren (rekursiv)
  7167.               obj = obj_cdr; goto entry; # CDR markieren (tail-end-rekursiv)
  7168.             }
  7169.           #ifdef IMMUTABLE_CONS
  7170.           case imm_cons_type:
  7171.             if (marked(TheCons(obj))) goto m_schon_da; # markiert?
  7172.             { var reg2 object obj_cdr = Cdr(obj); # Komponenten (ohne Markierungsbit)
  7173.               var reg1 object obj_car = Car(obj);
  7174.               mark(TheImmCons(obj)); # markieren
  7175.               if (SP_overflow()) # SP-Tiefe überprüfen
  7176.                 longjmp(env->abbruch_context,TRUE); # Abbruch
  7177.               get_circ_mark(obj_car,env); # CAR markieren (rekursiv)
  7178.               obj = obj_cdr; goto entry; # CDR markieren (tail-end-rekursiv)
  7179.             }
  7180.           #endif
  7181.           case_symbol:
  7182.             if (marked(TheSymbol(obj))) # markiert?
  7183.               if (eq(Symbol_package(obj),NIL)) # uninterniertes Symbol?
  7184.                 goto m_schon_da; # ja -> war schon da, merken
  7185.                 else
  7186.                 goto m_end; # nein -> war zwar schon da, aber unberücksichtigt lassen
  7187.             # bisher unmarkiertes Symbol
  7188.             mark(TheSymbol(obj)); # markieren
  7189.             goto m_end;
  7190.           case sbvector_type: case bvector_type: # Bit-Vector
  7191.           case sstring_type: case string_type: # String
  7192.           case_bignum: # Bignum
  7193.           #ifndef WIDE
  7194.           case_ffloat: # Single-Float
  7195.           #endif
  7196.           case_dfloat: # Double-Float
  7197.           case_lfloat: # Long-Float
  7198.           case_ratio: # Ratio
  7199.           case_complex: # Complex
  7200.             # Objekt ohne Komponenten, die ausgegeben werden:
  7201.             if (marked(ThePointer(obj))) goto m_schon_da; # markiert?
  7202.             # bisher unmarkiert
  7203.             mark(ThePointer(obj)); # markieren
  7204.             goto m_end;
  7205.           #ifdef IMMUTABLE_ARRAY
  7206.           case imm_sbvector_type: case imm_bvector_type: # immutabler Bit-Vector
  7207.           case imm_sstring_type: case imm_string_type: # immutabler String
  7208.             # immutables Objekt ohne Komponenten, die ausgegeben werden:
  7209.             if (marked(ThePointer(obj))) goto m_schon_da; # markiert?
  7210.             # bisher unmarkiert
  7211.             mark(TheImmArray(obj)); # markieren
  7212.             goto m_end;
  7213.           #endif
  7214.           case svector_type: # Simple-Vector
  7215.             if (marked(TheSvector(obj))) goto m_schon_da; # markiert?
  7216.             # bisher unmarkiert
  7217.             mark(TheSvector(obj)); # markieren
  7218.             m_svector:
  7219.             if (env->pr_array) # Komponenten weiterzuverfolgen?
  7220.               { var reg2 uintL count = TheSvector(obj)->length;
  7221.                 if (!(count==0))
  7222.                   # markiere count>0 Komponenten
  7223.                   { var reg1 object* ptr = &TheSvector(obj)->data[0];
  7224.                     if (SP_overflow()) # SP-Tiefe überprüfen
  7225.                       longjmp(env->abbruch_context,TRUE); # Abbruch
  7226.                     dotimespL(count,count, { get_circ_mark(*ptr++,env); } ); # markiere Komponenten (rekursiv)
  7227.               }   }
  7228.             goto m_end;
  7229.           case array_type: case vector_type:
  7230.             # Nicht-simpler Array mit Komponenten, die Objekte sind:
  7231.             if (marked(TheArray(obj))) goto m_schon_da; # markiert?
  7232.             # bisher unmarkiert
  7233.             mark(TheArray(obj)); # markieren
  7234.             m_array:
  7235.             if (env->pr_array) # Komponenten weiterzuverfolgen?
  7236.               { obj=TheArray(obj)->data; goto entry; } # Datenvektor (tail-end-rekursiv) markieren
  7237.               else
  7238.               goto m_end;
  7239.           #ifdef IMMUTABLE_ARRAY
  7240.           case imm_svector_type: # immutabler Simple-Vector
  7241.             if (marked(TheSvector(obj))) goto m_schon_da; # markiert?
  7242.             # bisher unmarkiert
  7243.             mark(TheImmSvector(obj)); # markieren
  7244.             goto m_svector;
  7245.           case imm_array_type: case imm_vector_type:
  7246.             # immutabler nicht-simpler Array mit Komponenten, die Objekte sind:
  7247.             if (marked(TheArray(obj))) goto m_schon_da; # markiert?
  7248.             # bisher unmarkiert
  7249.             mark(TheImmArray(obj)); # markieren
  7250.             goto m_array;
  7251.           #endif
  7252.           case_closure: # Closure
  7253.             if (marked(TheClosure(obj))) goto m_schon_da; # markiert?
  7254.             # bisher unmarkiert
  7255.             mark(TheClosure(obj)); # markieren
  7256.             if (env->pr_closure) # Komponenten weiterzuverfolgen?
  7257.               goto m_record_components; # alle Komponenten werden ausgeben (s. unten)
  7258.               else # nur den Namen (tail-end-rekursiv) markieren
  7259.               { obj=TheClosure(obj)->clos_name; goto entry; }
  7260.           case_structure: # Structure
  7261.             if (marked(TheStructure(obj))) goto m_schon_da; # markiert?
  7262.             # bisher unmarkiert
  7263.             mark(TheStructure(obj)); # markieren
  7264.             goto m_record_components;
  7265.           case_stream: # Stream
  7266.             if (marked(TheStream(obj))) goto m_schon_da; # markiert?
  7267.             # bisher unmarkiert
  7268.             mark(TheStream(obj));
  7269.             switch (TheStream(obj)->strmtype)
  7270.               { case strmtype_broad:
  7271.                 case strmtype_concat:
  7272.                   goto m_record_components;
  7273.                 default:
  7274.                   goto m_end;
  7275.               }
  7276.           case_instance: # CLOS-Instanz
  7277.             if (marked(TheInstance(obj))) goto m_schon_da; # markiert?
  7278.             # bisher unmarkiert
  7279.             mark(TheInstance(obj)); # markieren
  7280.             goto m_record_components;
  7281.           case_orecord: # sonstigen Record markieren:
  7282.             if (marked(TheRecord(obj))) goto m_schon_da; # markiert?
  7283.             # bisher unmarkiert
  7284.             mark(TheRecord(obj)); # markieren
  7285.             switch (TheRecord(obj)->rectype)
  7286.               { case Rectype_Hashtable:
  7287.                   # Hash-Table: je nach Array-Ausgabe-Flag
  7288.                   if (env->pr_array) break; else goto m_end;
  7289.                 case Rectype_Package:
  7290.                   # Packages werden nicht komponentenweise ausgegeben
  7291.                   goto m_end;
  7292.                 case Rectype_Readtable:
  7293.                   # Readtables werden nicht komponentenweise ausgegeben
  7294.                   goto m_end;
  7295.                 #ifndef case_structure
  7296.                 case Rectype_Structure: goto case_structure;
  7297.                 #endif
  7298.                 #ifndef case_stream
  7299.                 case Rectype_Stream: goto case_stream;
  7300.                 #endif
  7301.                 default: break;
  7302.               }
  7303.             # Pathnames, Random-States, Bytes, Fsubrs, Loadtimeevals,
  7304.             # Symbol-Macros und evtl. Hash-Tables werden evtl.
  7305.             # komponentenweise ausgegeben.
  7306.             m_record_components: # Komponenten eines Records markieren:
  7307.               { var reg2 uintC count = Record_length(obj);
  7308.                 if (!(count==0))
  7309.                   # markiere count>0 Komponenten
  7310.                   { var reg1 object* ptr = &TheRecord(obj)->recdata[0];
  7311.                     if (SP_overflow()) # SP-Tiefe überprüfen
  7312.                       longjmp(env->abbruch_context,TRUE); # Abbruch
  7313.                     dotimespC(count,count, { get_circ_mark(*ptr++,env); } ); # markiere Komponenten (rekursiv)
  7314.               }   }
  7315.             goto m_end;
  7316.           m_schon_da:
  7317.             # Objekt wurde markiert, war aber schon markiert.
  7318.             # Es ist eine Zirkularität.
  7319.             if (STACK_overflow()) # STACK-Tiefe überprüfen
  7320.               longjmp(env->abbruch_context,TRUE); # Abbruch
  7321.             # Objekt mit gelöschtem garcol_bit im STACK ablegen:
  7322.             pushSTACK(without_mark_bit(obj));
  7323.             env->counter++; # und mitzählen
  7324.             goto m_end;
  7325.           case_machine: # Maschinenpointer
  7326.           case_char: # Character
  7327.           case_subr: # Subr
  7328.           case_system: # Frame-pointer, Read-label, system
  7329.           case_fixnum: # Fixnum
  7330.           case_sfloat: # Short-Float
  7331.           #ifdef WIDE
  7332.           case_ffloat: # Single-Float
  7333.           #endif
  7334.           default:
  7335.             # Objekt kann nicht markiert werden -> fertig
  7336.             goto m_end;
  7337.           m_end: ; # fertig
  7338.     }   }
  7339. # UP: Demarkiert Objekt obj.
  7340.   local void get_circ_unmark(obj,env)
  7341.     var reg2 object obj;
  7342.     var reg3 get_circ_global* env;
  7343.     { entry:
  7344.       switch (typecode(obj) & ~bit(garcol_bit_t)) # je nach Typinfo ohne garcol_bit
  7345.         { case cons_type:
  7346.             if (!marked(TheCons(obj))) goto u_end; # schon demarkiert?
  7347.             unmark(TheCons(obj)); # demarkieren
  7348.             get_circ_unmark(Car(obj),env); # CAR demarkieren (rekursiv)
  7349.             obj=Cdr(obj); goto entry; # CDR demarkieren (tail-end-rekursiv)
  7350.           #ifdef IMMUTABLE_CONS
  7351.           case imm_cons_type:
  7352.             if (!marked(TheCons(obj))) goto u_end; # schon demarkiert?
  7353.             unmark(TheImmCons(obj)); # demarkieren
  7354.             get_circ_unmark(Car(obj),env); # CAR demarkieren (rekursiv)
  7355.             obj=Cdr(obj); goto entry; # CDR demarkieren (tail-end-rekursiv)
  7356.           #endif
  7357.           case_symbol:
  7358.             # Symbol demarkieren. Wertzelle etc. für PRINT unwesentlich.
  7359.           case sbvector_type: case bvector_type: # Bit-Vector
  7360.           case sstring_type: case string_type: # String
  7361.           case_bignum: # Bignum
  7362.           #ifndef WIDE
  7363.           case_ffloat: # Single-Float
  7364.           #endif
  7365.           case_dfloat: # Double-Float
  7366.           case_lfloat: # Long-Float
  7367.           case_ratio: # Ratio
  7368.           case_complex: # Complex
  7369.             # Objekt demarkieren, das keine markierten Komponenten hat:
  7370.             unmark(ThePointer(obj)); # demarkieren
  7371.             goto u_end;
  7372.           #ifdef IMMUTABLE_ARRAY
  7373.           case imm_sbvector_type: case imm_bvector_type: # immutabler Bit-Vector
  7374.           case imm_sstring_type: case imm_string_type: # immutabler String
  7375.             # immutables Objekt demarkieren, das keine markierten Komponenten hat:
  7376.             unmark(TheImmArray(obj)); # demarkieren
  7377.             goto u_end;
  7378.           #endif
  7379.           case svector_type:
  7380.             # Simple-Vector demarkieren, seine Komponenten ebenfalls:
  7381.             if (!marked(TheSvector(obj))) goto u_end; # schon demarkiert?
  7382.             unmark(TheSvector(obj)); # demarkieren
  7383.             u_svector:
  7384.             if (env->pr_array) # wurden die Komponenten weiterverfolgt?
  7385.               { var reg2 uintL count = TheSvector(obj)->length;
  7386.                 if (!(count==0))
  7387.                   # demarkiere count>0 Komponenten
  7388.                   { var reg1 object* ptr = &TheSvector(obj)->data[0];
  7389.                     dotimespL(count,count, { get_circ_unmark(*ptr++,env); } ); # demarkiere Komponenten (rekursiv)
  7390.               }   }
  7391.             goto u_end;
  7392.           case array_type: case vector_type:
  7393.             # Nicht-simpler Array mit Komponenten, die Objekte sind:
  7394.             if (!marked(TheArray(obj))) goto u_end; # schon demarkiert?
  7395.             unmark(TheArray(obj)); # demarkieren
  7396.             u_array:
  7397.             if (env->pr_array) # wurden die Komponenten weiterverfolgt?
  7398.               { obj=TheArray(obj)->data; goto entry; } # Datenvektor (tail-end-rekursiv) demarkieren
  7399.               else
  7400.               goto u_end;
  7401.           #ifdef IMMUTABLE_ARRAY
  7402.           case imm_svector_type:
  7403.             # immutablen Simple-Vector demarkieren, seine Komponenten ebenfalls:
  7404.             if (!marked(TheSvector(obj))) goto u_end; # schon demarkiert?
  7405.             unmark(TheImmSvector(obj)); # demarkieren
  7406.             goto u_svector;
  7407.           case imm_array_type: case imm_vector_type:
  7408.             # immutabler nicht-simpler Array mit Komponenten, die Objekte sind:
  7409.             if (!marked(TheArray(obj))) goto u_end; # schon demarkiert?
  7410.             unmark(TheImmArray(obj)); # demarkieren
  7411.             goto u_array;
  7412.           #endif
  7413.           case_closure: # Closure demarkieren
  7414.             if (!marked(TheClosure(obj))) goto u_end; # schon demarkiert?
  7415.             unmark(TheClosure(obj)); # demarkieren
  7416.             if (env->pr_closure) # wurden Komponenten weiterverfolgt?
  7417.               goto u_record_components; # alle Komponenten werden ausgeben (s. unten)
  7418.               else # nur den Namen (tail-end-rekursiv) demarkieren
  7419.               { obj=TheClosure(obj)->clos_name; goto entry; }
  7420.           case_structure: # Structure demarkieren:
  7421.             if (!marked(TheStructure(obj))) goto u_end; # schon demarkiert?
  7422.             unmark(TheStructure(obj)); # demarkieren
  7423.             goto u_record_components;
  7424.           case_stream: # Stream demarkieren:
  7425.             if (!marked(TheStream(obj))) goto u_end; # schon demarkiert?
  7426.             unmark(TheStream(obj)); # demarkieren
  7427.             switch (TheStream(obj)->strmtype)
  7428.               { case strmtype_broad:
  7429.                 case strmtype_concat:
  7430.                   goto u_record_components;
  7431.                 default:
  7432.                   goto u_end;
  7433.               }
  7434.           case_instance: # CLOS-Instanz demarkieren:
  7435.             if (!marked(TheInstance(obj))) goto u_end; # schon demarkiert?
  7436.             unmark(TheInstance(obj)); # demarkieren
  7437.             goto u_record_components;
  7438.           case_orecord: # sonstigen Record demarkieren:
  7439.             if (!marked(TheRecord(obj))) goto u_end; # schon demarkiert?
  7440.             unmark(TheRecord(obj)); # demarkieren
  7441.             switch (TheRecord(obj)->rectype)
  7442.               { case Rectype_Hashtable:
  7443.                   # Hash-Table: je nach Array-Ausgabe-Flag
  7444.                   if (env->pr_array) break; else goto u_end;
  7445.                 case Rectype_Package:
  7446.                   # Packages werden nicht komponentenweise ausgegeben
  7447.                   goto u_end;
  7448.                 case Rectype_Readtable:
  7449.                   # Readtables werden nicht komponentenweise ausgegeben
  7450.                   goto u_end;
  7451.                 #ifndef case_structure
  7452.                 case Rectype_Structure: goto case_structure;
  7453.                 #endif
  7454.                 #ifndef case_stream
  7455.                 case Rectype_Stream: goto case_stream;
  7456.                 #endif
  7457.                 default: break;
  7458.               }
  7459.             # Pathnames, Random-States, Bytes, Fsubrs, Loadtimeevals,
  7460.             # Symbol-Macros und evtl. Hash-Tables werden evtl.
  7461.             # komponentenweise ausgegeben.
  7462.             u_record_components: # Komponenten eines Records demarkieren:
  7463.               { var reg2 uintC count = Record_length(obj);
  7464.                 if (!(count==0))
  7465.                   # demarkiere count>0 Komponenten
  7466.                   { var reg1 object* ptr = &TheRecord(obj)->recdata[0];
  7467.                     dotimespC(count,count, { get_circ_unmark(*ptr++,env); } ); # demarkiere Komponenten (rekursiv)
  7468.               }   }
  7469.             goto u_end;
  7470.           case_machine: # Maschinenpointer
  7471.           case_char: # Character
  7472.           case_subr: # Subr
  7473.           case_system: # Frame-pointer, Read-label, system
  7474.           case_fixnum: # Fixnum
  7475.           case_sfloat: # Short-Float
  7476.           #ifdef WIDE
  7477.           case_ffloat: # Single-Float
  7478.           #endif
  7479.           default:
  7480.             # Objekt demarkieren, das gar keine Markierung haben kann:
  7481.             goto u_end;
  7482.           u_end: ; # fertig
  7483.     }   }
  7484.  
  7485. # UP: Entflicht #n# - Referenzen im Objekt *ptr mit Hilfe der Aliste alist.
  7486. # > *ptr : Objekt
  7487. # > alist : Aliste (Read-Label --> zu substituierendes Objekt)
  7488. # < *ptr : Objekt mit entflochtenen Referenzen
  7489. # < ergebnis : fehlerhafte Referenz oder nullobj falls alles OK
  7490.   global object subst_circ (object* ptr, object alist);
  7491. #
  7492. # Zirkularitätenberücksichtigung ist nötig, damit die Substitution sich von
  7493. # zyklischen Strukturen, wie sie sich bei #. (insbesondere #.(FIND-CLASS 'FOO))
  7494. # ergeben können, nicht durcheinanderbringen läßt.
  7495.  
  7496. #if 0 # ohne Zirkularitätenberücksichtigung
  7497.  
  7498.   local void subst (object* ptr);
  7499.   local object subst_circ_alist;
  7500.   local jmp_buf subst_circ_jmpbuf;
  7501.   local object subst_circ_bad;
  7502.   global object subst_circ(ptr,alist)
  7503.     var reg1 object* ptr;
  7504.     var reg2 object alist;
  7505.     { subst_circ_alist = alist;
  7506.       if (!setjmp(subst_circ_jmpbuf))
  7507.         { subst(ptr); return nullobj; }
  7508.         else
  7509.         # Abbruch wegen fehlerhafter Referenz
  7510.         { return subst_circ_bad; }
  7511.     }
  7512.   local void subst(ptr)
  7513.     var reg2 object ptr;
  7514.     { check_SP();
  7515.       enter_subst:
  7516.      {var reg1 object obj = *ptr;
  7517.       # Fallunterscheidung nach Typ:
  7518.       # Objekte ohne Teilobjekte (Maschinenpointer, Bit-Vektoren,
  7519.       # Strings, Characters, SUBRs, Integers, Floats) enthalten
  7520.       # keine Referenzen. Ebenso Symbole und rationale Zahlen (bei ihnen
  7521.       # können die Teilobjekte nicht in #n= - Syntax eingegeben worden
  7522.       # sein) und komplexe Zahlen (für ihre Komponenten sind nur
  7523.       # Integers, Floats, rationale Zahlen zugelassen, also Objekte,
  7524.       # die ihrerseits keine Referenzen enthalten können).
  7525.       switch (mtypecode(*ptr))
  7526.         { case svector_type: # Simple-Vector
  7527.             # alle Elemente durchlaufen:
  7528.             { var reg4 uintL len = TheSvector(obj)->length;
  7529.               if (!(len==0))
  7530.                 { var reg3 object* objptr = &TheSvector(obj)->data[0];
  7531.                   dotimespL(len,len, { subst(&(*objptr++)); } );
  7532.             }   }
  7533.             break;
  7534.           case array_type:
  7535.           case vector_type:
  7536.             # nicht-simpler Array, kein String oder Bit-Vektor
  7537.             # Datenvektor durchlaufen: endrekursiv subst(Datenvektor)
  7538.             ptr = &TheArray(obj)->data; goto enter_subst;
  7539.           #ifdef IMMUTABLE_ARRAY
  7540.           case imm_svector_type: # immutabler Simple-Vector
  7541.             # alle Elemente durchlaufen:
  7542.             { var reg4 uintL len = TheSvector(obj)->length;
  7543.               if (!(len==0))
  7544.                 { var reg3 object* objptr = &TheImmSvector(obj)->data[0];
  7545.                   dotimespL(len,len, { subst(&(*objptr++)); } );
  7546.             }   }
  7547.             break;
  7548.           case imm_array_type:
  7549.           case imm_vector_type:
  7550.             # nicht-simpler Array, kein String oder Bit-Vektor
  7551.             # Datenvektor durchlaufen: endrekursiv subst(Datenvektor)
  7552.             ptr = &TheImmArray(obj)->data; goto enter_subst;
  7553.           #endif
  7554.           case_record: # Record
  7555.             # alle Elemente durchlaufen:
  7556.             { var reg4 uintC len = Record_length(obj);
  7557.               if (!(len==0))
  7558.                 { var reg3 object* objptr = &TheRecord(obj)->recdata[0];
  7559.                   dotimespC(len,len, { subst(&(*objptr++)); } );
  7560.             }   }
  7561.             break;
  7562.           case_system: # Frame-Pointer oder Read-Label oder System
  7563.             if (as_oint(obj) & wbit(0+oint_addr_shift))
  7564.               # Read-Label oder System
  7565.               if (as_oint(obj) & wbit(oint_data_len-1+oint_addr_shift))
  7566.                 {} # System
  7567.                 else
  7568.                 # Read-Label
  7569.                 { # Read-Label obj in der Aliste suchen:
  7570.                   var reg4 object alist = subst_circ_alist;
  7571.                   while (consp(alist))
  7572.                     { var reg3 object acons = Car(alist);
  7573.                       if (eq(Car(acons),obj))
  7574.                         # gefunden
  7575.                         { # *ptr = obj = (car acons) durch (cdr acons) ersetzen:
  7576.                           *ptr = Cdr(acons);
  7577.                           return;
  7578.                         }
  7579.                       alist = Cdr(alist);
  7580.                     }
  7581.                   # nicht gefunden -> Abbruch
  7582.                   subst_circ_bad = obj;
  7583.                   longjmp(subst_circ_jmpbuf,TRUE);
  7584.                 }
  7585.               else
  7586.               # Frame-Pointer
  7587.               {}
  7588.             break;
  7589.           case cons_type: # Cons
  7590.             # rekursiv: subst(&Car(obj))
  7591.             subst(&Car(obj));
  7592.             # endrekursiv: subst(&Cdr(obj))
  7593.             ptr = &Cdr(obj); goto enter_subst;
  7594.           #ifdef IMMUTABLE_CONS
  7595.           case imm_cons_type: # immutables Cons
  7596.             # rekursiv: subst(&Car(obj))
  7597.             subst(&TheImmCons(obj)->car);
  7598.             # endrekursiv: subst(&Cdr(obj))
  7599.             ptr = &TheImmCons(obj)->cdr; goto enter_subst;
  7600.           #endif
  7601.           case_machine: # Maschinenpointer
  7602.           case_bvector: # Bit-Vektor
  7603.           case_string: # String
  7604.           case_char: # Character
  7605.           case_subr: # SUBR
  7606.           case_number: # Zahl
  7607.           case_symbol: # Symbol
  7608.             # Objekt enthält keine Referenzen -> nichts zu tun
  7609.             break;
  7610.           default: NOTREACHED
  7611.     }}  }
  7612.  
  7613. #else # mit Zirkularitätenberücksichtigung
  7614.  
  7615. # Methode:
  7616. # Markiere rekursiv die Objekte, in denen die Substitution gerade durchgeführt
  7617. # wird/wurde. Danach demarkiere rekursiv das Objekt.
  7618.  
  7619.   local void subst_circ_mark (object* ptr);
  7620.   local void subst_circ_unmark (object* ptr);
  7621.   local object subst_circ_alist;
  7622.   local jmp_buf subst_circ_jmpbuf;
  7623.   local object subst_circ_bad;
  7624.   global object subst_circ(ptr,alist)
  7625.     var object* ptr;
  7626.     var reg1 object alist;
  7627.     { subst_circ_alist = alist;
  7628.       set_break_sem_1(); # Break unmöglich machen
  7629.       if (!setjmp(subst_circ_jmpbuf))
  7630.         { subst_circ_mark(ptr); # markieren und substituieren
  7631.           subst_circ_unmark(ptr); # Markierungen wieder löschen
  7632.           clr_break_sem_1(); # Break wieder möglich
  7633.           return nullobj;
  7634.         }
  7635.         else
  7636.         # Abbruch aus subst_circ_mark() heraus
  7637.         { subst_circ_unmark(ptr); # erst alles demarkieren
  7638.           clr_break_sem_1(); # Break wieder möglich
  7639.           if (!eq(subst_circ_bad,nullobj)) # wegen fehlerhafter Referenz?
  7640.             { return subst_circ_bad; }
  7641.             else # sonst war's SP-Überlauf
  7642.             { SP_ueber(); }
  7643.     }   }
  7644.   local void subst_circ_mark(ptr)
  7645.     var reg2 object* ptr;
  7646.     { if (SP_overflow()) # SP-Tiefe überprüfen
  7647.         { subst_circ_bad = nullobj; longjmp(subst_circ_jmpbuf,TRUE); } # Abbruch
  7648.       enter_subst:
  7649.      {var reg1 object obj = without_mark_bit(*ptr);
  7650.       # Fallunterscheidung nach Typ:
  7651.       # Objekte ohne Teilobjekte (Maschinenpointer, Bit-Vektoren,
  7652.       # Strings, Characters, SUBRs, Integers, Floats) enthalten
  7653.       # keine Referenzen. Ebenso Symbole und rationale Zahlen (bei ihnen
  7654.       # können die Teilobjekte nicht in #n= - Syntax eingegeben worden
  7655.       # sein) und komplexe Zahlen (für ihre Komponenten sind nur
  7656.       # Integers, Floats, rationale Zahlen zugelassen, also Objekte,
  7657.       # die ihrerseits keine Referenzen enthalten können).
  7658.       switch (typecode(obj))
  7659.         { case svector_type: # Simple-Vector
  7660.             if (marked(TheSvector(obj))) return; # Objekt schon markiert?
  7661.             mark(TheSvector(obj)); # markieren
  7662.             # alle Elemente durchlaufen:
  7663.             { var reg4 uintL len = TheSvector(obj)->length;
  7664.               if (!(len==0))
  7665.                 { var reg3 object* objptr = &TheSvector(obj)->data[0];
  7666.                   dotimespL(len,len, { subst_circ_mark(&(*objptr++)); } );
  7667.             }   }
  7668.             return;
  7669.           case array_type:
  7670.           case vector_type:
  7671.             # nicht-simpler Array, kein String oder Bit-Vektor
  7672.             if (marked(TheArray(obj))) return; # Objekt schon markiert?
  7673.             mark(TheArray(obj)); # markieren
  7674.             # Datenvektor durchlaufen: endrekursiv subst_circ_mark(Datenvektor)
  7675.             ptr = &TheArray(obj)->data; goto enter_subst;
  7676.           #ifdef IMMUTABLE_ARRAY
  7677.           case imm_svector_type: # immutabler Simple-Vector
  7678.             if (marked(TheSvector(obj))) return; # Objekt schon markiert?
  7679.             mark(TheImmSvector(obj)); # markieren
  7680.             # alle Elemente durchlaufen:
  7681.             { var reg4 uintL len = TheSvector(obj)->length;
  7682.               if (!(len==0))
  7683.                 { var reg3 object* objptr = &TheImmSvector(obj)->data[0];
  7684.                   dotimespL(len,len, { subst_circ_mark(&(*objptr++)); } );
  7685.             }   }
  7686.             return;
  7687.           case imm_array_type:
  7688.           case imm_vector_type:
  7689.             # nicht-simpler Array, kein String oder Bit-Vektor
  7690.             if (marked(TheArray(obj))) return; # Objekt schon markiert?
  7691.             mark(TheImmArray(obj)); # markieren
  7692.             # Datenvektor durchlaufen: endrekursiv subst_circ_mark(Datenvektor)
  7693.             ptr = &TheImmArray(obj)->data; goto enter_subst;
  7694.           #endif
  7695.           case_record: # Record
  7696.             if (marked(TheRecord(obj))) return; # Objekt schon markiert?
  7697.             mark(TheRecord(obj)); # markieren
  7698.             # Beim Ersetzen von Read-Labels in Hash-Tables verliert deren
  7699.             # Aufbau seinen Gültigkeit (denn die Hashfunktion der in ihr
  7700.             # gespeicherten Objekte verändert sich).
  7701.             if (TheRecord(obj)->rectype == Rectype_Hashtable) # eine Hash-Table ?
  7702.               { mark_ht_invalid(TheHashtable(obj)); } # ja -> für Reorganisation vormerken
  7703.             # alle Elemente durchlaufen:
  7704.             { var reg4 uintC len = Record_length(obj);
  7705.               if (!(len==0))
  7706.                 { var reg3 object* objptr = &TheRecord(obj)->recdata[0];
  7707.                   dotimespC(len,len, { subst_circ_mark(&(*objptr++)); } );
  7708.             }   }
  7709.             return;
  7710.           case_system: # Frame-Pointer oder Read-Label oder System
  7711.             if (as_oint(obj) & wbit(0+oint_addr_shift))
  7712.               # Read-Label oder System
  7713.               if (as_oint(obj) & wbit(oint_data_len-1+oint_addr_shift))
  7714.                 {} # System
  7715.                 else
  7716.                 # Read-Label
  7717.                 { # Read-Label obj in der Aliste suchen:
  7718.                   var reg4 object alist = subst_circ_alist;
  7719.                   while (consp(alist))
  7720.                     { var reg3 object acons = Car(alist);
  7721.                       if (eq(Car(acons),obj))
  7722.                         # gefunden
  7723.                         { # *ptr = obj = (car acons) durch (cdr acons) ersetzen,
  7724.                           # dabei aber das Markierungsbit unverändert lassen:
  7725.                           *ptr = (marked(ptr) ? with_mark_bit(Cdr(acons)) : Cdr(acons));
  7726.                           return;
  7727.                         }
  7728.                       alist = Cdr(alist);
  7729.                     }
  7730.                   # nicht gefunden -> Abbruch
  7731.                   subst_circ_bad = obj;
  7732.                   longjmp(subst_circ_jmpbuf,TRUE);
  7733.                 }
  7734.               else
  7735.               # Frame-Pointer
  7736.               {}
  7737.             return;
  7738.           case cons_type: # Cons
  7739.             if (marked(TheCons(obj))) return; # Objekt schon markiert?
  7740.             mark(TheCons(obj)); # markieren
  7741.             # rekursiv: subst_circ_mark(&Car(obj))
  7742.             subst_circ_mark(&Car(obj));
  7743.             # endrekursiv: subst_circ_mark(&Cdr(obj))
  7744.             ptr = &Cdr(obj); goto enter_subst;
  7745.           #ifdef IMMUTABLE_CONS
  7746.           case imm_cons_type: # immutables Cons
  7747.             if (marked(TheCons(obj))) return; # Objekt schon markiert?
  7748.             mark(TheImmCons(obj)); # markieren
  7749.             # rekursiv: subst_circ_mark(&Car(obj))
  7750.             subst_circ_mark(&TheImmCons(obj)->car);
  7751.             # endrekursiv: subst_circ_mark(&Cdr(obj))
  7752.             ptr = &TheImmCons(obj)->cdr; goto enter_subst;
  7753.           #endif
  7754.           case_machine: # Maschinenpointer
  7755.           case_bvector: # Bit-Vektor
  7756.           case_string: # String
  7757.           case_char: # Character
  7758.           case_subr: # SUBR
  7759.           case_number: # Zahl
  7760.           case_symbol: # Symbol
  7761.             # Objekt enthält keine Referenzen -> nichts zu tun
  7762.             return;
  7763.           default: NOTREACHED
  7764.     }}  }
  7765.   local void subst_circ_unmark(ptr)
  7766.     var reg2 object* ptr;
  7767.     { enter_subst:
  7768.      {var reg1 object obj = *ptr;
  7769.       # Fallunterscheidung nach Typ, wie oben:
  7770.       switch (typecode(obj))
  7771.         { case svector_type: # Simple-Vector
  7772.             if (!marked(TheSvector(obj))) return; # schon demarkiert?
  7773.             unmark(TheSvector(obj)); # demarkieren
  7774.             # alle Elemente durchlaufen:
  7775.             { var reg4 uintL len = TheSvector(obj)->length;
  7776.               if (!(len==0))
  7777.                 { var reg3 object* objptr = &TheSvector(obj)->data[0];
  7778.                   dotimespL(len,len, { subst_circ_unmark(&(*objptr++)); } );
  7779.             }   }
  7780.             return;
  7781.           case array_type:
  7782.           case vector_type:
  7783.             # nicht-simpler Array, kein String oder Bit-Vektor
  7784.             if (!marked(TheArray(obj))) return; # schon demarkiert?
  7785.             unmark(TheArray(obj)); # demarkieren
  7786.             # Datenvektor durchlaufen: endrekursiv subst_circ_unmark(Datenvektor)
  7787.             ptr = &TheArray(obj)->data; goto enter_subst;
  7788.           #ifdef IMMUTABLE_ARRAY
  7789.           case imm_svector_type: # immutabler Simple-Vector
  7790.             if (!marked(TheSvector(obj))) return; # schon demarkiert?
  7791.             unmark(TheImmSvector(obj)); # demarkieren
  7792.             # alle Elemente durchlaufen:
  7793.             { var reg4 uintL len = TheSvector(obj)->length;
  7794.               if (!(len==0))
  7795.                 { var reg3 object* objptr = &TheImmSvector(obj)->data[0];
  7796.                   dotimespL(len,len, { subst_circ_unmark(&(*objptr++)); } );
  7797.             }   }
  7798.             return;
  7799.           case imm_array_type:
  7800.           case imm_vector_type:
  7801.             # nicht-simpler Array, kein String oder Bit-Vektor
  7802.             if (!marked(TheArray(obj))) return; # schon demarkiert?
  7803.             unmark(TheImmArray(obj)); # demarkieren
  7804.             # Datenvektor durchlaufen: endrekursiv subst_circ_unmark(Datenvektor)
  7805.             ptr = &TheImmArray(obj)->data; goto enter_subst;
  7806.           #endif
  7807.           case_record: # Record
  7808.             if (!marked(TheRecord(obj))) return; # schon demarkiert?
  7809.             unmark(TheRecord(obj)); # demarkieren
  7810.             # alle Elemente durchlaufen:
  7811.             { var reg4 uintC len = Record_length(obj);
  7812.               if (!(len==0))
  7813.                 { var reg3 object* objptr = &TheRecord(obj)->recdata[0];
  7814.                   dotimespC(len,len, { subst_circ_unmark(&(*objptr++)); } );
  7815.             }   }
  7816.             return;
  7817.           case cons_type: # Cons
  7818.             if (!marked(TheCons(obj))) return; # schon demarkiert?
  7819.             unmark(TheCons(obj)); # demarkieren
  7820.             # rekursiv: subst_circ_unmark(&Car(obj))
  7821.             subst_circ_unmark(&Car(obj));
  7822.             # endrekursiv: subst_circ_unmark(&Cdr(obj))
  7823.             ptr = &Cdr(obj); goto enter_subst;
  7824.           #ifdef IMMUTABLE_CONS
  7825.           case imm_cons_type: # immutables Cons
  7826.             if (!marked(TheCons(obj))) return; # schon demarkiert?
  7827.             unmark(TheImmCons(obj)); # demarkieren
  7828.             # rekursiv: subst_circ_unmark(&Car(obj))
  7829.             subst_circ_unmark(&TheImmCons(obj)->car);
  7830.             # endrekursiv: subst_circ_unmark(&Cdr(obj))
  7831.             ptr = &TheImmCons(obj)->cdr; goto enter_subst;
  7832.           #endif
  7833.           case_system: # Frame-Pointer oder Read-Label oder System
  7834.           case_machine: # Maschinenpointer
  7835.           case_bvector: # Bit-Vektor
  7836.           case_string: # String
  7837.           case_char: # Character
  7838.           case_subr: # SUBR
  7839.           case_number: # Zahl
  7840.           case_symbol: # Symbol
  7841.             # Objekt enthält keine Referenzen -> nichts zu tun
  7842.             return;
  7843.           default: NOTREACHED
  7844.     }}  }
  7845.  
  7846. #endif
  7847.  
  7848. # ------------------------------------------------------------------------------
  7849. #                  Elementare Stringfunktionen
  7850.  
  7851. # Ausgabe eines konstanten ASCIZ-Strings, direkt übers Betriebssystem:
  7852. # asciz_out(string);
  7853. # > char* asciz: ASCIZ-String
  7854.   global void asciz_out (const char * asciz);
  7855.   global void asciz_out(asciz)
  7856.     var reg3 const char * asciz;
  7857.     {
  7858.       #ifdef AMIGAOS
  7859.         begin_system_call();
  7860.         Write(Output_handle,asciz,asciz_length(asciz));
  7861.         end_system_call();
  7862.       #endif
  7863.       #if (defined(UNIX) && !defined(NEXTAPP)) || (defined(MSDOS) && !defined(WINDOWS)) || defined(RISCOS) || defined(WIN32_UNIX)
  7864.         begin_system_call();
  7865.         full_write(stdout_handle,asciz,asciz_length(asciz));
  7866.         end_system_call();
  7867.       #endif
  7868.       #ifdef NEXTAPP
  7869.         begin_system_call();
  7870.         nxterminal_write_string(asciz);
  7871.         end_system_call();
  7872.       #endif
  7873.       #if defined(WINDOWS)
  7874.         # Low-Level Debug Output kann nicht über Windows gehen, sondern muß
  7875.         # ein File zum Ziel haben. Da unter DOS offene Files die Länge 0
  7876.         # haben, müssen wir das File sofort wieder schließen.
  7877.         #ifdef EMUNIX
  7878.           # open(), close() usw. ruft bei RSX direkt DOS auf.
  7879.           static int fd = -1;
  7880.           begin_system_call();
  7881.           if (fd<0)
  7882.             { fd = open("c:/lisp.out",O_RDWR|O_CREAT|O_TRUNC|O_TEXT,my_open_mask); }
  7883.           if (fd>=0)
  7884.             { write(fd,asciz,asciz_length(asciz));
  7885.               close(dup(fd)); # effectively fsync(fd)
  7886.             }
  7887.           end_system_call();
  7888.         #else
  7889.           var int fd;
  7890.           static char buf[] = "c:/temp/lisp0000.out";
  7891.           static uintL count = 0;
  7892.           buf[12] = ((count >> 9) & 7) + '0';
  7893.           buf[13] = ((count >> 6) & 7) + '0';
  7894.           buf[14] = ((count >> 3) & 7) + '0';
  7895.           buf[15] = ((count >> 0) & 7) + '0';
  7896.           count++;
  7897.           begin_system_call();
  7898.           #ifndef WATCOM
  7899.             fd = open(buf,O_RDWR|O_CREAT|O_TRUNC|O_TEXT,my_open_mask);
  7900.             if (fd>=0) { write(fd,asciz,asciz_length(asciz)); close(fd); }
  7901.           #else # WATCOM
  7902.             # Das normale open(), close() schließt nicht richtig, wenn das
  7903.             # Programm anschließend abstürzt.
  7904.             { var unsigned int written;
  7905.               fd = 0; _dos_creatnew(buf,0,&fd);
  7906.               _dos_write(fd,asciz,asciz_length(asciz),&written);
  7907.               _dos_close(fd);
  7908.             }
  7909.           #endif
  7910.           end_system_call();
  7911.         #endif
  7912.       #endif
  7913.     }
  7914.  
  7915.   global void err_asciz_out (const char * asciz);
  7916.   global void err_asciz_out(asciz)
  7917.     var reg3 const char * asciz;
  7918.     {
  7919.       asciz_out(CRLFstring "*** - ");
  7920.       asciz_out(asciz);
  7921.     }
  7922.  
  7923. # UP: Liefert einen LISP-String mit vorgegebenem Inhalt.
  7924. # make_string(charptr,len)
  7925. # > uintB* charptr: Adresse einer Zeichenfolge
  7926. # > uintL len: Länge der Zeichenfolge
  7927. # < ergebnis: Simple-String mit den len Zeichen ab charptr als Inhalt
  7928. # kann GC auslösen
  7929.   global object make_string (const uintB* charptr, uintL len);
  7930.   global object make_string(charptr,len)
  7931.     var reg2 const uintB* charptr;
  7932.     var reg3 uintL len;
  7933.     { var reg4 object obj = allocate_string(len); # String allozieren
  7934.       var reg1 uintB* ptr = &TheSstring(obj)->data[0];
  7935.       # Zeichenfolge von charptr nach ptr kopieren:
  7936.       dotimesL(len,len, { *ptr++ = *charptr++; } );
  7937.       return(obj);
  7938.     }
  7939.  
  7940. #ifndef asciz_length
  7941. # UP: Liefert die Länge eines ASCIZ-Strings.
  7942. # asciz_length(asciz)
  7943. # > char* asciz: ASCIZ-String
  7944. #       (Adresse einer durch ein Nullbyte abgeschlossenen Zeichenfolge)
  7945. # < ergebnis: Länge der Zeichenfolge (ohne Nullbyte)
  7946.   global uintL asciz_length (const char * asciz);
  7947.   global uintL asciz_length(asciz)
  7948.     var reg3 const char* asciz;
  7949.     { var reg1 const char* ptr = asciz;
  7950.       var reg2 uintL len = 0;
  7951.       # Nullbyte suchen und dabei Länge hochzählen:
  7952.       while (!( *ptr++ == 0 )) { len++; }
  7953.       return len;
  7954.     }
  7955. #endif
  7956.  
  7957. #ifndef asciz_equal
  7958. # UP: Vergleicht zwei ASCIZ-Strings.
  7959. # asciz_equal(asciz1,asciz2)
  7960. # > char* asciz1: erster ASCIZ-String
  7961. # > char* asciz2: zweiter ASCIZ-String
  7962. # < ergebnis: TRUE falls die Zeichenfolgen gleich sind
  7963.   global boolean asciz_equal (const char * asciz1, const char * asciz2);
  7964.   global boolean asciz_equal(asciz1,asciz2)
  7965.     var reg2 const char* asciz1;
  7966.     var reg3 const char* asciz2;
  7967.     { # Bytes vergleichen, solange bis das erste Nullbyte kommt:
  7968.       loop
  7969.         { var reg1 char ch1 = *asciz1++;
  7970.           if (!(ch1 == *asciz2++)) goto no;
  7971.           if (ch1 == '\0') goto yes;
  7972.         }
  7973.       yes: return TRUE;
  7974.       no: return FALSE;
  7975.     }
  7976. #endif
  7977.  
  7978. # UP: Wandelt einen ASCIZ-String in einen LISP-String um.
  7979. # asciz_to_string(asciz)
  7980. # > char* asciz: ASCIZ-String
  7981. #       (Adresse einer durch ein Nullbyte abgeschlossenen Zeichenfolge)
  7982. # < ergebnis: String mit der Zeichenfolge (ohne Nullbyte) als Inhalt
  7983. # kann GC auslösen
  7984.   global object asciz_to_string (const char * asciz);
  7985.   global object asciz_to_string(asciz)
  7986.     var reg1 const char* asciz;
  7987.     { return make_string((const uintB*)asciz,asciz_length(asciz)); }
  7988.  
  7989. # UP: Wandelt einen String in einen ASCIZ-String um.
  7990. # string_to_asciz(obj)
  7991. # > object obj: String
  7992. # < ergebnis: Simple-String mit denselben Zeichen und einem Nullbyte mehr am Schluß
  7993. # kann GC auslösen
  7994.   global object string_to_asciz (object obj);
  7995.   global object string_to_asciz (obj)
  7996.     var reg5 object obj;
  7997.     { # (vgl. copy_string in CHARSTRG)
  7998.       pushSTACK(obj); # String retten
  7999.      {var reg4 object new = allocate_string(vector_length(obj)+1);
  8000.           # neuer Simple-String mit einem Byte mehr Länge
  8001.       obj = popSTACK(); # String zurück
  8002.       { var uintL len;
  8003.         var reg1 uintB* sourceptr = unpack_string(obj,&len);
  8004.         # Source-String: Länge in len, Bytes ab sourceptr
  8005.         var reg2 uintB* destptr = &TheSstring(new)->data[0];
  8006.         # Destination-String: Bytes ab destptr
  8007.         { # Kopierschleife:
  8008.           var reg3 uintL count;
  8009.           dotimesL(count,len, { *destptr++ = *sourceptr++; } );
  8010.           *destptr++ = 0; # Nullbyte anfügen
  8011.       } }
  8012.       return(new);
  8013.     }}
  8014.  
  8015. # ------------------------------------------------------------------------------
  8016. #                  Andere globale Hilfsfunktionen
  8017.  
  8018. #if (int_bitsize < long_bitsize)
  8019. # Übergabewert an setjmpl() von longjmpl():
  8020.   global long jmpl_value;
  8021. #endif
  8022.  
  8023. #ifndef SP
  8024. # Bestimmung (einer Approximation) des SP-Stackpointers.
  8025.   global void* SP (void);
  8026.   global void* SP()
  8027.     { var long dummy;
  8028.       return &dummy;
  8029.     }
  8030. #endif
  8031.  
  8032. # Fehlermeldung wegen Erreichen einer unerreichbaren Programmstelle.
  8033. # Kehrt nicht zurück.
  8034. # fehler_notreached(file,line);
  8035. # > file: Filename (mit Anführungszeichen) als konstanter ASCIZ-String
  8036. # > line: Zeilennummer
  8037.   nonreturning_function(global, fehler_notreached, (const char * file, uintL line));
  8038.   global void fehler_notreached(file,line)
  8039.     var reg2 const char * file;
  8040.     var reg1 uintL line;
  8041.     { pushSTACK(fixnum(line));
  8042.       pushSTACK(asciz_to_string(file));
  8043.       { 
  8044.         //: DEUTSCH "Interner Fehler: Anweisung in File ~, Zeile ~ wurde ausgeführt!!"
  8045.         //: ENGLISH "Internal error: statement in file ~, line ~ has been reached!!"
  8046.         //: FRANCAIS "Erreur interne : Dans le fichier ~, la ligne ~ fut exécutée!"        
  8047.         var const char *line1 = GETTEXT("internal error in file ~, line ~");
  8048.         //: DEUTSCH "Bitte schicken Sie eine Mitteilung an die Programm-Autoren, "
  8049.         //: ENGLISH "Please send the authors of the program, "
  8050.         //: FRANCAIS "Veuillez signaler aux auteurs du programme comment " 
  8051.         var const char *line2 = GETTEXT("Please send the authors of the program");
  8052.         //: DEUTSCH "mit der Beschreibung, wie Sie diesen Fehler erzeugt haben!"
  8053.         //: ENGLISH "a description how you produced this error!"
  8054.         //: FRANCAIS "vous avez pu faire apparaître cette erreur, s.v.p.!"
  8055.         var const char *line3=GETTEXT("a description how you produced this error!");
  8056.         fehler5(serious_condition,line1,NLstring,line2,NLstring,line3);
  8057.       }
  8058.     }
  8059.  
  8060. #ifndef LANGUAGE_STATIC
  8061.  
  8062.   # Sprache, in der mit dem Benutzer kommuniziert wird:
  8063.     global uintC language;
  8064.  
  8065.   # Initialisiert die Sprache, gegeben die Sprachbezeichnung.
  8066.     local boolean init_language_from (const char* langname);
  8067.     local boolean init_language_from(langname)
  8068.       var reg1 const char* langname;
  8069.       { if (asciz_equal(langname,"ENGLISH") || asciz_equal(langname,"english"))
  8070.           { language = language_english; return TRUE; }
  8071.         if (asciz_equal(langname,"DEUTSCH") || asciz_equal(langname,"deutsch")
  8072.             || asciz_equal(langname,"GERMAN") || asciz_equal(langname,"german")
  8073.            )
  8074.           { language = language_deutsch; return TRUE; }
  8075.         if (asciz_equal(langname,"FRANCAIS") || asciz_equal(langname,"francais")
  8076.             #ifndef ASCII_CHS
  8077.             || asciz_equal(langname,"FRANÇAIS") || asciz_equal(langname,"français")
  8078.             #endif
  8079.             || asciz_equal(langname,"FRENCH") || asciz_equal(langname,"french")
  8080.            )
  8081.           { language = language_francais; return TRUE; }
  8082.         return FALSE;
  8083.       }
  8084.  
  8085.   # Initialisiert die Sprache.
  8086.     local void init_language (const char* argv_language);
  8087.     local void init_language(argv_language)
  8088.       var reg2 const char* argv_language;
  8089.       { # Sprache wird so festgelegt, mit Prioritäten in dieser Reihenfolge:
  8090.         #   1. Fest eingebaut, LANGUAGE_STATIC
  8091.         #   2. -L Kommandozeilen-Argument
  8092.         #   3. Environment-Variable CLISP_LANGUAGE
  8093.         #   4. Environment-Variable LANG
  8094.         #   5. Default: Englisch
  8095.         if (argv_language)
  8096.           { if (init_language_from(argv_language)) return; }
  8097.         #ifdef HAVE_ENVIRONMENT
  8098.         { var reg1 const char* langname = getenv("CLISP_LANGUAGE");
  8099.           if (langname)
  8100.             { if (init_language_from(langname)) return; }
  8101.           #ifdef AMIGAOS
  8102.           langname = getenv("Language"); # since OS 3.0
  8103.             { if (init_language_from(langname)) return; }
  8104.           #endif
  8105.         }
  8106.         { var reg1 const char* lang = getenv("LANG");
  8107.           if (lang)
  8108.             { # LANG hat i.a. die Syntax Sprache[_Land][.Zeichensatz]
  8109.               if (lang[0]=='e' && lang[1]=='n' && !alphanumericp((uintB)lang[2])) # "en"
  8110.                 { language = language_english; return; }
  8111.               if (lang[0]=='d' && lang[1]=='e' && !alphanumericp((uintB)lang[2])) # "de"
  8112.                 { language = language_deutsch; return; }
  8113.               if (lang[0]=='f' && lang[1]=='r' && !alphanumericp((uintB)lang[2])) # "fr"
  8114.                 { language = language_francais; return; }
  8115.         }   }
  8116.         #endif
  8117.  
  8118.         # Default: Englisch
  8119.         language = language_english;
  8120.       }
  8121.  
  8122. #endif
  8123.  
  8124. # ------------------------------------------------------------------------------
  8125. #                       Tastatur-Unterbrechung
  8126.  
  8127. # ------------------------------------------------------------------------------
  8128. #                        Initialisierung
  8129.  
  8130. # Name des Programms (für Fehlermeldungszwecke)
  8131.   global char* program_name;
  8132.  
  8133. # Flag, ob System vollständig geladen (für Fehlermeldungsbehandlung)
  8134.   local boolean everything_ready = FALSE;
  8135.  
  8136. # Flag, ob SYS::READ-FORM sich ILISP-kompatibel verhalten soll:
  8137.   global boolean ilisp_mode = FALSE;
  8138.  
  8139. #if defined(UNIX) || defined(WIN32_UNIX)
  8140.  
  8141. # Real User ID des laufenden Prozesses.
  8142.   global uid_t user_uid;
  8143.  
  8144. #endif
  8145.  
  8146. #ifdef PENDING_INTERRUPTS
  8147.   # Flag, ob eine Unterbrechung anliegt.
  8148.   global uintB interrupt_pending = FALSE;
  8149. #endif
  8150.  
  8151. #ifdef HAVE_SIGNALS
  8152.  
  8153. # Paßt den Wert von SYS::*PRIN-LINELENGTH* an die aktuelle Breite des
  8154. # Terminal-Fensters an.
  8155. # update_linelength();
  8156.   local void update_linelength (void);
  8157.   local void update_linelength()
  8158.     { # SYS::*PRIN-LINELENGTH* := Breite des Terminal-Fensters - 1
  8159.       #if !defined(NEXTAPP)
  8160.       # [vgl. 'term.c' in 'calc' von Hans-J. Böhm, Vernon Lee, Alan J. Demers]
  8161.       if (isatty(stdout_handle)) # Standard-Output ein Terminal?
  8162.         { /* var reg2 int lines = 0; */
  8163.           var reg1 int columns = 0;
  8164.           #ifdef TIOCGWINSZ
  8165.           # Probiere erst ioctl:
  8166.           { var struct winsize stdout_window_size;
  8167.             if (!( ioctl(stdout_handle,TIOCGWINSZ,&stdout_window_size) <0))
  8168.               { /* lines = stdout_window_size.ws_row; */
  8169.                 columns = stdout_window_size.ws_col;
  8170.           }   }
  8171.           # Das kann - entgegen der Dokumentation - scheitern!
  8172.           if (/* (lines > 0) && */ (columns > 0)) goto OK;
  8173.           #endif
  8174.           #if !defined(WATCOM) && !defined(WIN32_DOS) && !defined(WIN32_UNIX)
  8175.           # Nun probieren wir's über termcap:
  8176.           { var reg3 char* term_name = getenv("TERM");
  8177.             if (term_name==NULL) { term_name = "unknown"; }
  8178.            {var char termcap_entry_buf[10000];
  8179.             if ( tgetent(&!termcap_entry_buf,term_name) ==1)
  8180.               { /* lines = tgetnum("li"); if (lines<0) { lines = 0; } */
  8181.                 columns = tgetnum("co"); if (columns<0) { columns = 0; }
  8182.               }
  8183.           }}
  8184.           #endif
  8185.           # Hoffentlich enthält columns jetzt einen vernünftigen Wert.
  8186.           if (/* (lines > 0) && */ (columns > 0)) goto OK;
  8187.           if (FALSE)
  8188.             { OK:
  8189.               # Wert von SYS::*PRIN-LINELENGTH* verändern:
  8190.               set_Symbol_value(S(prin_linelength),fixnum(columns-1));
  8191.             }
  8192.         }
  8193.       #else # defined(NEXTAPP)
  8194.       if (nxterminal_line_length > 0)
  8195.         # Wert von SYS::*PRIN-LINELENGTH* verändern:
  8196.         { set_Symbol_value(S(prin_linelength),fixnum(nxterminal_line_length-1)); }
  8197.       #endif
  8198.     }
  8199. #if defined(SIGWINCH) && !defined(NO_ASYNC_INTERRUPTS)
  8200. # Signal-Handler für Signal SIGWINCH:
  8201.   local void sigwinch_handler (int sig);
  8202.   local void sigwinch_handler(sig)
  8203.     var int sig; # sig = SIGWINCH
  8204.     { signal_acknowledge(SIGWINCH,&sigwinch_handler);
  8205.       update_linelength();
  8206.     }
  8207. #endif
  8208.  
  8209. # Our general policy with child processes - in particular child processes
  8210. # to which we are connected through pipes - is not to wait for them, but
  8211. # instead do what init(1) would do in case our process terminates before
  8212. # the child: perform a non-blocking waitpid() and ignore the child's
  8213. # termination status.
  8214. #   void handle_child () { while (waitpid(-1,NULL,WNOHANG) > 0); }
  8215. #   SIGNAL(SIGCLD,handle_child);
  8216. # The following is equivalent (but better, since it doesn't interrupt system
  8217. # calls):
  8218. #   SIGNAL(SIGCLD,SIG_IGN);
  8219.  
  8220.   local void install_sigcld_handler (void);
  8221.   local void install_sigcld_handler ()
  8222.     {
  8223.       #if defined(SIGCLD)
  8224.         SIGNAL(SIGCLD,SIG_IGN);
  8225.       #endif
  8226.     }
  8227.  
  8228.   global void begin_want_sigcld ()
  8229.     {
  8230.       #if defined(SIGCLD)
  8231.         SIGNAL(SIGCLD,SIG_DFL);
  8232.       #endif
  8233.     }
  8234.   global void end_want_sigcld ()
  8235.     {
  8236.       #if defined(SIGCLD)
  8237.         SIGNAL(SIGCLD,SIG_IGN);
  8238.         # Try to remove zombies which may have been created since the last
  8239.         # begin_want_sigcld() call.
  8240.         #ifdef HAVE_WAITPID
  8241.           while (waitpid(-1,NULL,WNOHANG) > 0);
  8242.         #endif
  8243.       #endif
  8244.     }
  8245.  
  8246. # Eine Tastatur-Unterbrechung (Signal SIGINT, erzeugt durch Ctrl-C)
  8247. # wird eine Sekunde lang aufgehoben. In dieser Zeit kann sie mittels
  8248. # 'interruptp' auf fortsetzbare Art behandelt werden. Nach Ablauf dieser
  8249. # Zeit wird das Programm nichtfortsetzbar unterbrochen.
  8250. # Signal-Handler für Signal SIGINT:
  8251.   local void interrupt_handler (int sig);
  8252.   local void interrupt_handler(sig)
  8253.     var int sig; # sig = SIGINT
  8254.     { signal_acknowledge(SIGINT,&interrupt_handler);
  8255.   #ifdef PENDING_INTERRUPTS
  8256.       if (!interrupt_pending) # Liegt schon ein Interrupt an -> nichts zu tun
  8257.         { interrupt_pending = TRUE; # Flag für 'interruptp' setzen
  8258.           #ifdef HAVE_UALARM
  8259.           # eine halbe Sekunde warten, dann jede 1/20 sec probieren
  8260.           ualarm(ticks_per_second/2,ticks_per_second/20);
  8261.           #else
  8262.           alarm(1); # eine Sekunde warten, weiter geht's dann bei alarm_handler
  8263.           #endif
  8264.         }
  8265.     }
  8266.   local void alarm_handler (int sig);
  8267.   local void alarm_handler(sig)
  8268.     var int sig; # sig = SIGALRM
  8269.     { # Die Zeit ist nun abgelaufen.
  8270.       #if defined(EMUNIX) || defined(WIN32_DOS) # Verhindere Programm-Beendigung durch SIGALRM
  8271.       #ifndef HAVE_UALARM
  8272.       #ifdef EMUNIX_OLD_8h # EMX-Bug umgehen
  8273.       alarm(1000);
  8274.       #endif
  8275.       alarm(0); # SIGALRM-Timer abbrechen
  8276.       #endif
  8277.       #endif
  8278.       signal_acknowledge(SIGALRM,&alarm_handler);
  8279.   #endif # PENDING_INTERRUPTS (!)
  8280.     #ifndef NO_ASYNC_INTERRUPTS
  8281.       # Warten, bis Unterbrechung erlaubt:
  8282.       if (!(break_sems.gesamt == 0))
  8283.     #endif
  8284.         {
  8285.           #ifndef WATCOM
  8286.           #ifndef HAVE_UALARM
  8287.           alarm(1); # Probieren wir's in einer Sekunde nochmal
  8288.           #endif
  8289.           #endif
  8290.           return; # Nach kurzer Zeit wird wieder ein SIGALRM ausgelöst.
  8291.         }
  8292.     #ifndef NO_ASYNC_INTERRUPTS
  8293.       # Wir springen jetzt aus dem signal-Handler heraus, weder mit 'return'
  8294.       # noch mit 'longjmp'.
  8295.       #
  8296.       # Hans-J. Boehm <boehm@parc.xerox.com> weist darauf hin, daß dies
  8297.       # Probleme bringen kann, wenn das Signal ein laufendes malloc() oder
  8298.       # free() unterbrochen hat und die malloc()-Library nicht reentrant ist.
  8299.       # Abhilfe: statt malloc() stets xmalloc() verwenden, das eine Break-
  8300.       # Semaphore setzt? Aber was ist mit malloc()-Aufrufen, die von Routinen
  8301.       # wie opendir(), getpwnam(), tgetent(), ... abgesetzt werden? Soll man
  8302.       # malloc() selber definieren und darauf hoffen, daß es von allen Library-
  8303.       # funktionen aufgerufen wird (statisch gelinkt oder per DLL)??
  8304.       #
  8305.       #if defined(SIGNAL_NEED_UNBLOCK) || (defined(GNU_READLINE) && (defined(SIGNALBLOCK_BSD) || defined(SIGNALBLOCK_POSIX)))
  8306.       # Falls entweder [SIGNAL_NEED_UNBLOCK] mit signal() installierte Handler
  8307.       # sowieso mit blockiertem Signal aufgerufen werden - das sind üblicherweise
  8308.       # BSD-Systeme -, oder falls andere unsichere Komponenten [GNU_READLINE]
  8309.       # per sigaction() o.ä. das Blockieren des Signals beim Aufruf veranlassen
  8310.       # können, müssen wir das gerade blockierte Signal entblockieren:
  8311.         #if defined(SIGNALBLOCK_POSIX)
  8312.           { var sigset_t sigblock_mask;
  8313.             sigemptyset(&sigblock_mask); sigaddset(&sigblock_mask,SIGALRM);
  8314.             sigprocmask(SIG_UNBLOCK,&sigblock_mask,NULL);
  8315.           }
  8316.         #elif defined(SIGNALBLOCK_BSD)
  8317.           sigsetmask(sigblock(0) & ~sigmask(SIGALRM));
  8318.         #endif
  8319.       #endif
  8320.       #ifdef HAVE_SAVED_STACK
  8321.       # STACK auf einen sinnvollen Wert setzen:
  8322.       if (!(saved_STACK==NULL)) { setSTACK(STACK = saved_STACK); }
  8323.       #endif
  8324.       # Über 'fehler' in eine Break-Schleife springen:
  8325.       //: DEUTSCH "Ctrl-C: Tastatur-Interrupt"
  8326.       //: ENGLISH "Ctrl-C: User break"
  8327.       //: FRANCAIS "Ctrl-C : Interruption clavier"
  8328.       fehler(serious_condition,GETTEXT("ctrl-c user break"));
  8329.     #endif
  8330.     }
  8331.  
  8332. #if defined(IMMUTABLE) && !defined(GENERATIONAL_GC)
  8333. # Signal-Handler für Signal SIGSEGV:
  8334.   local void sigsegv_handler (int sig);
  8335.   local void sigsegv_handler(sig)
  8336.     var int sig; # sig = SIGSEGV
  8337.     { signal_acknowledge(SIGSEGV,&sigsegv_handler);
  8338.       break_sems.gesamt = 0; # Sehr gefährlich!!
  8339.       #ifdef SIGNAL_NEED_UNBLOCK # Unter Linux nicht nötig, unter SunOS4 nötig.
  8340.       # gerade blockiertes Signal entblockieren:
  8341.       sigsetmask(sigblock(0) & ~sigmask(SIGSEGV));
  8342.       #endif
  8343.       #ifdef HAVE_SAVED_STACK
  8344.       # STACK auf einen sinnvollen Wert setzen:
  8345.       if (!(saved_STACK==NULL)) { setSTACK(STACK = saved_STACK); }
  8346.       #endif
  8347.       # Über 'fehler' in eine Break-Schleife springen:
  8348.       fehler_immutable();
  8349.     }
  8350.   #define install_segv_handler()  \
  8351.     SIGNAL(SIGSEGV,&sigsegv_handler)
  8352. #endif
  8353.  
  8354. #ifdef GENERATIONAL_GC
  8355.  
  8356.   local void install_segv_handler (void);
  8357.  
  8358.   #ifdef UNIX_NEXTSTEP
  8359.  
  8360.     # Die Fehler-Adresse bekommen wir als subcode zu einer Mach-Exception.
  8361.     # Dazu läuft ein Thread, der am Exception-Port horcht.
  8362.  
  8363.     #include <mach/exception.h>
  8364.     #include <mach/exc_server.h>
  8365.     #include <mach/cthreads.h>
  8366.  
  8367.     # Die Behandlungs-Methode, wird von exc_server() aufgerufen:
  8368.     global kern_return_t catch_exception_raise (port_t exception_port, port_t thread, port_t task, int exception, int code, int subcode);
  8369.     local boolean exception_handled = FALSE;
  8370.     global kern_return_t catch_exception_raise(exception_port,thread,task,exception,code,subcode)
  8371.       var port_t exception_port;
  8372.       var port_t thread;
  8373.       var port_t task;
  8374.       var reg1 int exception;
  8375.       var int code;
  8376.       var reg2 int subcode;
  8377.       { if ((exception == EXC_BAD_ACCESS)
  8378.             # siehe <mach/exception.h>:
  8379.             #   Could not access memory
  8380.             #   Code contains kern_return_t describing error.
  8381.             #   Subcode contains bad memory address.
  8382.             && (handle_fault((aint)subcode) == handler_done)
  8383.            )
  8384.           { exception_handled = TRUE; return KERN_SUCCESS; }
  8385.           else
  8386.           { exception_handled = FALSE; return KERN_FAILURE; }
  8387.       }
  8388.  
  8389.     local port_t main_thread_port;
  8390.     local port_t old_exception_port;
  8391.     local port_t new_exception_port;
  8392.  
  8393.     # Haupt-Funktion des Threads:
  8394.     local any_t exception_thread_main (void* dummy);
  8395.     local any_t exception_thread_main(dummy)
  8396.       var void* dummy;
  8397.       { var char in_msg_data[excMaxRequestSize]; # siehe <mach/exc_server.h>
  8398.         var char out_msg_data[excMaxReplySize]; # siehe <mach/exc_server.h>
  8399.         #define in_msg  (*((msg_header_t*)&in_msg_data[0]))
  8400.         #define out_msg  (*((msg_header_t*)&out_msg_data[0]))
  8401.         var reg1 kern_return_t retval;
  8402.         loop
  8403.           { # Auf Message am Exception-Port warten:
  8404.             in_msg.msg_size = excMaxRequestSize;
  8405.             in_msg.msg_local_port = new_exception_port;
  8406.             retval = msg_receive(&in_msg,MSG_OPTION_NONE,0);
  8407.             if (!(retval==KERN_SUCCESS))
  8408.               { 
  8409.                 //: DEUTSCH "Mach msg_receive didn't succeed."
  8410.                 //: ENGLISH "Mach msg_receive didn't succeed."
  8411.                 //: FRANCAIS "Mach msg_receive didn't succeed."
  8412.                 asciz_out(GETTEXT("Mach msg_receive didn't succeed."));
  8413.                 asciz_out(CRLFstring);
  8414.                 abort(); 
  8415.               }
  8416.             # Exception-Handler 1 aufrufen, der liefert in out_msg eine Antwort:
  8417.             if (!exc_server(&in_msg,&out_msg))
  8418.               { 
  8419.                 //: DEUTSCH "Mach exc_server didn't succeed."
  8420.                 //: ENGLISH "Mach exc_server didn't succeed."
  8421.                 //: FRANCAIS "Mach exc_server didn't succeed."
  8422.                 asciz_out(GETTEXT("Mach exc_server didn't succeed."));
  8423.                 asciz_out(CRLFstring);
  8424.                 abort(); 
  8425.               }
  8426.             # Antwort weiterleiten:
  8427.             retval = msg_send(&out_msg,MSG_OPTION_NONE,0);
  8428.             if (!(retval==KERN_SUCCESS))
  8429.               {
  8430.                 //: DEUTSCH "Mach msg_send didn't succeed."
  8431.                 //: ENGLISH "Mach msg_send didn't succeed."
  8432.                 //: FRANCAIS "Mach msg_send didn't succeed."
  8433.                 asciz_out(GETTEXT("Mach msg_send didn't succeed."));
  8434.                 asciz_out(CRLFstring); 
  8435.                 abort(); 
  8436.               }
  8437.             # Rückgabewert von handle_fault() anschauen:
  8438.             if (exception_handled)
  8439.               { exception_handled = FALSE; }
  8440.               else
  8441.               { # Exception-Handler 2 aufrufen:
  8442.                 in_msg.msg_remote_port = old_exception_port;
  8443.                 in_msg.msg_local_port = main_thread_port;
  8444.                 retval = msg_send(&in_msg,MSG_OPTION_NONE,0);
  8445.                 if (!(retval==KERN_SUCCESS))
  8446.                   { 
  8447.                     //: DEUTSCH "Mach msg_send to old_exception_port didn't succeed."
  8448.                     //: ENGLISH "Mach msg_send to old_exception_port didn't succeed."
  8449.                     //: FRANCAIS "Mach msg_send to old_exception_port didn't succeed."
  8450.                     asciz_out(GETTEXT("Mach msg_send to old_exception_port didn't succeed."));
  8451.                     asciz_out(CRLFstring);
  8452.                     abort(); 
  8453.                   }
  8454.               }
  8455.       }   }
  8456.  
  8457.     local void install_segv_handler()
  8458.       { local var boolean already_installed = FALSE;
  8459.         if (already_installed)
  8460.           return;
  8461.         # Alten Exception-Port retten:
  8462.         if (!(task_get_exception_port(task_self(),&old_exception_port)==KERN_SUCCESS))
  8463.           {
  8464.             //: DEUTSCH "Mach task_get_exception_port fails."
  8465.             //: ENGLISH "Mach task_get_exception_port fails."
  8466.             //: FRANCAIS "Mach task_get_exception_port fails."
  8467.             asciz_out(GETTEXT("Mach task_get_exception_port fails."));
  8468.             asciz_out(CRLFstring);
  8469.             abort(); 
  8470.           }
  8471.         # Neuen Exception-Port installieren:
  8472.         if (!(port_allocate(task_self(),&new_exception_port)==KERN_SUCCESS))
  8473.           { 
  8474.             //: DEUTSCH "Mach port_allocate fails."
  8475.             //: ENGLISH "Mach port_allocate fails."
  8476.             //: FRANCAIS "Mach port_allocate fails."
  8477.             asciz_out(GETTEXT("Mach port_allocate fails."));
  8478.             asciz_out(CRLFstring);
  8479.             abort(); 
  8480.           }
  8481.         if (!(task_set_exception_port(task_self(),new_exception_port)==KERN_SUCCESS))
  8482.           { 
  8483.             //: DEUTSCH "Mach task_set_exception_port fails."
  8484.             //: ENGLISH "Mach task_set_exception_port fails."
  8485.             //: FRANCAIS "Mach task_set_exception_port fails."
  8486.             asciz_out(GETTEXT("Mach task_set_exception_port fails."));
  8487.             asciz_out(CRLFstring);
  8488.             abort(); 
  8489.           }
  8490.         # Exception-Behandlungs-Thread aufsetzen:
  8491.         cthread_detach(cthread_fork(&exception_thread_main,NULL));
  8492.         already_installed = TRUE;
  8493.       }
  8494.  
  8495.   #else
  8496.  
  8497.     local void install_sigsegv_handler (int sig);
  8498.  
  8499.     # Signal-Handler für Signal SIGSEGV u.ä.:
  8500.     local void sigsegv_handler (FAULT_HANDLER_ARGLIST)
  8501.       FAULT_HANDLER_ARGDECL
  8502.       { var char* address = (char*)(FAULT_ADDRESS);
  8503.         switch (handle_fault((aint)address))
  8504.           { case handler_done:
  8505.               # erfolgreich
  8506.               #ifdef SIGNAL_NEED_REINSTALL
  8507.               install_sigsegv_handler(sig);
  8508.               #endif
  8509.               break;
  8510.             case handler_immutable:
  8511.               if (sig == SIGSEGV)
  8512.                 {
  8513.                   #ifdef IMMUTABLE
  8514.                   #ifdef SIGNAL_NEED_REINSTALL
  8515.                   install_sigsegv_handler(sig);
  8516.                   #endif
  8517.                   break_sems.gesamt = 0; # Sehr gefährlich!!
  8518.                   # gerade blockierte Signale entblockieren:
  8519.                   #ifdef HAVE_SIGACTION
  8520.                     #if defined(SIGNALBLOCK_POSIX)
  8521.                     { var sigset_t sigblock_mask;
  8522.                       sigemptyset(&sigblock_mask);
  8523.                       sigaddset(&sigblock_mask,sig);
  8524.                       sigaddset(&sigblock_mask,SIGINT);
  8525.                       sigaddset(&sigblock_mask,SIGALRM);
  8526.                       #ifdef SIGWINCH
  8527.                       sigaddset(&sigblock_mask,SIGWINCH);
  8528.                       #endif
  8529.                       sigprocmask(SIG_UNBLOCK,&sigblock_mask,NULL);
  8530.                     }
  8531.                     #elif defined(SIGNALBLOCK_SYSV)
  8532.                       sigrelse(sig);
  8533.                       sigrelse(SIGINT);
  8534.                       sigrelse(SIGALRM);
  8535.                       #ifdef SIGWINCH
  8536.                       sigrelse(SIGWINCH);
  8537.                       #endif
  8538.                     #elif defined(SIGNALBLOCK_BSD)
  8539.                     { var sigset_t sigblock_mask = sigblock(0);
  8540.                       sigblock_mask &= ~sigmask(sig);
  8541.                       sigblock_mask &= ~sigmask(SIGINT);
  8542.                       sigblock_mask &= ~sigmask(SIGALRM);
  8543.                       #ifdef SIGWINCH
  8544.                       sigblock_mask &= ~sigmask(SIGWINCH);
  8545.                       #endif
  8546.                       sigsetmask(sigblock_mask);
  8547.                     }
  8548.                     #endif
  8549.                   #else
  8550.                     #ifdef SIGNAL_NEED_UNBLOCK # Unter SunOS4 nötig.
  8551.                     sigsetmask(sigblock(0) & ~sigmask(sig));
  8552.                     #endif
  8553.                   #endif
  8554.                   #ifdef HAVE_SAVED_STACK
  8555.                   # STACK auf einen sinnvollen Wert setzen:
  8556.                   if (!(saved_STACK==NULL)) { setSTACK(STACK = saved_STACK); }
  8557.                   #endif
  8558.                   # Über 'fehler' in eine Break-Schleife springen:
  8559.                   fehler_immutable();
  8560.                   #endif
  8561.                 }
  8562.               /* fallthrough */
  8563.             case handler_failed:
  8564.               # erfolglos 
  8565.               //: DEUTSCH "SIGSEGV kann nicht behoben werden. Fehler-Adresse = 0x"
  8566.               //: ENGLISH "SIGSEGV cannot be cured. Fault address = 0x"
  8567.               //: FRANCAIS "SIGSEGV ne peut être relevé. Adresse fautive = 0x"
  8568.               err_asciz_out(GETTEXT("segfault cannot be cured"));
  8569.               hex_out(address);
  8570.               //: DEUTSCH "."
  8571.               //: ENGLISH "."
  8572.               //: FRANCAIS "."
  8573.               asciz_out(GETTEXT("[end]segfault cannot be cured"));
  8574.               asciz_out(CRLFstring);
  8575.               # Der Default-Handler wird uns in den Debugger führen.
  8576.               SIGNAL(sig,SIG_DFL);
  8577.               break;
  8578.           }
  8579.       }
  8580.  
  8581.     # Signal-Handler sorgfältig installieren:
  8582.     local void install_sigsegv_handler(sig)
  8583.       var reg1 int sig;
  8584.       {
  8585.         #ifdef HAVE_SIGACTION
  8586.           struct sigaction action;
  8587.           action.sa_handler = &sigsegv_handler;
  8588.           # Während einer SIGSEGV-Behandlung sollten alle Signale blockiert
  8589.           # sein, deren Behandlung auf Lisp-Objekte zugreifen muß.
  8590.           sigemptyset(&action.sa_mask);
  8591.           sigaddset(&action.sa_mask,SIGINT);
  8592.           sigaddset(&action.sa_mask,SIGALRM);
  8593.           #ifdef SIGWINCH
  8594.           sigaddset(&action.sa_mask,SIGWINCH);
  8595.           #endif
  8596.           # Eventuell muß das Betriebssystem dem Handler
  8597.           # ein "siginfo_t" übergeben:
  8598.           action.sa_flags =
  8599.                             #ifdef FAULT_ADDRESS_FROM_SIGINFO
  8600.                             SA_SIGINFO |
  8601.                             #endif
  8602.                             0;
  8603.           sigaction(sig,&action,(struct sigaction *)0);
  8604.         #else
  8605.           SIGNAL(sig,&sigsegv_handler);
  8606.         #endif
  8607.       }
  8608.  
  8609.     # Alle Signal-Handler installieren:
  8610.     local void install_segv_handler()
  8611.       {
  8612.         #define FAULT_HANDLER(sig)  install_sigsegv_handler(sig);
  8613.         WP_SIGNAL
  8614.         #undef FAULT_HANDLER
  8615.       }
  8616.  
  8617.   #endif
  8618.  
  8619. #endif
  8620.  
  8621. #endif
  8622.  
  8623. # Umwandlung der Argumenttypen eines FSUBR in einen Code:
  8624.   local fsubr_argtype_ fsubr_argtype (uintW req_anz, uintW opt_anz, fsubr_body_ body_flag);
  8625.   local fsubr_argtype_ fsubr_argtype(req_anz,opt_anz,body_flag)
  8626.     var reg1 uintW req_anz;
  8627.     var reg2 uintW opt_anz;
  8628.     var reg3 fsubr_body_ body_flag;
  8629.     { switch (body_flag)
  8630.         { case fsubr_nobody:
  8631.             switch (opt_anz)
  8632.               { case 0:
  8633.                   switch (req_anz)
  8634.                     { case 1: return(fsubr_argtype_1_0_nobody);
  8635.                       case 2: return(fsubr_argtype_2_0_nobody);
  8636.                       default: goto illegal;
  8637.                     }
  8638.                 case 1:
  8639.                   switch (req_anz)
  8640.                     { case 1: return(fsubr_argtype_1_1_nobody);
  8641.                       case 2: return(fsubr_argtype_2_1_nobody);
  8642.                       default: goto illegal;
  8643.                     }
  8644.                 default: goto illegal;
  8645.               }
  8646.           case fsubr_body:
  8647.             switch (opt_anz)
  8648.               { case 0:
  8649.                   switch (req_anz)
  8650.                     { case 0: return(fsubr_argtype_0_body);
  8651.                       case 1: return(fsubr_argtype_1_body);
  8652.                       case 2: return(fsubr_argtype_2_body);
  8653.                       default: goto illegal;
  8654.                     }
  8655.                 default: goto illegal;
  8656.               }
  8657.           default: goto illegal;
  8658.         }
  8659.       illegal:
  8660.         //: DEUTSCH "Unbekannter FSUBR-Argumenttyp"
  8661.         //: ENGLISH "Unknown signature of a FSUBR"
  8662.         //: FRANCAIS "Type d'argument inconnu pour FSUBR"
  8663.         asciz_out(GETTEXT("unknown signature of a fsubr")); 
  8664.         asciz_out(CRLFstring);
  8665.         quit_sofort(1);
  8666.     }
  8667.  
  8668. # Umwandlung der Argumenttypen eines SUBR in einen Code:
  8669.   local subr_argtype_ subr_argtype (uintW req_anz, uintW opt_anz, subr_rest_ rest_flag, subr_key_ key_flag);
  8670.   local subr_argtype_ subr_argtype(req_anz,opt_anz,rest_flag,key_flag)
  8671.     var reg1 uintW req_anz;
  8672.     var reg2 uintW opt_anz;
  8673.     var reg3 subr_rest_ rest_flag;
  8674.     var reg4 subr_key_ key_flag;
  8675.     { switch (key_flag)
  8676.         { case subr_nokey:
  8677.             switch (rest_flag)
  8678.               { case subr_norest:
  8679.                   switch (opt_anz)
  8680.                     { case 0:
  8681.                         switch (req_anz)
  8682.                           { case 0: return(subr_argtype_0_0);
  8683.                             case 1: return(subr_argtype_1_0);
  8684.                             case 2: return(subr_argtype_2_0);
  8685.                             case 3: return(subr_argtype_3_0);
  8686.                             case 4: return(subr_argtype_4_0);
  8687.                             case 5: return(subr_argtype_5_0);
  8688.                             case 6: return(subr_argtype_6_0);
  8689.                             default: goto illegal;
  8690.                           }
  8691.                       case 1:
  8692.                         switch (req_anz)
  8693.                           { case 0: return(subr_argtype_0_1);
  8694.                             case 1: return(subr_argtype_1_1);
  8695.                             case 2: return(subr_argtype_2_1);
  8696.                             case 3: return(subr_argtype_3_1);
  8697.                             case 4: return(subr_argtype_4_1);
  8698.                             default: goto illegal;
  8699.                           }
  8700.                       case 2:
  8701.                         switch (req_anz)
  8702.                           { case 0: return(subr_argtype_0_2);
  8703.                             case 1: return(subr_argtype_1_2);
  8704.                             case 2: return(subr_argtype_2_2);
  8705.                             default: goto illegal;
  8706.                           }
  8707.                       case 3:
  8708.                         switch (req_anz)
  8709.                           { case 0: return(subr_argtype_0_3);
  8710.                             default: goto illegal;
  8711.                           }
  8712.                       case 4:
  8713.                         switch (req_anz)
  8714.                           { case 0: return(subr_argtype_0_4);
  8715.                             default: goto illegal;
  8716.                           }
  8717.                       case 5:
  8718.                         switch (req_anz)
  8719.                           { case 0: return(subr_argtype_0_5);
  8720.                             default: goto illegal;
  8721.                           }
  8722.                       default: goto illegal;
  8723.                     }
  8724.                 case subr_rest:
  8725.                   switch (opt_anz)
  8726.                     { case 0:
  8727.                         switch (req_anz)
  8728.                           { case 0: return(subr_argtype_0_0_rest);
  8729.                             case 1: return(subr_argtype_1_0_rest);
  8730.                             case 2: return(subr_argtype_2_0_rest);
  8731.                             case 3: return(subr_argtype_3_0_rest);
  8732.                             default: goto illegal;
  8733.                           }
  8734.                       default: goto illegal;
  8735.                     }
  8736.                 default: goto illegal;
  8737.               }
  8738.           case subr_key:
  8739.             switch (rest_flag)
  8740.               { case subr_norest:
  8741.                   switch (opt_anz)
  8742.                     { case 0:
  8743.                         switch (req_anz)
  8744.                           { case 0: return(subr_argtype_0_0_key);
  8745.                             case 1: return(subr_argtype_1_0_key);
  8746.                             case 2: return(subr_argtype_2_0_key);
  8747.                             case 3: return(subr_argtype_3_0_key);
  8748.                             case 4: return(subr_argtype_4_0_key);
  8749.                             default: goto illegal;
  8750.                           }
  8751.                       case 1:
  8752.                         switch (req_anz)
  8753.                           { case 0: return(subr_argtype_0_1_key);
  8754.                             case 1: return(subr_argtype_1_1_key);
  8755.                             default: goto illegal;
  8756.                           }
  8757.                       case 2:
  8758.                         switch (req_anz)
  8759.                           { case 1: return(subr_argtype_1_2_key);
  8760.                             default: goto illegal;
  8761.                           }
  8762.                       default: goto illegal;
  8763.                     }
  8764.                 case subr_rest:
  8765.                 default: goto illegal;
  8766.               }
  8767.           case subr_key_allow: goto illegal;
  8768.           default: goto illegal;
  8769.         }
  8770.       illegal:
  8771.         //: DEUTSCH "Unbekannter SUBR-Argumenttyp"
  8772.         //: ENGLISH "Unknown signature of a SUBR"
  8773.         //: FRANCAIS "Type d'argument inconnu pour SUBR"
  8774.         asciz_out(GETTEXT("unknown signature of a SUBR"));
  8775.         asciz_out(CRLFstring);
  8776.         quit_sofort(1);
  8777.     }
  8778.  
  8779. # Initialisierungs-Routinen für die Tabellen
  8780. # während des 1. Teils der Initialisierungsphase:
  8781.   # subr_tab initialisieren:
  8782.     local void init_subr_tab_1 (void);
  8783.     local void init_subr_tab_1()
  8784.       {
  8785.         #if defined(INIT_SUBR_TAB)
  8786.           #ifdef MAP_MEMORY_TABLES
  8787.             # Tabelle in den vorgesehenen Bereich kopieren:
  8788.             subr_tab = subr_tab_data;
  8789.           #endif
  8790.           #if !NIL_IS_CONSTANT
  8791.           # Erst noch den name-Slot initialisieren:
  8792.           { var reg1 subr_* ptr = (subr_*)&subr_tab; # subr_tab durchgehen
  8793.             #define LISPFUN  LISPFUN_E
  8794.             #include "subr.c"
  8795.             #undef LISPFUN
  8796.           }
  8797.           # und den keywords-Slot vorläufig initialisieren:
  8798.           { var reg1 subr_* ptr = (subr_*)&subr_tab; # subr_tab durchgehen
  8799.             var reg2 uintC count = subr_anz;
  8800.             dotimesC(count,subr_anz, { ptr->keywords = NIL; ptr++; });
  8801.           }
  8802.           #endif
  8803.           # Durch SPVWTABF sind schon alle Slots außer keywords und argtype
  8804.           # initialisiert.
  8805.           # Nun den argtype-Slot initialisieren:
  8806.           { var reg1 subr_* ptr = (subr_*)&subr_tab; # subr_tab durchgehen
  8807.             var reg2 uintC count;
  8808.             dotimesC(count,subr_anz,
  8809.               { ptr->argtype =
  8810.                   (uintW)subr_argtype(ptr->req_anz,ptr->opt_anz,ptr->rest_flag,ptr->key_flag);
  8811.                 ptr++;
  8812.               });
  8813.           }
  8814.         #else
  8815.           # Alle Slots außer keywords initialisieren:
  8816.           { var reg1 subr_* ptr = (subr_*)&subr_tab; # subr_tab durchgehen
  8817.             #define LISPFUN  LISPFUN_D
  8818.             #include "subr.c"
  8819.             #undef LISPFUN
  8820.           }
  8821.         #endif
  8822.         { var reg3 module_* module;
  8823.           for_modules(all_other_modules,
  8824.             { var reg1 subr_* ptr = module->stab; # subr_tab durchgehen
  8825.               var reg2 uintC count;
  8826.               dotimesC(count,*module->stab_size,
  8827.                 { ptr->argtype =
  8828.                     (uintW)subr_argtype(ptr->req_anz,ptr->opt_anz,ptr->rest_flag,ptr->key_flag);
  8829.                   ptr++;
  8830.                 });
  8831.             });
  8832.         }
  8833.         #ifdef MAP_MEMORY_TABLES
  8834.         # Andere Tabellen ebenfalls in den gemappten Bereich kopieren:
  8835.         { var reg2 subr_* newptr = (subr_*)&subr_tab;
  8836.           var reg4 module_* module;
  8837.           main_module.stab = newptr; newptr += subr_anz;
  8838.           for_modules(all_other_modules,
  8839.             { var reg1 subr_* oldptr = module->stab;
  8840.               var reg3 uintC count;
  8841.               module->stab = newptr;
  8842.               dotimesC(count,*module->stab_size, { *newptr++ = *oldptr++; } );
  8843.             });
  8844.           ASSERT(newptr == (subr_*)&subr_tab + total_subr_anz);
  8845.         }
  8846.         #endif
  8847.       }
  8848.   # symbol_tab initialisieren:
  8849.     local void init_symbol_tab_1 (void);
  8850.     local void init_symbol_tab_1()
  8851.       {
  8852.         #if defined(INIT_SYMBOL_TAB) && NIL_IS_CONSTANT
  8853.           #ifdef MAP_MEMORY_TABLES
  8854.             # Tabelle in den vorgesehenen Bereich kopieren:
  8855.             symbol_tab = symbol_tab_data;
  8856.           #endif
  8857.         #else
  8858.           #if 0 # wozu so viel Code produzieren?
  8859.             { var reg1 symbol_* ptr = (symbol_*)&symbol_tab; # symbol_tab durchgehen
  8860.               #define LISPSYM  LISPSYM_B
  8861.               #include "constsym.c"
  8862.               #undef LISPSYM
  8863.             }
  8864.           #else
  8865.             { var reg1 symbol_* ptr = (symbol_*)&symbol_tab; # symbol_tab durchgehen
  8866.               var reg2 uintC count;
  8867.               dotimesC(count,symbol_anz,
  8868.                 { ptr->GCself = symbol_tab_ptr_as_object(ptr);
  8869.                   ptr->symvalue = unbound;
  8870.                   ptr->symfunction = unbound;
  8871.                   ptr->proplist = NIL;
  8872.                   ptr->pname = NIL;
  8873.                   ptr->homepackage = NIL;
  8874.                   ptr++;
  8875.                 });
  8876.               #undef ptr_as_symbol
  8877.             }
  8878.           #endif
  8879.         #endif
  8880.       }
  8881.   # object_tab initialisieren:
  8882.     local void init_object_tab_1 (void);
  8883.     local void init_object_tab_1()
  8884.       { var reg3 module_* module;
  8885.         #if defined(INIT_OBJECT_TAB) && NIL_IS_CONSTANT # object_tab schon vorinitialisiert?
  8886.           for_modules(all_other_modules,
  8887.             { var reg1 object* ptr = module->otab; # object_tab durchgehen
  8888.               var reg2 uintC count;
  8889.               dotimesC(count,*module->otab_size, { *ptr++ = NIL; });
  8890.             });
  8891.         #else
  8892.           for_modules(all_modules,
  8893.             { var reg1 object* ptr = module->otab; # object_tab durchgehen
  8894.               var reg2 uintC count;
  8895.               dotimesC(count,*module->otab_size, { *ptr++ = NIL; });
  8896.             });
  8897.         #endif
  8898.       }
  8899.   # andere Module grob initialisieren:
  8900.     local void init_other_modules_1 (void);
  8901.     local void init_other_modules_1()
  8902.       { var reg3 module_* module;
  8903.         for_modules(all_other_modules,
  8904.           { # Pointer in der Subr-Tabelle mit NIL füllen, damit GC möglich wird:
  8905.             var reg1 subr_* ptr = module->stab;
  8906.             var reg2 uintC count;
  8907.             dotimesC(count,*module->stab_size,
  8908.               { ptr->name = NIL; ptr->keywords = NIL; ptr++; }
  8909.               );
  8910.             # Die Pointer in der Objekt-Tabelle hat init_object_tab_1() schon vorinitialisiert.
  8911.           });
  8912.       }
  8913.  
  8914. # Initialisierungs-Routinen für die Tabellen
  8915. # während des 2. Teils der Initialisierungsphase:
  8916.   # subr_tab fertig initialisieren: Keyword-Vektoren eintragen.
  8917.     local void init_subr_tab_2 (void);
  8918.     local void init_subr_tab_2()
  8919.       #if 0
  8920.         # Ich hätt's gern so einfach, aber
  8921.         # bei TURBO-C reicht der Speicher zum Compilieren nicht!
  8922.         { # subr_tab durchgehen
  8923.           var reg2 object vec;
  8924.           var reg1 object* vecptr;
  8925.           #define LISPFUN  LISPFUN_H
  8926.           #define kw(name)  *vecptr++ = S(K##name)
  8927.           #include "subr.c"
  8928.           #undef LISPFUN
  8929.           #undef kw
  8930.         }
  8931.       #else
  8932.         { # Keyword-Vektoren einzeln erzeugen:
  8933.           var reg2 object vec;
  8934.           var reg1 object* vecptr;
  8935.           # füllt ein einzelnes Keyword mehr in den Vektor ein:
  8936.             #define kw(name)  *vecptr++ = S(K##name)
  8937.           # bildet Vektor mit gegebenen Keywords:
  8938.             #define v(key_anz,keywords)  \
  8939.               vec = allocate_vector(key_anz); \
  8940.               vecptr = &TheSvector(vec)->data[0]; \
  8941.               keywords;
  8942.           # setzt den Vektor als Keyword-Vektor zum SUBR name fest:
  8943.             #define s(name)  subr_tab.D_##name.keywords = vec;
  8944.           #include "subrkw.c"
  8945.           #undef s
  8946.           #undef v
  8947.           #undef kw
  8948.         }
  8949.       #endif
  8950.   # symbol_tab zu Ende initialisieren: Printnamen und Home-Package eintragen.
  8951.     local void init_symbol_tab_2 (void);
  8952.     local void init_symbol_tab_2()
  8953.       { # Tabelle der Printnamen:
  8954.         local char* pname_table[symbol_anz] =
  8955.           {
  8956.             #define LISPSYM  LISPSYM_D
  8957.             #include "constsym.c"
  8958.             #undef LISPSYM
  8959.           };
  8960.         # Tabelle der Packages:
  8961.         enum { # Die Werte dieser Aufzählung sind der Reihe nach 0,1,2,...
  8962.                enum_lisp_index,
  8963.                enum_user_index,
  8964.                enum_system_index,
  8965.                enum_keyword_index,
  8966.                #define LISPPACK  LISPPACK_A
  8967.                #include "constpack.c"
  8968.                #undef LISPPACK
  8969.                enum_dummy_index
  8970.           };
  8971.         #define package_anz  ((uintL)enum_dummy_index)
  8972.         local uintB package_index_table[symbol_anz] =
  8973.           {
  8974.             #define LISPSYM  LISPSYM_E
  8975.             #include "constsym.c"
  8976.             #undef LISPSYM
  8977.           };
  8978.         {var reg1 object list = O(all_packages); # Liste der Packages
  8979.          # kurz nach der Initialisierung:
  8980.          # (#<PACKAGE LISP> #<PACKAGE USER> #<PACKAGE SYSTEM> #<PACKAGE KEYWORD> ...)
  8981.          var reg2 uintC count;
  8982.          dotimespC(count,package_anz, { pushSTACK(Car(list)); list = Cdr(list); });
  8983.         }
  8984.        {var reg3 symbol_* ptr = (symbol_*)&symbol_tab; # symbol_tab durchgehen
  8985.         var reg4 char** pname_ptr = &pname_table[0]; # pname_table durchgehen
  8986.         var reg5 uintB* index_ptr = &package_index_table[0]; # package_index_table durchgehen
  8987.         var reg6 uintC count;
  8988.         dotimesC(count,symbol_anz,
  8989.           { ptr->pname = make_imm_array(asciz_to_string(*pname_ptr++)); # Printnamen eintragen
  8990.            {var reg2 uintB index = *index_ptr++;
  8991.             var reg1 object* package_ = &STACK_(package_anz-1) STACKop -(uintP)index; # Pointer auf Package
  8992.             pushSTACK(symbol_tab_ptr_as_object(ptr)); # Symbol
  8993.             import(&STACK_0,package_); # erst normal importieren
  8994.             if (index == (uintB)enum_lisp_index) # in #<PACKAGE LISP> ?
  8995.               { export(&STACK_0,package_); } # ja -> auch exportieren
  8996.             Symbol_package(popSTACK()) = *package_; # und die Home-Package setzen
  8997.             ptr++;
  8998.           }});
  8999.         skipSTACK(package_anz);
  9000.       }}
  9001.   # FSUBRs/SUBRs in ihre Symbole eintragen:
  9002.     local void init_symbol_functions (void);
  9003.     local void init_symbol_functions()
  9004.       {# FSUBRs eintragen:
  9005.        {typedef struct {
  9006.                         #if defined(INIT_SUBR_TAB) && NIL_IS_CONSTANT
  9007.                           #define LISPSPECFORM LISPSPECFORM_F
  9008.                           object name;
  9009.                           #define fsubr_name(p)  (p)->name
  9010.                         #else
  9011.                           #define LISPSPECFORM LISPSPECFORM_E
  9012.                           uintL name_offset;
  9013.                           #define fsubr_name(p)  symbol_tab_ptr_as_object((char*)&symbol_tab+(p)->name_offset)
  9014.                         #endif
  9015.                         uintW req_anz;
  9016.                         uintW opt_anz;
  9017.                         uintW body_flag;
  9018.                        }
  9019.                 fsubr_data;
  9020.         local fsubr_data fsubr_data_tab[] = {
  9021.                                               #include "fsubr.c"
  9022.                                             };
  9023.         #undef LISPSPECFORM
  9024.         var reg4 fsubr_* ptr1 = (fsubr_*)&fsubr_tab; # fsubr_tab durchgehen
  9025.         var reg2 fsubr_data* ptr2 = &fsubr_data_tab[0]; # fsubr_data_tab durchgehen
  9026.         var reg5 uintC count;
  9027.         dotimesC(count,fsubr_anz,
  9028.           { var reg3 object sym = fsubr_name(ptr2);
  9029.             var reg1 object obj = allocate_fsubr();
  9030.             TheFsubr(obj)->name = sym;
  9031.             TheFsubr(obj)->argtype = fixnum((uintW)fsubr_argtype(ptr2->req_anz,ptr2->opt_anz,ptr2->body_flag));
  9032.             TheFsubr(obj)->function = type_pointer_object(machine_type,*ptr1);
  9033.             Symbol_function(sym) = obj;
  9034.             ptr1++; ptr2++;
  9035.           });
  9036.        }
  9037.        # SUBRs eintragen:
  9038.        {var reg1 subr_* ptr = (subr_*)&subr_tab; # subr_tab durchgehen
  9039.         var reg2 uintC count;
  9040.         dotimesC(count,subr_anz,
  9041.           { Symbol_function(ptr->name) = subr_tab_ptr_as_object(ptr);
  9042.             ptr++;
  9043.           });
  9044.       }}
  9045.   # Konstanten/Variablen ihre Werte zuweisen:
  9046.     local void init_symbol_values (void);
  9047.     local void init_symbol_values()
  9048.       { # Hilfsmacro: Konstante := wert+1
  9049.         #define define_constant_UL1(symbol,wert)  \
  9050.           { var reg1 object x = # wert+1 als Integer             \
  9051.               ( ((uintL)(wert) < (uintL)(bitm(oint_data_len)-1)) \
  9052.                 ? fixnum(wert+1)                                 \
  9053.                 : I_1_plus_I(UL_to_I(wert))                      \
  9054.               );                                                 \
  9055.             define_constant(symbol,x);                           \
  9056.           }
  9057.         # allgemein:
  9058.         define_constant(S(nil),S(nil));                 # NIL := NIL
  9059.         define_constant(S(t),S(t));                     # T := T
  9060.         # zu EVAL/CONTROL:
  9061.         define_constant_UL1(S(lambda_parameters_limit),lp_limit_1); # LAMBDA-PARAMETERS-LIMIT := lp_limit_1 + 1
  9062.         define_constant_UL1(S(call_arguments_limit),ca_limit_1); # CALL-ARGUMENTS-LIMIT := ca_limit_1 + 1
  9063.         define_constant(S(multiple_values_limit),       # MULTIPLE-VALUES-LIMIT
  9064.           fixnum(mv_limit));      # := mv_limit
  9065.         define_constant(S(jmpbuf_size),                 # SYS::*JMPBUF-SIZE* := Größe eines jmp_buf
  9066.           fixnum(jmpbufsize));
  9067.         define_constant(S(big_endian),(BIG_ENDIAN_P ? T : NIL)); # SYS::*BIG-ENDIAN* := NIL bzw. T
  9068.         define_variable(S(macroexpand_hook),L(pfuncall)); # *MACROEXPAND-HOOK* := #'SYS::%FUNCALL
  9069.         define_variable(S(evalhookstern),NIL);          # *EVALHOOK*
  9070.         define_variable(S(applyhookstern),NIL);         # *APPLYHOOK*
  9071.         # zu PACKAGE:
  9072.         define_variable(S(packagestern),Car(O(all_packages))); # *PACKAGE* := '#<PACKAGE LISP>
  9073.         # zu SYMBOL:
  9074.         define_variable(S(gensym_counter),Fixnum_1);    # *GENSYM-COUNTER* := 1
  9075.         # zu LISPARIT:
  9076.         init_arith(); # definiert folgende:
  9077.         # define_variable(S(pi),_EMA_);                      # PI
  9078.         # define_constant(S(most_positive_fixnum),_EMA_);    # MOST-POSITIVE-FIXNUM
  9079.         # define_constant(S(most_negative_fixnum),_EMA_);    # MOST-NEGATIVE-FIXNUM
  9080.         # define_constant(S(most_positive_short_float),_EMA_); # MOST-POSITIVE-SHORT-FLOAT
  9081.         # define_constant(S(least_positive_short_float),_EMA_); # LEAST-POSITIVE-SHORT-FLOAT
  9082.         # define_constant(S(least_negative_short_float),_EMA_); # LEAST-NEGATIVE-SHORT-FLOAT
  9083.         # define_constant(S(most_negative_short_float),_EMA_); # MOST-NEGATIVE-SHORT-FLOAT
  9084.         # define_constant(S(most_positive_single_float),_EMA_); # MOST-POSITIVE-SINGLE-FLOAT
  9085.         # define_constant(S(least_positive_single_float),_EMA_); # LEAST-POSITIVE-SINGLE-FLOAT
  9086.         # define_constant(S(least_negative_single_float),_EMA_); # LEAST-NEGATIVE-SINGLE-FLOAT
  9087.         # define_constant(S(most_negative_single_float),_EMA_); # MOST-NEGATIVE-SINGLE-FLOAT
  9088.         # define_constant(S(most_positive_double_float),_EMA_); # MOST-POSITIVE-DOUBLE-FLOAT
  9089.         # define_constant(S(least_positive_double_float),_EMA_); # LEAST-POSITIVE-DOUBLE-FLOAT
  9090.         # define_constant(S(least_negative_double_float),_EMA_); # LEAST-NEGATIVE-DOUBLE-FLOAT
  9091.         # define_constant(S(most_negative_double_float),_EMA_); # MOST-NEGATIVE-DOUBLE-FLOAT
  9092.         # define_variable(S(most_positive_long_float),_EMA_); # MOST-POSITIVE-LONG-FLOAT
  9093.         # define_variable(S(least_positive_long_float),_EMA_); # LEAST-POSITIVE-LONG-FLOAT
  9094.         # define_variable(S(least_negative_long_float),_EMA_); # LEAST-NEGATIVE-LONG-FLOAT
  9095.         # define_variable(S(most_negative_long_float),_EMA_); # MOST-NEGATIVE-LONG-FLOAT
  9096.         # define_constant(S(short_float_epsilon),_EMA_);     # SHORT-FLOAT-EPSILON
  9097.         # define_constant(S(single_float_epsilon),_EMA_);    # SINGLE-FLOAT-EPSILON
  9098.         # define_constant(S(double_float_epsilon),_EMA_);    # DOUBLE-FLOAT-EPSILON
  9099.         # define_variable(S(long_float_epsilon),_EMA_);      # LONG-FLOAT-EPSILON
  9100.         # define_constant(S(short_float_negative_epsilon),_EMA_); # SHORT-FLOAT-NEGATIVE-EPSILON
  9101.         # define_constant(S(single_float_negative_epsilon),_EMA_); # SINGLE-FLOAT-NEGATIVE-EPSILON
  9102.         # define_constant(S(double_float_negative_epsilon),_EMA_); # DOUBLE-FLOAT-NEGATIVE-EPSILON
  9103.         # define_variable(S(long_float_negative_epsilon),_EMA_); # LONG-FLOAT-NEGATIVE-EPSILON
  9104.         # define_variable(S(read_default_float_format),_EMA_); # *READ-DEFAULT-FLOAT-FORMAT*
  9105.         # define_variable(S(random_state),_EMA_);            # *RANDOM-STATE*
  9106.         # zu ARRAY:
  9107.         define_constant_UL1(S(array_total_size_limit),arraysize_limit_1); # ARRAY-TOTAL-SIZE-LIMIT := arraysize_limit_1 + 1
  9108.         define_constant_UL1(S(array_dimension_limit),arraysize_limit_1); # ARRAY-DIMENSION-LIMIT := arraysize_limit_1 + 1
  9109.         define_constant_UL1(S(array_rank_limit),arrayrank_limit_1); # ARRAY-RANK-LIMIT := arrayrank_limit_1 + 1
  9110.         # zu DEBUG:
  9111.         define_variable(S(plus),NIL);                   # +
  9112.         define_variable(S(plus2),NIL);                  # ++
  9113.         define_variable(S(plus3),NIL);                  # +++
  9114.         define_variable(S(minus),NIL);                  # -
  9115.         define_variable(S(mal),NIL);                    # *
  9116.         define_variable(S(mal2),NIL);                   # **
  9117.         define_variable(S(mal3),NIL);                   # ***
  9118.         define_variable(S(durch),NIL);                  # /
  9119.         define_variable(S(durch2),NIL);                 # //:
  9120.         define_variable(S(durch3),NIL);                 # //:/
  9121.         define_variable(S(driverstern),NIL);            # *DRIVER* := NIL
  9122.         define_variable(S(break_driver),NIL);           # *BREAK-DRIVER* := NIL
  9123.         define_variable(S(break_count),Fixnum_0);       # SYS::*BREAK-COUNT* := 0
  9124.         define_variable(S(recurse_count_standard_output),Fixnum_0); # SYS::*RECURSE-COUNT-STANDARD-OUTPUT* := 0
  9125.         define_variable(S(load_input_stream),NIL);
  9126.         # zu STREAM:
  9127.         # später: init_streamvars(); # definiert folgende:
  9128.         # define_variable(S(standard_input),_EMA_);          # *STANDARD-INPUT*
  9129.         # define_variable(S(standard_output),_EMA_);         # *STANDARD-OUTPUT*
  9130.         # define_variable(S(error_output),_EMA_);            # *ERROR-OUTPUT*
  9131.         # define_variable(S(query_io),_EMA_);                # *QUERY-IO*
  9132.         # define_variable(S(debug_io),_EMA_);                # *DEBUG-IO*
  9133.         # define_variable(S(terminal_io),_EMA_);             # *TERMINAL-IO*
  9134.         # define_variable(S(trace_output),_EMA_);            # *TRACE-OUTPUT*
  9135.         # define_variable(S(keyboard_input),_EMA_);          # *KEYBOARD-INPUT*
  9136.         define_variable(S(default_pathname_defaults),unbound); # *DEFAULT-PATHNAME-DEFAULTS*
  9137.         define_variable(S(read_pathname_p),NIL);
  9138.         # zu IO:
  9139.         init_reader(); # definiert folgende:
  9140.         # define_variable(S(read_base),_EMA_);               # *READ-BASE* := 10
  9141.         # define_variable(S(read_suppress),_EMA_);           # *READ-SUPPRESS* := NIL
  9142.         # define_variable(S(readtablestern),_EMA_);          # *READTABLE*
  9143.         define_variable(S(read_preserve_whitespace),unbound); # SYS::*READ-PRESERVE-WHITESPACE*
  9144.         define_variable(S(read_recursive_p),unbound);   # SYS::*READ-RECURSIVE-P*
  9145.         define_variable(S(read_reference_table),unbound); # SYS::*READ-REFERENCE-TABLE*
  9146.         define_variable(S(backquote_level),unbound);    # SYS::*BACKQUOTE-LEVEL*
  9147.         define_variable(S(compiling),NIL);              # SYS::*COMPILING* ;= NIL
  9148.         define_variable(S(print_case),S(Kupcase));      # *PRINT-CASE* := :UPCASE
  9149.         define_variable(S(print_level),NIL);            # *PRINT-LEVEL* := NIL
  9150.         define_variable(S(print_length),NIL);           # *PRINT-LENGTH* := NIL
  9151.         define_variable(S(print_gensym),T);             # *PRINT-GENSYM* := T
  9152.         define_variable(S(print_escape),T);             # *PRINT-ESCAPE* := T
  9153.         define_variable(S(print_radix),NIL);            # *PRINT-RADIX* := NIL
  9154.         define_variable(S(print_base),fixnum(10));      # *PRINT-BASE* := 10
  9155.         define_variable(S(print_array),T);              # *PRINT-ARRAY* := T
  9156.         define_variable(S(print_circle),NIL);           # *PRINT-CIRCLE* := NIL
  9157.         define_variable(S(print_pretty),NIL);           # *PRINT-PRETTY* := NIL
  9158.         define_variable(S(print_closure),NIL);          # *PRINT-CLOSURE* := NIL
  9159.         define_variable(S(print_readably),NIL);         # *PRINT-READABLY* := NIL
  9160.         define_variable(S(print_rpars),T);              # *PRINT-RPARS* := T
  9161.         define_variable(S(print_indent_lists),fixnum(2)); # *PRINT-INDENT-LISTS* := 2
  9162.         define_variable(S(print_circle_table),unbound); # SYS::*PRINT-CIRCLE-TABLE*
  9163.         define_variable(S(prin_level),unbound);         # SYS::*PRIN-LEVEL*
  9164.         define_variable(S(prin_stream),unbound);        # SYS::*PRIN-STREAM*
  9165.         define_variable(S(prin_linelength),fixnum(79)); # SYS::*PRIN-LINELENGTH* := 79 (vorläufig)
  9166.         define_variable(S(prin_l1),unbound);            # SYS::*PRIN-L1*
  9167.         define_variable(S(prin_lm),unbound);            # SYS::*PRIN-LM*
  9168.         define_variable(S(prin_rpar),unbound);          # SYS::*PRIN-RPAR*
  9169.         define_variable(S(prin_jblocks),unbound);       # SYS::*PRIN-JBLOCKS*
  9170.         define_variable(S(prin_jbstrings),unbound);     # SYS::*PRIN-JBSTRINGS*
  9171.         define_variable(S(prin_jbmodus),unbound);       # SYS::*PRIN-JBMODUS*
  9172.         define_variable(S(prin_jblpos),unbound);        # SYS::*PRIN-JBLPOS*
  9173.         # zu EVAL:
  9174.         define_variable(S(evalhookstern),NIL);          # *EVALHOOK* := NIL
  9175.         define_variable(S(applyhookstern),NIL);         # *APPLYHOOK* := NIL
  9176.         # zu MISC:
  9177.         define_constant(S(internal_time_units_per_second),  # INTERNAL-TIME-UNITS-PER-SECOND
  9178.           fixnum(ticks_per_second) ); # := 200 bzw. 1000000
  9179.         # zu ERROR:
  9180.         define_variable(S(use_clcs),NIL);               # SYS::*USE-CLCS* := NIL
  9181.         define_variable(S(recursive_error_count),Fixnum_0); # SYS::*RECURSIVE-ERROR-COUNT* := 0
  9182.         define_variable(S(error_handler),NIL);          # *ERROR-HANDLER* := NIL
  9183.         # zu SPVW:
  9184.         define_variable(S(init_hooks),NIL);             # SYS::*INIT-HOOKS* := NIL
  9185.         define_variable(S(quiet),NIL);                  # SYS::*QUIET* := NIL
  9186.         # zu FOREIGN:
  9187.         #ifdef DYNAMIC_FFI
  9188.         define_constant(S(fv_flag_readonly),fixnum(fv_readonly));  # FFI::FV-FLAG-READONLY
  9189.         define_constant(S(fv_flag_malloc_free),fixnum(fv_malloc)); # FFI::FV-FLAG-MALLOC-FREE
  9190.         define_constant(S(ff_flag_alloca),fixnum(ff_alloca));      # FFI::FF-FLAG-ALLOCA
  9191.         define_constant(S(ff_flag_malloc_free),fixnum(ff_malloc)); # FFI::FF-FLAG-MALLOC-FREE
  9192.         define_constant(S(ff_flag_out),fixnum(ff_out));            # FFI::FF-FLAG-OUT
  9193.         define_constant(S(ff_flag_in_out),fixnum(ff_inout));       # FFI::FF-FLAG-IN-OUT
  9194.         define_constant(S(ff_language_asm),fixnum(ff_lang_asm));       # FFI::FF-LANGUAGE-ASM
  9195.         define_constant(S(ff_language_c),fixnum(ff_lang_c));           # FFI::FF-LANGUAGE-C
  9196.         define_constant(S(ff_language_ansi_c),fixnum(ff_lang_ansi_c)); # FFI::FF-LANGUAGE-ANSI-C
  9197.         #endif
  9198.         # zu PATHNAME:
  9199.         #ifdef LOGICAL_PATHNAMES
  9200.         { # SYS::*LOGICAL-PATHNAME-TRANSLATIONS* := (MAKE-HASH-TABLE :TEST #'EQUAL)
  9201.           pushSTACK(S(Ktest)); pushSTACK(L(equal)); funcall(L(make_hash_table),2);
  9202.           define_variable(S(logpathname_translations),value1);
  9203.         }
  9204.         O(empty_logical_pathname) = allocate_logpathname();
  9205.         #endif
  9206.         # *DEFAULT-PATHNAME-DEFAULTS* vorläufig initialisieren:
  9207.         define_variable(S(default_pathname_defaults),allocate_pathname());
  9208.         #undef define_constant_UL1
  9209.       }
  9210.   # sonstige Objekte kreieren und Objekttabelle füllen:
  9211.     local void init_object_tab (void);
  9212.     local void init_object_tab()
  9213.       { # Tabelle mit Initialisierungsstrings:
  9214.         local var char* object_initstring_tab []
  9215.           = {
  9216.              #define LISPOBJ LISPOBJ_C
  9217.              #include "constobj.c"
  9218.              #undef LISPOBJ
  9219.             };
  9220.         # *FEATURES* initialisieren:
  9221.         { var reg2 char* features_initstring =
  9222.             "(CLISP CLTL1 COMMON-LISP INTERPRETER"
  9223.             #ifdef FAST_SP
  9224.               " SYSTEM::CLISP2"
  9225.             #else
  9226.               " SYSTEM::CLISP3"
  9227.             #endif
  9228.             #ifdef LOGICAL_PATHNAMES
  9229.               " LOGICAL-PATHNAMES"
  9230.             #endif
  9231.             #ifdef DYNAMIC_FFI
  9232.               " FFI"
  9233.             #endif
  9234.             #ifdef ENABLE_NLS
  9235.               " NLS"
  9236.             #endif
  9237.             #ifdef AMIGA
  9238.               " AMIGA"
  9239.             #endif
  9240.             #ifdef SUN3
  9241.               " SUN3"
  9242.             #endif
  9243.             #ifdef SUN386
  9244.               " SUN386"
  9245.             #endif
  9246.             #ifdef SUN4
  9247.               " SUN4"
  9248.             #endif
  9249.             #ifdef PC386
  9250.               " PC386"
  9251.             #endif
  9252.             #ifdef MSDOS
  9253.              #ifdef OS2
  9254.               " OS/2"
  9255.              #else
  9256.               " DOS"
  9257.              #endif
  9258.             #endif
  9259.             #ifdef WIN32_DOS
  9260.              " WIN32-DOS"
  9261.             #endif
  9262.             #ifdef WIN32_UNIX
  9263.                 " WIN32-UNIX"
  9264.             #endif
  9265.             #ifdef RISCOS
  9266.               " ACORN-RISCOS"
  9267.             #endif
  9268.             #ifdef UNIX
  9269.               " UNIX"
  9270.             #endif
  9271.             ")"
  9272.             ;
  9273.           pushSTACK(asciz_to_string(features_initstring));
  9274.          {var reg1 object list = (funcall(L(read_from_string),1), value1);
  9275.           define_variable(S(features),list);             # *FEATURES*
  9276.         }}
  9277.         # Objekte aus den Strings lesen:
  9278.         { var reg1 object* objptr = (object*)&object_tab; # object_tab durchgehen
  9279.           var reg2 char** stringptr = &object_initstring_tab[0]; # Stringtabelle durchgehen
  9280.           var reg3 uintC count;
  9281.           dotimesC(count,object_anz,
  9282.             { pushSTACK(asciz_to_string(*stringptr++)); # String
  9283.               funcall(L(make_string_input_stream),1); # in Stream verpacken
  9284.               pushSTACK(value1);
  9285.              {var reg4 object obj = read(&STACK_0,NIL,NIL); # Objekt lesen
  9286.               skipSTACK(1);
  9287.               if (!eq(obj,dot_value)) { *objptr = obj; } # und eintragen (außer ".")
  9288.               objptr++;
  9289.             }});
  9290.         }
  9291.         TheSstring(O(null_string))->data[0] = 0; # Nullbyte in den Null-String einfügen
  9292.         Car(O(top_decl_env)) = O(declaration_types); # Toplevel-Deklarations-Environment bauen
  9293.       }
  9294.  
  9295.     #ifdef DYNBIND_LIST
  9296.     local void init_dynbind_list (void);
  9297.     local void init_dynbind_list()
  9298.       {
  9299.         define_variable(S(dynamic_and_special_frames),NIL);
  9300.         define_variable(S(dynamic_bindings),NIL);
  9301.         define_variable(S(special_bindings),NIL);
  9302.         define_variable(S(transitions_to_dynamic_bindings),NIL);
  9303.         define_variable(S(transitions_to_special_bindings),NIL);
  9304.       }
  9305.     #endif
  9306.  
  9307.     local void init_derived_strings (void);
  9308.     local void init_derived_strings()
  9309.       {
  9310.         pushSTACK(O(lisp_implementation_version_date_string));
  9311.         pushSTACK(O(space_string));
  9312.         pushSTACK(O(left_paren_string));
  9313.         pushSTACK(OL(lisp_implementation_version_month_string));
  9314.         pushSTACK(O(space_string));
  9315.         pushSTACK(O(lisp_implementation_version_year_string));
  9316.         pushSTACK(O(right_paren_string));          
  9317.         define_variable(S(lisp_implementation_version_string),string_concat(7));
  9318.         pushSTACK(OL(c_compiler_version_string));
  9319.         pushSTACK(O(space_string));
  9320.         pushSTACK(O(c_compiler_version_number_string));
  9321.         define_variable(S(software_version_string),string_concat(3));
  9322.       }
  9323.  
  9324.   # Zu-Fuß-Initialisierung aller LISP-Daten:
  9325.     local void initmem (void);
  9326.     local void initmem()
  9327.       { init_symbol_tab_1(); # symbol_tab initialisieren
  9328.         init_object_tab_1(); # object_tab initialisieren
  9329.         init_other_modules_1(); # andere Module grob initialisieren
  9330.         # Jetzt sind die Tabellen erst einmal grob initialisiert, bei GC
  9331.         # kann nichts passieren.
  9332.         # subr_tab fertig initialisieren:
  9333.         init_subr_tab_2();
  9334.         # Packages initialisieren:
  9335.         init_packages();
  9336.         # symbol_tab fertig initialisieren:
  9337.         init_symbol_tab_2();
  9338.         # SUBRs/FSUBRs in ihre Symbole eintragen:
  9339.         init_symbol_functions();
  9340.         # Konstanten/Variablen: Wert in die Symbole eintragen:
  9341.         init_symbol_values();
  9342.         # sonstige Objekte kreieren:
  9343.         #ifdef DYNBIND_LIST
  9344.         init_dynbind_list();
  9345.         #endif
  9346.         init_object_tab();
  9347.       }
  9348.  
  9349.     local void err_module_needs_package (const char *module_name,const char *package_name);
  9350.     local void err_module_needs_package (module_name,package_name)
  9351.       var const char *module_name;
  9352.       var const char *package_name;
  9353.       {
  9354.         //: DEUTSCH "Modul `"
  9355.         //: ENGLISH "module `"
  9356.         //: FRANCAIS "Pas de module «"
  9357.         asciz_out(GETTEXT("module"));
  9358.         asciz_out(module_name);
  9359.         //: DEUTSCH "' benötigt Package "
  9360.         //: ENGLISH "' requires package "
  9361.         //: FRANCAIS "» sans le paquetage "
  9362.         asciz_out(GETTEXT("requires package"));
  9363.         asciz_out(package_name);
  9364.         //: DEUTSCH "."
  9365.         //: ENGLISH "."
  9366.         //: FRANCAIS "."
  9367.         asciz_out(GETTEXT("[end]requires package"));
  9368.         asciz_out(CRLFstring);
  9369.       }
  9370.  
  9371.   # Laden vom MEM-File:
  9372.     local void loadmem (char* filename); # siehe unten
  9373.   # Initialiserung der anderen, noch nicht initialisierten Module:
  9374.     local void init_other_modules_2 (void);
  9375.     local void init_other_modules_2()
  9376.       { var reg5 module_* module; # modules durchgehen
  9377.         for_modules(all_other_modules,
  9378.           { if (!module->initialized)
  9379.               { # Objekt-Tabelle mit NIL füllen, damit GC möglich wird:
  9380.                 var reg1 object* object_ptr = module->otab;
  9381.                 var reg2 uintC count;
  9382.                 dotimesC(count,*module->otab_size, { *object_ptr++ = NIL; } );
  9383.               }
  9384.           });
  9385.       }
  9386.     local void init_other_modules_3 (void);
  9387.     local void init_other_modules_3()
  9388.       { var reg7 module_* module; # modules durchgehen
  9389.         for_modules(all_other_modules,
  9390.           { if (!module->initialized)
  9391.               { # Subr-Symbole eintragen:
  9392.                 { var reg2 subr_* subr_ptr = module->stab;
  9393.                   var reg1 subr_initdata* init_ptr = module->stab_initdata;
  9394.                   var reg3 uintC count;
  9395.                   dotimesC(count,*module->stab_size,
  9396.                     { var reg5 char* packname = init_ptr->packname;
  9397.                       var reg6 object symname = asciz_to_string(init_ptr->symname);
  9398.                       var object symbol;
  9399.                       if (packname==NULL)
  9400.                         { symbol = make_symbol(symname); }
  9401.                         else
  9402.                         { var reg4 object pack = find_package(asciz_to_string(packname));
  9403.                           if (nullp(pack)) # Package nicht gefunden?
  9404.                             { err_module_needs_package(module->name,packname);
  9405.                               quit_sofort(1);
  9406.                             }
  9407.                           intern(symname,pack,&symbol);
  9408.                         }
  9409.                       subr_ptr->name = symbol; # Subr komplett machen
  9410.                       Symbol_function(symbol) = subr_tab_ptr_as_object(subr_ptr); # Funktion definieren
  9411.                       init_ptr++; subr_ptr++;
  9412.                     });
  9413.                 }
  9414.                 # Objekte eintragen:
  9415.                 { var reg2 object* object_ptr = module->otab;
  9416.                   var reg1 object_initdata* init_ptr = module->otab_initdata;
  9417.                   var reg3 uintC count;
  9418.                   dotimesC(count,*module->otab_size,
  9419.                     { pushSTACK(asciz_to_string(init_ptr->initstring)); # String
  9420.                       funcall(L(make_string_input_stream),1); # in Stream verpacken
  9421.                       pushSTACK(value1);
  9422.                       *object_ptr = read(&STACK_0,NIL,NIL); # Objekt lesen
  9423.                       skipSTACK(1);
  9424.                       object_ptr++; init_ptr++;
  9425.                     });
  9426.                 }
  9427.                 # Initialisierungsfunktion aufrufen:
  9428.                 (*module->initfunction1)(module);
  9429.               }
  9430.           });
  9431.       }
  9432.  
  9433. #ifdef AMIGAOS
  9434.  
  9435.   # Diese beiden Variablen werden, wenn man Glück hat, vom Startup-System
  9436.   # (von dem main() aufgerufen wird) sinnvoll vorbesetzt:
  9437.   global Handle Input_handle = Handle_NULL;    # low-level stdin Eingabekanal
  9438.   global Handle Output_handle = Handle_NULL;   # low-level stdout Ausgabekanal
  9439.  
  9440.   global BPTR orig_dir_lock = BPTR_NONE; # das Current Directory beim Programmstart
  9441.   # wird verwendet von PATHNAME
  9442.  
  9443.   # Initialisierung, ganz zuerst in main() durchzuführen:
  9444.     local void init_amiga (void);
  9445.     local void init_amiga()
  9446.       {
  9447.         cpu_is_68000 = ((SysBase->AttnFlags & (AFF_68020|AFF_68030|AFF_68040)) == 0);
  9448.         #ifdef MC68000
  9449.         # Diese Version benötigt einen 68000. (Wegen addressbus_mask.)
  9450.         if (!cpu_is_68000)
  9451.           { exit(RETURN_FAIL); }
  9452.         #endif
  9453.         #ifdef MC680Y0
  9454.         # Diese Version benötigt mindestens einen 68020, läuft nicht auf 68000.
  9455.         # (Wegen ari68020.d, einiger asm()s und wegen gcc-Option -m68020.)
  9456.         if (cpu_is_68000)
  9457.           { exit(RETURN_FAIL); }
  9458.         #endif
  9459.         # Wir wollen uns nicht mehr mit OS Version 1.x beschäftigen
  9460.     if (SysBase->LibNode.lib_Version < 36) { exit(RETURN_FAIL); }
  9461.         if (Input_handle==Handle_NULL) { Input_handle = Input(); }
  9462.         if (Output_handle==Handle_NULL) { Output_handle = Output(); }
  9463.         # Abfrage, ob Workbench-Aufruf ohne besonderen Startup:
  9464.         if ((Input_handle==Handle_NULL) || (Output_handle==Handle_NULL))
  9465.           { exit(RETURN_FAIL); }
  9466.         # Benutzter Speicher muß in [0..2^oint_addr_len-1] liegen:
  9467.         if (!(pointable_usable_test((aint)&init_amiga) # Code-Segment überprüfen
  9468.               && pointable_usable_test((aint)&symbol_tab) # Daten-Segment überprüfen
  9469.            ) )
  9470.           { 
  9471.             //: DEUTSCH "Diese CLISP-Version muß in Speicher mit niedrigen Adressen ablaufen."
  9472.             //: ENGLISH "This version of CLISP runs only in low address memory."
  9473.             //: FRANCAIS "Cette version de CLISP ne marche qu'en mémoire à adresse basse."
  9474.             asciz_out(GETTEXT("this version of CLISP runs only in low address memory"));
  9475.             asciz_out(CRLFstring);
  9476.             asciz_out("CODE: "); hex_out((aint)&init_amiga);
  9477.             asciz_out(", DATA: "); hex_out((aint)&symbol_tab);
  9478.             asciz_out("." CRLFstring);
  9479.             exit(RETURN_FAIL);
  9480.           }
  9481.         #if !(defined(WIDE) || defined(MC68000))
  9482.         # Ein Flag, das uns hilft, Speicher mit niedrigen Adressen zu bekommen:
  9483.         retry_allocmemflag =
  9484.           (CPU_IS_68000              # der 68000 hat nur 24 Bit Adreßbereich,
  9485.            ? MEMF_ANY                # nie ein zweiter Versuch nötig
  9486.            : MEMF_24BITDMA           # sonst Flag MEMF_24BITDMA
  9487.           );
  9488.         #endif
  9489.       }
  9490.  
  9491.   # Rückgabe aller Ressourcen und Programmende:
  9492.   nonreturning_function(local, exit_amiga, (sintL code));
  9493.   local void exit_amiga(code)
  9494.     var reg3 sintL code;
  9495.     { begin_system_call();
  9496.       # Zurück ins Verzeichnis, in das wir beim Programmstart waren:
  9497.       if (!(orig_dir_lock == BPTR_NONE)) # haben wir das Verzeichnis je gewechselt?
  9498.         { var reg1 BPTR lock = CurrentDir(orig_dir_lock); # zurück ins alte
  9499.           UnLock(lock); # dieses nun freigeben
  9500.         }
  9501.       # Speicher freigeben:
  9502.       { var reg1 MemBlockHeader* memblocks = allocmemblocks;
  9503.         until (memblocks==NULL)
  9504.           { var reg2 MemBlockHeader* next = memblocks->next;
  9505.             FreeMem(memblocks,memblocks->size);
  9506.             memblocks = next;
  9507.       }   }
  9508.       # Programmende:
  9509.       exit(code);
  9510.     }
  9511.  
  9512. #endif
  9513.  
  9514. # Hauptprogramm trägt den Namen 'main'.
  9515.   #ifdef NEXTAPP
  9516.     # main() existiert schon in Lisp_main.m
  9517.     #define main  clisp_main
  9518.   #endif
  9519.   #if defined(EMUNIX) && defined(WINDOWS)
  9520.     # main() existiert bereits in libwin.a
  9521.     #define main  clisp_main
  9522.   #endif
  9523.   #ifndef argc_t
  9524.     #define argc_t int  # Typ von argc ist meist 'int'.
  9525.   #endif
  9526.   global int main (argc_t argc, char* argv[]);
  9527.   local boolean argv_quiet = FALSE; # ob beim Start Quiet-Option angegeben
  9528.   global int main(argc,argv)
  9529.     var reg1 argc_t argc;
  9530.     var reg1 char* * argv;
  9531.     { # Initialisierung der Speicherverwaltung.
  9532.       # Gesamtvorgehen:
  9533.       # Command-Line-Argumente verarbeiten.
  9534.       # Speicheraufteilung bestimmen.
  9535.       # Commandstring anschauen und entweder LISP-Daten vom .MEM-File
  9536.       #   laden oder zu Fuß erzeugen und statische LISP-Daten initialisieren.
  9537.       # Interrupt-Handler aufbauen.
  9538.       # Begrüßung ausgeben.
  9539.       # In den Driver springen.
  9540.       #
  9541.       #ifdef AMIGAOS
  9542.       init_amiga();
  9543.       #endif
  9544.       #ifdef EMUNIX
  9545.       # Wildcards und Response-Files in der Kommandozeile expandieren:
  9546.       _response(&argc,&argv);
  9547.       _wildcard(&argc,&argv);
  9548.       #endif
  9549.       #ifdef DJUNIX
  9550.       # Ctrl-Break verbieten, so weit es geht:
  9551.       local var int cbrk;
  9552.       cbrk = getcbrk();
  9553.       if (cbrk) { setcbrk(0); }
  9554.       # Ctrl-Break wollen wir abfangen:
  9555.       _go32_want_ctrl_break(1);
  9556.       #endif
  9557.       #ifdef WIN32_DOS
  9558.       # Auf stdin und stdout im Text-Modus zugreifen:
  9559.       begin_system_call();
  9560.       setmode(stdin_handle,O_TEXT);
  9561.       setmode(stdout_handle,O_TEXT);
  9562.       end_system_call();
  9563.       #endif
  9564.       #ifdef RISCOS
  9565.       # Disable UnixLib's automatic name munging:
  9566.       __uname_control = 1;
  9567.       #endif
  9568.       #if defined(UNIX) || defined(WIN32_UNIX)
  9569.       user_uid = getuid();
  9570.       #ifdef GRAPHICS_SWITCH
  9571.       # Programm muß mit "setuid root"-Privileg installiert werden:
  9572.       # (chown root, chmod 4755). Vom root-Privileg befreien wir uns so schnell
  9573.       # wie möglich - sicherheitshalber.
  9574.       { extern uid_t root_uid;
  9575.         root_uid = geteuid();
  9576.         setreuid(root_uid,user_uid);
  9577.       }
  9578.       #endif
  9579.       find_executable(argv[0]);
  9580.       #endif
  9581.      {var uintL argv_memneed = 0;
  9582.       #ifndef NO_SP_MALLOC
  9583.       var uintL argv_stackneed = 0;
  9584.       #endif
  9585.       #ifdef MULTIMAP_MEMORY_VIA_FILE
  9586.       var local char* argv_tmpdir = NULL;
  9587.       #endif
  9588.       var local char* argv_memfile = NULL;
  9589.       var local uintL argv_init_filecount = 0;
  9590.       var local char** argv_init_files;
  9591.       var local boolean argv_compile = FALSE;
  9592.       var local boolean argv_compile_listing = FALSE;
  9593.       var local uintL argv_compile_filecount = 0;
  9594.       typedef struct { char* input_file; char* output_file; } argv_compile_file;
  9595.       var local argv_compile_file* argv_compile_files;
  9596.       var local char* argv_package = NULL;
  9597.       var local char* argv_expr = NULL;
  9598.       var local char* argv_language = NULL;
  9599.       var local char* argv_localedir = NULL;
  9600.       {var DYNAMIC_ARRAY(,argv_init_files_array,char*,(uintL)argc); # maximal argc Init-Files
  9601.        argv_init_files = argv_init_files_array;
  9602.       {var DYNAMIC_ARRAY(,argv_compile_files_array,argv_compile_file,(uintL)argc); # maximal argc File-Argumente
  9603.        argv_compile_files = argv_compile_files_array;
  9604.       if (!(setjmp(&!original_context) == 0)) goto end_of_main;
  9605.       # Argumente argv[0..argc-1] abarbeiten:
  9606.       #   -h              Help
  9607.       #   -m size         Memory size (size = xxxxxxxB oder xxxxKB oder xMB)
  9608.       #   -s size         Stack size (size = xxxxxxxB oder xxxxKB oder xMB)
  9609.       #   -t directory    temporäres Directory
  9610.       #   -M file         MEM-File laden
  9611.       #   -L language     sets the user language
  9612.       #   -q              quiet: keine Copyright-Meldung
  9613.       #   -I              ILISP-freundlich
  9614.       #   -i file ...     LISP-File zur Initialisierung laden
  9615.       #   -c file ...     LISP-Files compilieren, dann LISP verlassen
  9616.       #   -l              Beim Compilieren: Listings anlegen
  9617.       #   -p package      *PACKAGE* setzen
  9618.       #   -x expr         LISP-Expressions ausführen, dann LISP verlassen
  9619.       program_name = argv[0]; # argv[0] ist der Programmname
  9620.       if (FALSE)
  9621.         { usage:
  9622.           //: DEUTSCH "Usage:  "
  9623.           //: ENGLISH "Usage:  "
  9624.           //: FRANCAIS "Usage:  "
  9625.           asciz_out(GETTEXT("Usage:  "));
  9626.           asciz_out(program_name);
  9627.           asciz_out(" [-h] [-m memsize]");
  9628.           #ifndef NO_SP_MALLOC
  9629.           asciz_out(" [-s stacksize]");
  9630.           #endif
  9631.           #ifdef MULTIMAP_MEMORY_VIA_FILE
  9632.           asciz_out(" [-t tmpdir]");
  9633.           #endif
  9634.           asciz_out(" [-M memfile] [-L language] [-q] [-I] [-i initfile ...]"
  9635.                     " [-c [-l] lispfile [-o outputfile] ...] [-p packagename]"
  9636.                     " [-x expression]" CRLFstring);
  9637.           quit_sofort(1); # anormales Programmende
  9638.         }
  9639.      {var reg2 char** argptr = &argv[1];
  9640.       var reg3 char** argptr_limit = &argv[argc];
  9641.       var reg5 enum { illegal, for_init, for_compile } argv_for = illegal;
  9642.       # Durchlaufen und Optionen abarbeiten, alles Abgearbeitete durch NULL
  9643.       # ersetzen:
  9644.       while (argptr < argptr_limit)
  9645.         { var reg1 char* arg = *argptr++; # nächstes Argument
  9646.           if (arg[0] == '-')
  9647.             { switch (arg[1])
  9648.                 { case 'h': # Help
  9649.                     goto usage;
  9650.                   # Liefert nach einem einbuchstabigen Kürzel den Rest der
  9651.                   # Option in arg. Evtl. Space wird übergangen.
  9652.                   #define OPTION_ARG  \
  9653.                     if (arg[2] == '\0') \
  9654.                       { if (argptr < argptr_limit) arg = *argptr++; else goto usage; } \
  9655.                       else { arg = &arg[2]; }
  9656.                   # Parst den Rest einer Option, die eine Byte-Größe angibt.
  9657.                   # Überprüft auch, ob gewisse Grenzen eingehalten werden.
  9658.                   #define SIZE_ARG(docstring,sizevar,limit_low,limit_high)  \
  9659.                     # arg sollte aus einigen Dezimalstellen, dann   \
  9660.                     # evtl. K oder M, dann evtl. B oder W bestehen. \
  9661.                     {var reg4 uintL val = 0;                        \
  9662.                      while ((*arg >= '0') && (*arg <= '9'))         \
  9663.                        { val = 10*val + (uintL)(*arg++ - '0'); }    \
  9664.                      switch (*arg)                                  \
  9665.                        { case 'k': case 'K': # Angabe in Kilobytes  \
  9666.                            val = val * 1024; arg++; break;          \
  9667.                          case 'm': case 'M': # Angabe in Megabytes  \
  9668.                            val = val * 1024*1024; arg++; break;     \
  9669.                        }                                            \
  9670.                      switch (*arg)                                  \
  9671.                        { case 'w': case 'W': # Angabe in Worten     \
  9672.                            val = val * sizeof(object);              \
  9673.                          case 'b': case 'B': # Angabe in Bytes      \
  9674.                            arg++; break;                            \
  9675.                        }                                            \
  9676.                      if (!(*arg == '\0')) # Argument zu Ende?       \
  9677.                        {                                            \
  9678.                          asciz_out("Syntax for ");                  \
  9679.                          asciz_out(docstring);                      \
  9680.                          asciz_out(": nnnnnnn or nnnnKB or nMB");   \
  9681.                          asciz_out(CRLFstring);                     \
  9682.                          goto usage;                                \
  9683.                        }                                            \
  9684.                      if (!((val >= limit_low) && (val <= limit_high))) \
  9685.                        { asciz_out(docstring);                      \
  9686.                          asciz_out(" out of range");       \
  9687.                          asciz_out(CRLFstring);                     \
  9688.                          goto usage;                                \
  9689.                        }                                            \
  9690.                      # Bei mehreren -m bzw. -s Argumenten zählt nur das letzte. \
  9691.                      sizevar = val;                                 \
  9692.                     }
  9693.                   case 'm': # Memory size
  9694.                     OPTION_ARG
  9695.                     //: DEUTSCH "memory size"
  9696.                     //: ENGLISH "memory size"
  9697.                     //: FRANCAIS "memory size"
  9698.                     SIZE_ARG(GETTEXT("memory size"),argv_memneed,100000,
  9699.                              (oint_addr_len+addr_shift < intLsize-1 # memory size begrenzt durch
  9700.                               ? bitm(oint_addr_len+addr_shift)      # Adreßraum in oint_addr_len+addr_shift Bits
  9701.                               : (uintL)bit(intLsize-1)-1            # (bzw. große Dummy-Grenze)
  9702.                             ))
  9703.                     break;
  9704.                   #ifndef NO_SP_MALLOC
  9705.                   case 's': # Stack size
  9706.                     OPTION_ARG
  9707.                     //: DEUTSCH "stack size"
  9708.                     //: ENGLISH "stack size"
  9709.                     //: FRANCAIS "stack size"
  9710.                     SIZE_ARG(GETTEXT("stack size"),argv_stackneed,40000,8*1024*1024)
  9711.                     break;
  9712.                   #endif
  9713.                   #ifdef MULTIMAP_MEMORY_VIA_FILE
  9714.                   case 't': # temporäres Directory
  9715.                     OPTION_ARG
  9716.                     if (!(argv_tmpdir == NULL)) goto usage;
  9717.                     argv_tmpdir = arg;
  9718.                     break;
  9719.                   #endif
  9720.                   case 'M': # MEM-File
  9721.                     OPTION_ARG
  9722.                     # Bei mehreren -M Argumenten zählt nur das letzte.
  9723.                     argv_memfile = arg;
  9724.                     break;
  9725.                   case 'L': # Language
  9726.                     OPTION_ARG
  9727.                     # Bei mehreren -L Argumenten zählt nur das letzte.
  9728.                     argv_language = arg;
  9729.                     break;
  9730.                   #ifdef ENABLE_NLS
  9731.                   case 'N': # NLS MO path
  9732.                     OPTION_ARG
  9733.                     argv_localedir = arg;
  9734.                     break;
  9735.                   #endif
  9736.                   case 'q': # keine Copyright-Meldung
  9737.                     argv_quiet = TRUE;
  9738.                     if (!(arg[2] == '\0')) goto usage;
  9739.                     break;
  9740.                   case 'I': # ILISP-freundlich
  9741.                     ilisp_mode = TRUE;
  9742.                     if (!(arg[2] == '\0')) goto usage;
  9743.                     break;
  9744.                   case 'i': # Initialisierungs-Files
  9745.                     argv_for = for_init;
  9746.                     if (!(arg[2] == '\0')) goto usage;
  9747.                     break;
  9748.                   case 'c': # Zu compilierende Files
  9749.                     argv_compile = TRUE;
  9750.                     argv_for = for_compile;
  9751.                     if (arg[2] == 'l')
  9752.                       { argv_compile_listing = TRUE;
  9753.                         if (!(arg[3] == '\0')) goto usage;
  9754.                       }
  9755.                       else
  9756.                       { if (!(arg[2] == '\0')) goto usage; }
  9757.                     break;
  9758.                   case 'l': # Compilate und Listings
  9759.                     argv_compile_listing = TRUE;
  9760.                     if (!(arg[2] == '\0')) goto usage;
  9761.                     break;
  9762.                   case 'o': # Ziel für zu compilierendes File
  9763.                     if (!(arg[2] == '\0')) goto usage;
  9764.                     OPTION_ARG
  9765.                     if (!((argv_compile_filecount > 0) && (argv_compile_files[argv_compile_filecount-1].output_file==NULL))) goto usage;
  9766.                     argv_compile_files[argv_compile_filecount-1].output_file = arg;
  9767.                     break;
  9768.                   case 'p': # Package
  9769.                     OPTION_ARG
  9770.                     # Bei mehreren -p Argumenten zählt nur das letzte.
  9771.                     argv_package = arg;
  9772.                     break;
  9773.                   case 'x': # LISP-Expression ausführen
  9774.                     OPTION_ARG
  9775.                     if (!(argv_expr == NULL)) goto usage;
  9776.                     argv_expr = arg;
  9777.                     break;
  9778.                   case '-': # -- Optionen im GNU-Stil
  9779.                     if (asciz_equal(&arg[2],"help"))
  9780.                       goto usage;
  9781.                     elif (asciz_equal(&arg[2],"version"))
  9782.                       { if (!(argv_expr == NULL)) goto usage;
  9783.                         argv_quiet = TRUE;
  9784.                         argv_expr = "(PROGN (FORMAT T \"CLISP ~A\" (LISP-IMPLEMENTATION-VERSION)) (EXIT))";
  9785.                         break;
  9786.                       }
  9787.                     elif (asciz_equal(&arg[2],"quiet") || asciz_equal(&arg[2],"silent"))
  9788.                       { argv_quiet = TRUE; break; }
  9789.                     else
  9790.                       goto usage; # Unbekannte Option
  9791.                     break;
  9792.                   default: # Unbekannte Option
  9793.                     goto usage;
  9794.             }   }
  9795.             else
  9796.             # keine Option,
  9797.             # wird als zu ladendes / zu compilerendes File interpretiert
  9798.             { switch (argv_for)
  9799.                 { case for_init:
  9800.                     argv_init_files[argv_init_filecount++] = arg; break;
  9801.                   case for_compile:
  9802.                     argv_compile_files[argv_compile_filecount].input_file = arg;
  9803.                     argv_compile_files[argv_compile_filecount].output_file = NULL;
  9804.                     argv_compile_filecount++;
  9805.                     break;
  9806.                   case illegal:
  9807.                   default:
  9808.                     goto usage;
  9809.             }   }
  9810.         }
  9811.       # Optionen semantisch überprüfen und Defaults eintragen:
  9812.       if (argv_memneed == 0)
  9813.         #if defined(SPVW_MIXED_BLOCKS_OPPOSITE) && defined(GENERATIONAL_GC)
  9814.         # Wegen GENERATIONAL_GC wird der Speicherbereich kaum ausgeschöpft.
  9815.         { argv_memneed = 3584*1024*sizeof(object); } # 3584 KW = 14 MB Default
  9816.         #else 
  9817.         # normalerweise
  9818.         { argv_memneed = 512*1024*sizeof(object); } # 512 KW = 2 MB Default
  9819.         #endif
  9820.       #ifdef MULTIMAP_MEMORY_VIA_FILE
  9821.       if (argv_tmpdir == NULL)
  9822.         { argv_tmpdir = getenv("TMPDIR"); # Environment-Variable probieren
  9823.           if (argv_tmpdir == NULL)
  9824.             { argv_tmpdir = "/tmp"; }
  9825.         }
  9826.       #endif
  9827.       if (!argv_compile)
  9828.         # Manche Optionen sind nur zusammen mit '-c' sinnvoll:
  9829.         { if (argv_compile_listing) goto usage; }
  9830.         else
  9831.         # Andere Optionen sind nur ohne '-c' sinnvoll:
  9832.         { if (!(argv_expr == NULL)) goto usage; }
  9833.      }
  9834.      #ifndef LANGUAGE_STATIC
  9835.      init_language(argv_language);
  9836.      #ifdef ENABLE_NLS
  9837.      setlocale (LC_ALL,"");
  9838.      if (language == language_deutsch)
  9839.       { setenv_ ("LANG","de");
  9840.         setlocale (LC_MESSAGES,"de");
  9841.       }
  9842.      elif (language == language_english) 
  9843.        { # setenv_ ("LANG","en");
  9844.          setlocale (LC_MESSAGES,"en");
  9845.        }
  9846.      elif (language == language_francais) 
  9847.        { setenv_ ("LANG","fr");
  9848.          setlocale (LC_MESSAGES,"fr");
  9849.        }
  9850.      else
  9851.        { # setenv_ ("LANG","en");
  9852.          setlocale (LC_MESSAGES, "en");
  9853.        }
  9854.      if (argv_localedir == NULL)
  9855.        argv_localedir = LOCALEDIR;
  9856.      { var struct stat statbuf;
  9857.        if (stat(argv_localedir,&statbuf) >= 0)
  9858.          {
  9859.            bindtextdomain (PACKAGE,argv_localedir);
  9860.            textdomain(PACKAGE);
  9861.          }
  9862.      }
  9863.      #endif
  9864.      #endif
  9865.      # Tabelle von Fehlermeldungen initialisieren:
  9866.      if (init_errormsg_table()<0) goto no_mem;
  9867.      # <ctype.h>-Funktionen 8-bit clean machen, sofern die Environment-Variable
  9868.      # LC_CTYPE passend gesetzt ist:
  9869.      # (Wir verwenden diese Funktionen zwar nicht direkt, aber Zusatzmodule wie
  9870.      # z.B. regexp profitieren davon.)
  9871.      #ifdef HAVE_LOCALE_H
  9872.      { var reg1 const char * locale;
  9873.        { locale = getenv("CLISP_LC_CTYPE");
  9874.          if (!locale)
  9875.            { locale = getenv("GNU_LC_CTYPE");
  9876.              if (!locale)
  9877.                { locale = getenv("LC_CTYPE"); }
  9878.        }   }
  9879.        if (locale)
  9880.          { setlocale(LC_CTYPE,locale); }
  9881.      }
  9882.      #endif
  9883.      # Speicher holen:
  9884.      #ifdef SPVW_PURE
  9885.      { var reg1 uintL heapnr;
  9886.        for (heapnr=0; heapnr<heapcount; heapnr++)
  9887.          { switch (heapnr)
  9888.              { # NB: IMMUTABLE spielt hier keine Rolle, denn die Heaps zu
  9889.                # case_imm_array  und  case imm_cons_type  werden immer leer
  9890.                # bleiben, da für sie keine allocate()-Anforderungen kommen.
  9891.                case_sstring:
  9892.                case_sbvector:
  9893.                case_bignum:
  9894.                #ifndef WIDE
  9895.                case_ffloat:
  9896.                #endif
  9897.                case_dfloat:
  9898.                case_lfloat:
  9899.                  mem.heaptype[heapnr] = 2; break;
  9900.                case_ostring:
  9901.                case_obvector:
  9902.                case_vector:
  9903.                case_array1:
  9904.                case_record:
  9905.                case_symbol:
  9906.                  mem.heaptype[heapnr] = 1; break;
  9907.                case_cons:
  9908.                case_ratio:
  9909.                case_complex:
  9910.                  mem.heaptype[heapnr] = 0; break;
  9911.                default:
  9912.                  mem.heaptype[heapnr] = -1; break;
  9913.          }   }
  9914.      }
  9915.      init_speicher_laengen();
  9916.      #endif
  9917.      #if defined(SPVW_MIXED_BLOCKS) && defined(GENERATIONAL_GC)
  9918.      { var reg1 uintL type;
  9919.        for (type = 0; type < typecount; type++)
  9920.          {
  9921.            #ifdef MULTIMAP_MEMORY
  9922.            switch (type)
  9923.              { MM_TYPECASES break;
  9924.                default: mem.heapnr_from_type[type] = -1; continue;
  9925.              }
  9926.            #endif
  9927.            switch (type)
  9928.              { case_cons: case_ratio: case_complex: mem.heapnr_from_type[type] = 1; break;
  9929.                default:                             mem.heapnr_from_type[type] = 0; break;
  9930.      }   }   }
  9931.      #endif
  9932.      #ifdef MAP_MEMORY_TABLES
  9933.      # total_subr_anz bestimmen:
  9934.      { var reg2 uintC total = 0;
  9935.        var reg1 module_* module;
  9936.        for_modules(all_modules, { total += *module->stab_size; } );
  9937.        total_subr_anz = total;
  9938.      }
  9939.      #endif
  9940.      {# Aufteilung des Gesamtspeichers in Teile:
  9941.       #define teile             16  # 16/16
  9942.         #ifdef NO_SP_MALLOC # wird SP vom Betriebssystem bereitgestellt?
  9943.         #define teile_SP         0
  9944.         #else
  9945.         #define teile_SP         2  # 2/16 (1/16 reicht oft nicht)
  9946.         #endif
  9947.         #define teile_STACK      2  # 2/16
  9948.         #ifdef HAVE_NUM_STACK
  9949.         #define teile_NUM_STACK  1  # 1/16
  9950.         #else
  9951.         #define teile_NUM_STACK  0
  9952.         #endif
  9953.         #define teile_stacks     (teile_SP + teile_STACK + teile_NUM_STACK)
  9954.         #ifdef SPVW_MIXED_BLOCKS
  9955.         #define teile_objects    (teile - teile_stacks)  # Rest
  9956.         #else
  9957.         #define teile_objects    0
  9958.         #endif
  9959.       var reg4 uintL pagesize = # Länge einer Speicherseite
  9960.         #if defined(MULTIMAP_MEMORY_VIA_FILE)
  9961.         getpagesize()
  9962.         #elif defined(MULTIMAP_MEMORY_VIA_SHM)
  9963.         SHMLBA
  9964.         #elif (defined(SINGLEMAP_MEMORY) || defined(TRIVIALMAP_MEMORY)) && defined(HAVE_MACH_VM)
  9965.         vm_page_size
  9966.         #elif defined(GENERATIONAL_GC)
  9967.           # UNIX_SUNOS5 hat doch tatsächlich mmap(), aber kein getpagesize() !
  9968.           #if defined(HAVE_GETPAGESIZE)
  9969.           getpagesize()
  9970.           #elif defined(UNIX_SUNOS5)
  9971.           PAGESIZE # siehe <sys/param.h>
  9972.           #else
  9973.           ??
  9974.           #endif
  9975.         #else # wenn die System-Speicherseiten-Länge keine Rolle spielt
  9976.         teile*varobject_alignment
  9977.         #endif
  9978.         ;
  9979.       var reg5 uintL memneed = argv_memneed; # benötigter Speicher
  9980.       var reg6 aint memblock; # untere Adresse des bereitgestellten Speicherblocks
  9981.       #ifndef SPVW_MIXED_BLOCKS_OPPOSITE
  9982.       memneed = teile_stacks*floor(memneed,teile); # noch keinen Speicher für objects berechnen
  9983.       #undef teile
  9984.       #define teile  teile_stacks
  9985.       #endif
  9986.       #ifndef NO_SP_MALLOC
  9987.       if (!(argv_stackneed==0))
  9988.         { memneed = memneed*(teile-teile_SP)/teile;
  9989.           # Die mit Option -s angegebene SP-Größe ist noch nicht in memneed inbegriffen.
  9990.           memneed = memneed + argv_stackneed;
  9991.         }
  9992.       #endif
  9993.       #if defined(MULTIMAP_MEMORY_VIA_SHM) && (defined(UNIX_SUNOS4) || defined(UNIX_SUNOS5))
  9994.       # SunOS 4 weigert sich, ein shmat() in einen vorher mallozierten Bereich
  9995.       # hinein zu machen, selbst wenn dawischen ein munmap() liegt:
  9996.       # errno = EINVAL. Auch das Umgekehrte, erst shmat() zu machen und dann
  9997.       # mit sbrk() oder brk() den belegten Bereich dem Datensegment einzu-
  9998.       # verleiben, scheitert mit errno = ENOMEM.
  9999.       # Der einzige Ausweg ist, sich den benötigten Speicher von weit weg,
  10000.       # möglichst außer Reichweite von malloc(), zu holen.
  10001.       { var reg1 uintL memhave = round_down(bit(oint_addr_len) - (aint)sbrk(0),SHMLBA);
  10002.         if (memhave < memneed) { memneed = memhave; }
  10003.         memblock = round_down(bit(oint_addr_len) - memneed,SHMLBA);
  10004.       }
  10005.       #else
  10006.       loop
  10007.         { memblock = (aint)mymalloc(memneed); # Speicher allozieren versuchen
  10008.           if (!((void*)memblock == NULL)) break; # gelungen -> OK
  10009.           memneed = floor(memneed,8)*7; # sonst mit 7/8 davon nochmals versuchen
  10010.           if (memneed < MINIMUM_SPACE+RESERVE) # aber mit weniger als MINIMUM_SPACE
  10011.             # geben wir uns nicht zufrieden:
  10012.             {
  10013.               //: DEUTSCH "Nur "
  10014.               //: ENGLISH "Only "
  10015.               //: FRANCAIS "Seuls "
  10016.               asciz_out(GETTEXT("only"));
  10017.               dez_out(memneed);
  10018.               //: DEUTSCH " Bytes verfügbar."
  10019.               //: ENGLISH " bytes available."
  10020.               //: FRANCAIS " octets libres."
  10021.               asciz_out(GETTEXT("bytes available"));
  10022.               asciz_out(CRLFstring);
  10023.               goto no_mem;
  10024.         }   }
  10025.       #endif
  10026.       #ifdef MULTIMAP_MEMORY
  10027.       # Wir brauchen zwar nur diesen Adreßraum und nicht seinen Inhalt, dürfen
  10028.       # ihn aber nicht freigeben, da er in unserer Kontrolle bleiben soll.
  10029.       #endif
  10030.       # Aufrunden zur nächsten Speicherseitengrenze:
  10031.       {var reg1 uintL unaligned = (uintL)(-memblock) % pagesize;
  10032.        memblock += unaligned; memneed -= unaligned;
  10033.       }
  10034.       # Abrunden zur letzen Speicherseitengrenze:
  10035.       {var reg1 uintL unaligned = memneed % pagesize;
  10036.        memneed -= unaligned;
  10037.       }
  10038.       # Der Speicherbereich [memblock,memblock+memneed-1] ist nun frei,
  10039.       # und seine Grenzen liegen auf Speicherseitengrenzen.
  10040.       #ifdef MULTIMAP_MEMORY
  10041.         map_pagesize = pagesize;
  10042.         #ifdef MULTIMAP_MEMORY_VIA_FILE
  10043.         if ( initmap(argv_tmpdir) <0) goto no_mem;
  10044.         #else
  10045.         if ( initmap() <0) goto no_mem;
  10046.         #endif
  10047.         #ifdef NORMAL_MULTIMAP_MEMORY
  10048.         multimap(case_machine: MM_TYPECASES, IMM_TYPECASES, TRUE, memblock, memneed, FALSE);
  10049.         #else # MINIMAL_MULTIMAP_MEMORY
  10050.         multimap(case_machine: case imm_type:, case imm_type:, TRUE, memblock, memneed, FALSE);
  10051.         #endif
  10052.         #ifdef MAP_MEMORY_TABLES
  10053.         # Dazu noch symbol_tab an die Adresse 0 legen:
  10054.         {var reg3 uintL memneed = round_up(sizeof(symbol_tab),pagesize); # Länge aufrunden
  10055.          multimap(case_symbolflagged: ,_EMA_, FALSE, 0, memneed, FALSE);
  10056.         }
  10057.         # Dazu noch subr_tab an die Adresse 0 legen:
  10058.         if ( zeromap(&subr_tab,round_up(total_subr_anz*sizeof(subr_),pagesize)) <0) goto no_mem;
  10059.         #elif defined(NORMAL_MULTIMAP_MEMORY)
  10060.         # Dazu noch symbol_tab und subr_tab multimappen:
  10061.         # Die symbol_tab und subr_tab behalten dabei ihre Adresse. Der Bereich,
  10062.         # in dem sie liegen (im Datensegment des Programms!!), wird zu Shared
  10063.         # Memory bzw. Shared-mmap-Attach gemacht. Was für ein Hack!
  10064.         # Dies ist mit der Existenz externer Module unvereinbar! ??
  10065.         {var reg5 aint symbol_tab_start = round_down((aint)&symbol_tab,pagesize);
  10066.          var reg6 aint symbol_tab_end = round_up((aint)&symbol_tab+sizeof(symbol_tab),pagesize);
  10067.          var reg7 aint subr_tab_start = round_down((aint)&subr_tab,pagesize);
  10068.          var reg8 aint subr_tab_end = round_up((aint)&subr_tab+sizeof(subr_tab),pagesize);
  10069.          if ((symbol_tab_end <= subr_tab_start) || (subr_tab_end <= symbol_tab_start))
  10070.            # zwei getrennte Intervalle
  10071.            { multimap(case_machine: case_symbolflagged: ,_EMA_, FALSE, symbol_tab_start, symbol_tab_end-symbol_tab_start, TRUE);
  10072.              multimap(case_machine: case_subr: ,_EMA_, FALSE, subr_tab_start, subr_tab_end-subr_tab_start, TRUE);
  10073.            }
  10074.            else
  10075.            # die Tabellen überlappen sich!
  10076.            { var reg3 aint tab_start = (symbol_tab_start < subr_tab_start ? symbol_tab_start : subr_tab_start);
  10077.              var reg4 aint tab_end = (symbol_tab_end > subr_tab_end ? symbol_tab_end : subr_tab_end);
  10078.              multimap(case_machine: case_symbolflagged: case_subr: ,_EMA_, FALSE, tab_start, tab_end-tab_start, TRUE);
  10079.            }
  10080.         }
  10081.         #endif
  10082.         #ifdef MULTIMAP_MEMORY_VIA_FILE
  10083.         if ( CLOSE(zero_fd) <0)
  10084.           { 
  10085.             //: DEUTSCH "Kann /dev/zero nicht schließen."
  10086.             //: ENGLISH "Cannot close /dev/zero ."
  10087.             //: FRANCAIS "Ne peux pas fermer /dev/zero ."
  10088.             asciz_out(GETTEXT("cannot close /dev/zero"));
  10089.             errno_out(errno);
  10090.             goto no_mem;
  10091.           }
  10092.         #endif
  10093.       #endif
  10094.       #if defined(SINGLEMAP_MEMORY) || defined(TRIVIALMAP_MEMORY) # <==> SPVW_PURE_BLOCKS || TRIVIALMAP_MEMORY
  10095.         map_pagesize = # Länge einer Hardware-Speicherseite
  10096.           # UNIX_SUNOS5 hat doch tatsächlich mmap(), aber kein getpagesize() !
  10097.           #if defined(HAVE_GETPAGESIZE)
  10098.           getpagesize()
  10099.           #elif defined(HAVE_MACH_VM)
  10100.           vm_page_size
  10101.           #elif defined(HAVE_SHM)
  10102.           SHMLBA
  10103.           #elif defined(UNIX_SUNOS5)
  10104.           PAGESIZE # siehe <sys/param.h>
  10105.           #else
  10106.           4096
  10107.           #endif
  10108.           ;
  10109.         if ( initmap() <0) goto no_mem;
  10110.         #ifdef SINGLEMAP_MEMORY
  10111.         # Alle Heaps vor-initialisieren:
  10112.         { var reg2 uintL heapnr;
  10113.           for (heapnr=0; heapnr<heapcount; heapnr++)
  10114.             { var reg1 Heap* heapptr = &mem.heaps[heapnr];
  10115.               heapptr->heap_limit = (aint)type_zero_oint(heapnr);
  10116.         }   }
  10117.         # Dazu noch symbol_tab, subr_tab an die Adresse 0 legen:
  10118.         # (Hierzu muß case_symbolflagged mit case_symbol äquivalent sein!)
  10119.         #define map_tab(tab,size)  \
  10120.           { var reg1 uintL map_len = round_up(size,map_pagesize); \
  10121.             if ( zeromap(&tab,map_len) <0) goto no_mem;           \
  10122.             mem.heaps[typecode(as_object((oint)&tab))].heap_limit += map_len; \
  10123.           }
  10124.         map_tab(symbol_tab,sizeof(symbol_tab));
  10125.         map_tab(subr_tab,total_subr_anz*sizeof(subr_));
  10126.         #endif
  10127.         #ifdef TRIVIALMAP_MEMORY
  10128.         # Alle Heaps als leer initialisieren.
  10129.         # Dabei den gesamten zur Verfügung stehenden Platz im Verhältnis 1:1 aufteilen.
  10130.         { var reg3 void* malloc_addr = malloc(1);
  10131.           var reg1 aint start = round_up((aint)malloc_addr+1*1024*1024,map_pagesize); # 1 MB Reserve für malloc()
  10132.           #if !defined(SUN4_29)
  10133.           var reg2 aint end = bitm(oint_addr_len+addr_shift);
  10134.           #else # defined(SUN4_29) -> Zugriff nur auf Adressen < 2^29 möglich
  10135.           var reg2 aint end = bitm(oint_addr_len+addr_shift < 29 ? oint_addr_len+addr_shift : 29);
  10136.           #endif
  10137.           mem.heaps[0].heap_limit = start;
  10138.           mem.heaps[1].heap_limit = start + round_down(floor(end-start,2),map_pagesize);
  10139.           free(malloc_addr);
  10140.         }
  10141.         #endif
  10142.         # Alle Heaps als leer initialisieren:
  10143.         { var reg2 uintL heapnr;
  10144.           for (heapnr=0; heapnr<heapcount; heapnr++)
  10145.             { var reg1 Heap* heapptr = &mem.heaps[heapnr];
  10146.               heapptr->heap_start = heapptr->heap_end = heapptr->heap_limit;
  10147.               #ifdef GENERATIONAL_GC
  10148.               heapptr->heap_gen0_start = heapptr->heap_gen0_end = heapptr->heap_gen1_start = heapptr->heap_limit;
  10149.               heapptr->physpages = NULL;
  10150.               #endif
  10151.         }   }
  10152.        #ifdef SINGLEMAP_MEMORY_STACK
  10153.         # STACK initialisieren:
  10154.         { var reg1 uintL map_len = round_up(memneed * teile_STACK/teile, map_pagesize);
  10155.           # Der Stack belegt das Intervall von 0 bis map_len bei Typcode = system_type:
  10156.           var reg2 aint low = (aint)type_zero_oint(system_type);
  10157.           var reg3 aint high = low + map_len;
  10158.           if ( zeromap((void*)low,map_len) <0) goto no_mem;
  10159.           #ifdef STACK_DOWN
  10160.             STACK_bound = (object*)(low + 0x100); # 64 Pointer Sicherheitsmarge
  10161.             setSTACK(STACK = (object*)high); # STACK initialisieren
  10162.           #endif
  10163.           #ifdef STACK_UP
  10164.             setSTACK(STACK = (object*)low); # STACK initialisieren
  10165.             STACK_bound = (object*)(high - 0x100); # 64 Pointer Sicherheitsmarge
  10166.           #endif
  10167.         }
  10168.         #undef teile_STACK
  10169.         #define teile_STACK 0  # brauche keinen Platz mehr für den STACK
  10170.         #if (teile==0)
  10171.           #undef teile
  10172.           #define teile 1  # Division durch 0 vermeiden
  10173.         #endif
  10174.        #endif
  10175.       #endif
  10176.       #ifdef GENERATIONAL_GC
  10177.       #ifdef MAP_MEMORY
  10178.       physpagesize = map_pagesize;
  10179.       #else
  10180.       physpagesize = pagesize;
  10181.       #endif
  10182.       # physpageshift = log2(physpagesize);
  10183.       { var reg1 uintL x = physpagesize;
  10184.         var reg2 uintL i = 0;
  10185.         until ((x >>= 1) == 0) { i++; }
  10186.         if (!((1UL << i) == physpagesize)) abort();
  10187.         physpageshift = i;
  10188.       }
  10189.       #endif
  10190.       # Speicherblock aufteilen:
  10191.       { var reg3 uintL free_reserved; # Anzahl reservierter Bytes
  10192.         #ifndef NO_SP_MALLOC
  10193.         var reg10 void* initial_SP; # Initialwert für SP-Stackpointer
  10194.         var reg9 uintL for_SP = 0; # Anzahl Bytes für SP-Stack
  10195.         #define min_for_SP  40000 # minimale SP-Stack-Größe
  10196.         #endif
  10197.         var reg7 uintL for_STACK; # Anzahl Bytes für Lisp-STACK
  10198.         var reg9 uintL for_NUM_STACK; # Anzahl Bytes für Zahlen-STACK
  10199.         var reg8 uintL for_objects; # Anzahl Bytes für Lisp-Objekte
  10200.         # Der STACK braucht Alignment, da bei Frame-Pointern das letzte Bit =0 sein muß:
  10201.         #define STACK_alignment  bit(addr_shift+1)
  10202.         #define alignment  (varobject_alignment>STACK_alignment ? varobject_alignment : STACK_alignment)
  10203.         free_reserved = memneed;
  10204.         #ifndef NO_SP_MALLOC
  10205.         if (!(argv_stackneed==0))
  10206.           if (2*argv_stackneed <= free_reserved) # nicht zu viel für den SP-Stack reservieren
  10207.             { for_SP = round_down(argv_stackneed,varobject_alignment);
  10208.               free_reserved -= argv_stackneed;
  10209.             }
  10210.         #endif
  10211.         # Durch teile*alignment teilbar machen, damit jedes Sechzehntel aligned ist:
  10212.         free_reserved = round_down(free_reserved,teile*alignment);
  10213.         free_reserved = free_reserved - RESERVE;
  10214.        {var reg2 uintL teil = free_reserved/teile; # ein Teilblock, ein Sechzehntel des Platzes
  10215.         var reg1 aint ptr = memblock;
  10216.         mem.MEMBOT = ptr;
  10217.         #ifndef NO_SP_MALLOC
  10218.         # SP allozieren:
  10219.         if (for_SP==0)
  10220.           { for_SP = teile_SP*teil; } # 2/16 für Programmstack
  10221.           else
  10222.           # Platz für SP ist schon abgezwackt.
  10223.           { # teile := teile-teile_SP; # geht nicht mehr, stattdessen:
  10224.             teil = round_down(free_reserved/(teile-teile_SP),alignment);
  10225.           }
  10226.         if (for_SP < min_for_SP) { for_SP = round_up(min_for_SP,alignment); } # aber nicht zu wenig
  10227.         #ifdef SP_DOWN
  10228.           SP_bound = (void*)(ptr + 0x800); # 512 Pointer Sicherheitsmarge
  10229.           ptr += for_SP;
  10230.           initial_SP = (void*)ptr;
  10231.         #endif
  10232.         #ifdef SP_UP
  10233.           initial_SP = (void*)ptr;
  10234.           ptr += for_SP;
  10235.           SP_bound = (void*)(ptr - 0x800); # 512 Pointer Sicherheitsmarge
  10236.         #endif
  10237.         #else
  10238.           # The default C stack size is too low on some systems. Enlarge it.
  10239.           #ifdef UNIX_NEXTSTEP
  10240.             { struct rlimit rl;
  10241.               long need = 0x800000; # 8 Megabyte
  10242.               getrlimit(RLIMIT_STACK, &rl);
  10243.               if (rl.rlim_max < need)
  10244.                 need = rl.rlim_max;
  10245.               if (rl.rlim_cur < need)
  10246.                 { rl.rlim_cur = need; setrlimit(RLIMIT_STACK,&rl); }
  10247.             }
  10248.           #endif
  10249.         #endif
  10250.         # STACK allozieren:
  10251.         #ifdef SINGLEMAP_MEMORY_STACK
  10252.         for_STACK = 0; # STACK ist schon woanders alloziert.
  10253.         #else
  10254.         #ifdef STACK_DOWN
  10255.           STACK_bound = (object*)(ptr + 0x100); # 64 Pointer Sicherheitsmarge
  10256.           ptr += for_STACK = teile_STACK*teil; # 2/16 für Lisp-STACK
  10257.           setSTACK(STACK = (object*)ptr); # STACK initialisieren
  10258.         #endif
  10259.         #ifdef STACK_UP
  10260.           setSTACK(STACK = (object*)ptr); # STACK initialisieren
  10261.           ptr += for_STACK = teile_STACK*teil; # 2/16 für Lisp-STACK
  10262.           STACK_bound = (object*)(ptr - 0x100); # 64 Pointer Sicherheitsmarge
  10263.         #endif
  10264.         #endif
  10265.         #ifdef HAVE_NUM_STACK
  10266.         # NUM_STACK allozieren:
  10267.         #ifdef NUM_STACK_DOWN
  10268.           NUM_STACK_bound = (uintD*)ptr;
  10269.           ptr += for_NUM_STACK = teile_NUM_STACK*teil; # 1/16 für Zahlen-STACK
  10270.           NUM_STACK = NUM_STACK_normal = (uintD*)round_down(ptr,sizeof(uintD)); # NUM_STACK initialisieren
  10271.         #endif
  10272.         #ifdef NUM_STACK_UP
  10273.           NUM_STACK = NUM_STACK_normal = (uintD*)round_up(ptr,sizeof(uintD)); # NUM_STACK initialisieren
  10274.           ptr += for_NUM_STACK = teile_NUM_STACK*teil; # 1/16 für Zahlen-STACK
  10275.           NUM_STACK_bound = (uintD*)ptr;
  10276.         #endif
  10277.         #else
  10278.         for_NUM_STACK = 0; # kein Zahlen-Stack vorhanden
  10279.         #endif
  10280.         #ifdef SPVW_MIXED_BLOCKS_OPPOSITE
  10281.         # Nun fangen die Lisp-Objekte an:
  10282.         #ifdef GENERATIONAL_GC
  10283.         mem.varobjects.heap_gen0_start = mem.varobjects.heap_gen0_end =
  10284.           mem.varobjects.heap_gen1_start =
  10285.             mem.varobjects.heap_start = (ptr + (physpagesize-1)) & -physpagesize;
  10286.         #else
  10287.         mem.varobjects.heap_start = ptr;
  10288.         #endif
  10289.         mem.varobjects.heap_end = mem.varobjects.heap_start; # Noch gibt es keine Objekte variabler Länge
  10290.         # Rest (14/16 oder etwas weniger) für Lisp-Objekte:
  10291.         for_objects = memblock+free_reserved - ptr; # etwa = teile_objects*teil
  10292.         ptr += for_objects;
  10293.         #ifdef GENERATIONAL_GC
  10294.         mem.conses.heap_gen0_start = mem.conses.heap_gen0_end =
  10295.           mem.conses.heap_gen1_end =
  10296.             mem.conses.heap_end = ptr & -physpagesize;
  10297.         #else
  10298.         mem.conses.heap_end = ptr;
  10299.         #endif
  10300.         mem.conses.heap_start = mem.conses.heap_end; # Noch gibt es keine Conses
  10301.         # ptr = memblock+free_reserved, da 2/16 + 14/16 = 1
  10302.         # Reservespeicher allozieren:
  10303.         ptr += RESERVE;
  10304.         # oberes Speicherende erreicht.
  10305.         mem.MEMTOP = ptr;
  10306.         # Darüber (weit weg) der Maschinenstack.
  10307.         #endif
  10308.         #if defined(SPVW_PURE_BLOCKS) || defined(TRIVIALMAP_MEMORY) || defined(GENERATIONAL_GC)
  10309.         mem.total_room = 0;
  10310.         #ifdef GENERATIONAL_GC
  10311.         mem.last_gcend_space0 = 0;
  10312.         mem.last_gcend_space1 = 0;
  10313.         #endif
  10314.         #endif
  10315.         #ifdef SPVW_PAGES
  10316.         for_each_heap(heap, { heap->inuse = EMPTY; } );
  10317.         for_each_cons_heap(heap, { heap->lastused = dummy_lastused; } );
  10318.         dummy_lastused->page_room = 0;
  10319.         mem.free_pages = NULL;
  10320.         mem.total_space = 0;
  10321.         mem.used_space = 0;
  10322.         mem.last_gcend_space = 0;
  10323.         mem.gctrigger_space = 0;
  10324.         #endif
  10325.         # Stacks initialisieren:
  10326.         #ifdef NO_SP_MALLOC
  10327.           #ifdef AMIGAOS
  10328.           { var struct Process * myprocess = (struct Process *)FindTask(NULL);
  10329.             var aint original_SP = process->pr_ReturnAddr; # SP beim Programmstart
  10330.             # Die Shell legt die Stackgröße vor dem Start auf den SP.
  10331.             ptr = original_SP - *(CLISP_ULONG*)original_SP;
  10332.             SP_bound = ptr + 0x1000; # 1024 Pointer Sicherheitsmarge
  10333.           }
  10334.           #endif
  10335.         #else
  10336.           #ifdef GNU
  10337.             # eine kleine Dummy-Aktion, die ein hinausgezögertes Aufräumen des SP
  10338.             # zu einem späteren Zeitpunkt verhindert:
  10339.             if (mem.MEMBOT) { asciz_out(""); }
  10340.           #endif
  10341.           #if defined(EMUNIX) && defined(WINDOWS)
  10342.           SP_start = SP(); # Für System-Calls müssen wir auf diesen Stack zurück!!
  10343.           #endif
  10344.           setSP(initial_SP); # SP setzen! Dabei gehen alle lokalen Variablen verloren!
  10345.         #endif
  10346.         pushSTACK(nullobj); pushSTACK(nullobj); # Zwei Nullpointer als STACKende-Kennung
  10347.      }}}
  10348.       init_subr_tab_1(); # subr_tab initialisieren
  10349.       if (argv_memfile==NULL)
  10350.         # Zu-Fuß-Initialisierung:
  10351.         { initmem(); 
  10352.           set_Symbol_value(S(image_pathname),NIL);
  10353.         }
  10354.         else
  10355.         # Speicherfile laden:
  10356.         { loadmem(argv_memfile); 
  10357.           pushSTACK(asciz_to_string(argv_memfile));
  10358.           funcall(L(parse_namestring),1);
  10359.           set_Symbol_value(S(image_pathname),value1);
  10360.         }
  10361.       init_other_modules_2();
  10362.       init_derived_strings();
  10363.       # aktuelle Evaluator-Environments auf den Toplevel-Wert setzen:
  10364.       aktenv.var_env   = NIL;
  10365.       aktenv.fun_env   = NIL;
  10366.       aktenv.block_env = NIL;
  10367.       aktenv.go_env    = NIL;
  10368.       aktenv.decl_env  = O(top_decl_env);
  10369.       # Alles fertig initialisiert.
  10370.       subr_self = NIL; # irgendein gültiges Lisp-Objekt
  10371.       set_break_sem_1(); clr_break_sem_2(); clr_break_sem_3(); clr_break_sem_4();
  10372.       everything_ready = TRUE;
  10373.       # Interrupt-Handler einrichten:
  10374.       #if defined(HAVE_SIGNALS)
  10375.         #if defined(SIGWINCH) && !defined(NO_ASYNC_INTERRUPTS)
  10376.         # Eine veränderte Größe des Terminal-Fensters soll sich auch sofort
  10377.         # in SYS::*PRIN-LINELENGTH* bemerkbar machen:
  10378.         SIGNAL(SIGWINCH,&sigwinch_handler);
  10379.         #endif
  10380.         # Die Größe des Terminal-Fensters auch jetzt beim Programmstart erfragen:
  10381.         begin_system_call();
  10382.         update_linelength();
  10383.         end_system_call();
  10384.       #endif
  10385.       #if defined(MSDOS) && defined(WINDOWS)
  10386.         { var int width;
  10387.           var int height;
  10388.           get_text_size(main_window,&width,&height);
  10389.           if (width > 0)
  10390.             { # Wert von SYS::*PRIN-LINELENGTH* verändern:
  10391.               set_Symbol_value(S(prin_linelength),fixnum(width-1));
  10392.         }   }
  10393.       #endif
  10394.       #if defined(MSDOS) && !defined(WINDOWS) && !defined(WIN32_DOS)
  10395.         # Die Breite des Bildschirms im aktuellen Bildschirm-Modus
  10396.         # jetzt beim Programmstart erfragen:
  10397.         if (isatty(stdout_handle)) # Standard-Output ein Terminal?
  10398.           { extern uintW v_cols(); # siehe STREAM.D
  10399.             #ifdef EMUNIX_PORTABEL
  10400.             var int scrsize[2];
  10401.             var reg1 uintL columns;
  10402.             #ifdef EMUNIX_OLD_8d
  10403.             if (_osmode == DOS_MODE)
  10404.               /* unter DOS */ { columns = v_cols(); }
  10405.               else
  10406.               /* unter OS/2 */
  10407.             #endif
  10408.             columns = (_scrsize(&!scrsize), scrsize[0]);
  10409.             #else
  10410.             var reg1 uintL columns = v_cols();
  10411.             #endif
  10412.             if (columns > 0)
  10413.               { # Wert von SYS::*PRIN-LINELENGTH* verändern:
  10414.                 set_Symbol_value(S(prin_linelength),fixnum(columns-1));
  10415.           }   }
  10416.       #endif
  10417.       #if defined(AMIGAOS) && 0
  10418.         # frage beim console.driver nach??
  10419.         if (IsInteractive(Input_handle) && IsInteractive(Output_handle)) # ??
  10420.           { var reg1 uintL len;
  10421.             var uintB question[4] = { CSI, '0', ' ', 'q' };
  10422.             var uintB response[30+1];
  10423.             Write(Output_handle,question,4);
  10424.             len = Read(Input_handle,response,30);
  10425.             response[len] = `\0`; sscanf(&response[5],"%d;%d", &lines, &columns); # ??
  10426.           }
  10427.       #endif
  10428.       #if defined(HAVE_SIGNALS)
  10429.       #if defined(UNIX) || defined(EMUNIX) || defined(RISCOS) || defined(WIN32_DOS) || defined(WIN32_UNIX)
  10430.         # Ctrl-C-Handler einsetzen:
  10431.         SIGNAL(SIGINT,&interrupt_handler);
  10432.         #ifdef PENDING_INTERRUPTS
  10433.         SIGNAL(SIGALRM,&alarm_handler);
  10434.         #endif
  10435.         #if defined(IMMUTABLE) || defined(GENERATIONAL_GC)
  10436.         install_segv_handler();
  10437.         #endif
  10438.       #endif
  10439.       install_sigcld_handler();
  10440.       #endif
  10441.       # Zeitvariablen initialisieren:
  10442.       init_time();
  10443.       # Stream-Variablen initialisieren:
  10444.       init_streamvars();
  10445.       #ifdef NEXTAPP
  10446.       # nxterminal-Stream funktionsfähig machen:
  10447.       if (nxterminal_init())
  10448.         { final_exitcode = 17; quit(); }
  10449.       #endif
  10450.       # Break ermöglichen:
  10451.       end_system_call();
  10452.       clr_break_sem_1();
  10453.       # Pathnames initialisieren:
  10454.       init_pathnames();
  10455.       #ifdef REXX
  10456.       # Rexx-Interface initialisieren:
  10457.       init_rexx();
  10458.       # Auf eine Fehlermeldung im Falle des Scheiterns verzichten wir.
  10459.       # Deswegen wollen wir das CLISP doch nicht unbrauchbar machen!
  10460.       #endif
  10461.       #ifdef DYNAMIC_FFI
  10462.       # FFI initialisieren:
  10463.       init_ffi();
  10464.       #endif
  10465.       # Modul-Initialisierungen:
  10466.       init_other_modules_3();
  10467.       { var reg7 module_* module; # modules durchgehen
  10468.         for_modules(all_other_modules,
  10469.           { if (module->initfunction2)
  10470.               # Initialisierungsfunktion aufrufen:
  10471.               (*module->initfunction2)(module);
  10472.           });
  10473.       }
  10474.       # Sonstige Initialisierungen:
  10475.       { pushSTACK(Symbol_value(S(init_hooks))); # SYS::*INIT-HOOKS*
  10476.         while (mconsp(STACK_0)) # abarbeiten
  10477.           { var reg1 object obj = STACK_0;
  10478.             STACK_0 = Cdr(obj); funcall(Car(obj),0);
  10479.           }
  10480.         skipSTACK(1);
  10481.       }
  10482.       # Begrüßung ausgeben:
  10483.       if (!sym_nullp(S(quiet))) # SYS::*QUIET* /= NIL ?
  10484.         { argv_quiet = TRUE; } # verhindert die Begrüßung
  10485.       if (!argv_quiet)
  10486.         { local char* banner[] = { # einige Zeilen à 66 Zeichen
  10487.           #  |Spalte 0           |Spalte 20                                    |Spalte 66
  10488.             "  i i i i i i i       ooooo    o        ooooooo   ooooo   ooooo   " NLstring,
  10489.             "  I I I I I I I      8     8   8           8     8     o  8    8  " NLstring,
  10490.             "  I I I I I I I      8         8           8     8        8    8  " NLstring,
  10491.             "  I I I I I I I      8         8           8      ooooo   8oooo   " NLstring,
  10492.            "  I  \\ `+' /  I      8         8           8           8  8       " NLstring,
  10493.            "   \\  `-+-'  /       8     o   8           8     o     8  8       " NLstring,
  10494.             "    `-__|__-'         ooooo    8oooooo  ooo8ooo   ooooo   8       " NLstring,
  10495.             "        |                                                         " NLstring,
  10496.             "  ------+------  Copyright (c) Bruno Haible, Michael Stoll 1992, 1993" NLstring,
  10497.             "                 Copyright (c) Bruno Haible, Marcus Daniels 1994, 1995, 1996" NLstring,
  10498.             };
  10499.           #ifdef AMIGA
  10500.           //: DEUTSCH  "                    Amiga-Version: Jörg Höhle                     "
  10501.           //: ENGLISH  "                    Amiga version: Jörg Höhle                     "
  10502.           //: FRANCAIS "                    version Amiga: Jörg Höhle                     "
  10503.           var char* banner2 = GETTEXT("amiga banner");
  10504.           #endif
  10505.           #ifdef DJUNIX
  10506.           //: DEUTSCH  "                    DOS-Portierung: Jürgen Weber, Bruno Haible    "
  10507.           //: ENGLISH  "                    DOS port: Jürgen Weber, Bruno Haible          "
  10508.           //: FRANCAIS "                    adapté à DOS par Jürgen Weber et Bruno Haible "
  10509.           var char* banner2 = GETTEXT("dos banner");
  10510.           #endif
  10511.           local char* banner3 =
  10512.             "                                                                  ";
  10513.           var reg3 uintL offset = (posfixnum_to_L(Symbol_value(S(prin_linelength))) >= 73 ? 0 : 20);
  10514.           var reg1 char** ptr = &banner[0];
  10515.           var reg2 uintC count;
  10516.           pushSTACK(var_stream(S(standard_output),strmflags_wr_ch_B)); # auf *STANDARD-OUTPUT*
  10517.           dotimesC(count,sizeof(banner)/sizeof(banner[0]),
  10518.             { write_sstring(&STACK_0,asciz_to_string(&(*ptr++)[offset])); }
  10519.             );
  10520.           #if defined(AMIGA) || defined(DJUNIX)
  10521.           write_sstring(&STACK_0,asciz_to_string(&banner2[offset]));
  10522.           write_sstring(&STACK_0,asciz_to_string(NLstring));
  10523.           #endif
  10524.           write_sstring(&STACK_0,asciz_to_string(&banner3[offset]));
  10525.           write_sstring(&STACK_0,asciz_to_string(NLstring));
  10526.           skipSTACK(1);
  10527.         }
  10528.       if (argv_compile || !(argv_expr == NULL))
  10529.         # '-c' oder '-x' angegeben -> LISP läuft im Batch-Modus:
  10530.         { # (setq *debug-io*
  10531.           #   (make-two-way-stream (make-string-input-stream "") *query-io*)
  10532.           # )
  10533.           funcall(L(make_concatenated_stream),0); # (MAKE-CONCATENATED-STREAM)
  10534.           pushSTACK(value1); # leerer Input-Stream
  10535.          {var reg1 object stream = var_stream(S(query_io),strmflags_wr_ch_B);
  10536.           set_Symbol_value(S(debug_io),make_twoway_stream(popSTACK(),stream));
  10537.         }}
  10538.       if (!(argv_package == NULL))
  10539.         # (IN-PACKAGE packagename) ausführen:
  10540.         { var reg1 object packname = asciz_to_string(argv_package);
  10541.           pushSTACK(packname); funcall(L(in_package),1);
  10542.         }
  10543.       # für jedes initfile (LOAD initfile) ausführen:
  10544.       { var reg1 char** fileptr = &argv_init_files[0];
  10545.         var reg2 uintL count;
  10546.         dotimesL(count,argv_init_filecount,
  10547.           { var reg3 object filename = asciz_to_string(*fileptr++);
  10548.             pushSTACK(filename); funcall(S(load),1);
  10549.           });
  10550.       }
  10551.       if (argv_compile)
  10552.         # für jedes File
  10553.         #   (EXIT-ON-ERROR
  10554.         #     (APPEASE-CERRORS
  10555.         #       (COMPILE-FILE (setq file (MERGE-PATHNAMES file (MERGE-PATHNAMES '#".lsp" (CD))))
  10556.         #                     [:OUTPUT-FILE (setq output-file (MERGE-PATHNAMES (MERGE-PATHNAMES output-file (MERGE-PATHNAMES '#".fas" (CD))) file))]
  10557.         #                     [:LISTING (MERGE-PATHNAMES '#".lis" (or output-file file))]
  10558.         #   ) ) )
  10559.         # durchführen:
  10560.         { var reg3 argv_compile_file* fileptr = &argv_compile_files[0];
  10561.           var reg6 uintL count;
  10562.           dotimesL(count,argv_compile_filecount,
  10563.             { var reg4 uintC argcount = 1;
  10564.               var reg5 object filename = asciz_to_string(fileptr->input_file);
  10565.               pushSTACK(S(compile_file));
  10566.               pushSTACK(filename);
  10567.               pushSTACK(O(source_file_type)); # #".lsp"
  10568.               funcall(L(cd),0); pushSTACK(value1); # (CD)
  10569.               funcall(L(merge_pathnames),2); # (MERGE-PATHNAMES '#".lsp" (CD))
  10570.               pushSTACK(value1);
  10571.               funcall(L(merge_pathnames),2); # (MERGE-PATHNAMES file ...)
  10572.               pushSTACK(value1);
  10573.               if (fileptr->output_file)
  10574.                 { filename = asciz_to_string(fileptr->output_file);
  10575.                   pushSTACK(S(Koutput_file));
  10576.                   pushSTACK(filename);
  10577.                   pushSTACK(O(compiled_file_type)); # #".fas"
  10578.                   funcall(L(cd),0); pushSTACK(value1); # (CD)
  10579.                   funcall(L(merge_pathnames),2); # (MERGE-PATHNAMES '#".fas" (CD))
  10580.                   pushSTACK(value1);
  10581.                   funcall(L(merge_pathnames),2); # (MERGE-PATHNAMES output-file ...)
  10582.                   pushSTACK(value1);
  10583.                   pushSTACK(STACK_2); # file
  10584.                   funcall(L(merge_pathnames),2); # (MERGE-PATHNAMES ... file)
  10585.                   pushSTACK(value1);
  10586.                   argcount += 2;
  10587.                 }
  10588.               if (argv_compile_listing)
  10589.                 { pushSTACK(S(Klisting));
  10590.                   pushSTACK(O(listing_file_type)); # #".lis"
  10591.                   pushSTACK(STACK_2); # (or output-file file)
  10592.                   funcall(L(merge_pathnames),2); # (MERGE-PATHNAMES '#".lis" ...)
  10593.                   pushSTACK(value1);
  10594.                   argcount += 2;
  10595.                 }
  10596.               # Alle Argumente quotieren:
  10597.              {var reg1 object* ptr = args_end_pointer;
  10598.               var reg2 uintC c;
  10599.               dotimesC(c,argcount,
  10600.                 { pushSTACK(S(quote)); pushSTACK(Before(ptr));
  10601.                   BEFORE(ptr) = listof(2);
  10602.                 });
  10603.              }
  10604.              {var reg1 object form = listof(1+argcount); # `(COMPILE-FILE ',...)
  10605.               pushSTACK(S(batchmode_errors));
  10606.               pushSTACK(form);
  10607.               form = listof(2); # `(SYS::BATCHMODE-ERRORS (COMPILE-FILE ',...))
  10608.               eval_noenv(form); # ausführen
  10609.               fileptr++;
  10610.             }});
  10611.           quit();
  10612.         }
  10613.       if (!(argv_expr == NULL))
  10614.         # *STANDARD-INPUT* auf einen Stream setzen, der argv_expr produziert:
  10615.         { pushSTACK(asciz_to_string(argv_expr));
  10616.           funcall(L(make_string_input_stream),1);
  10617.           set_Symbol_value(S(standard_input),value1);
  10618.           # Dann den Driver aufrufen. Stringende -> EOF -> Programmende.
  10619.         }
  10620.       # Read-Eval-Print-Schleife aufrufen:
  10621.       driver();
  10622.       quit();
  10623.       /*NOTREACHED*/
  10624.       # Falls der Speicher nicht ausreichte:
  10625.       no_mem:
  10626.       asciz_out(program_name); asciz_out(": ");
  10627.       //: DEUTSCH "Nicht genug Speicher für LISP"
  10628.       //: ENGLISH "Not enough memory for Lisp."
  10629.       //: FRANCAIS "Il n'y a pas assez de mémoire pour LISP."
  10630.       asciz_out(GETTEXT("not enough memory for Lisp"));
  10631.       asciz_out(CRLFstring);
  10632.       quit_sofort(1);
  10633.       /*NOTREACHED*/
  10634.      # Beendigung des Programms durch quit_sofort():
  10635.       end_of_main:
  10636.       #ifdef MULTIMAP_MEMORY
  10637.       exitmap();
  10638.       #endif
  10639.       FREE_DYNAMIC_ARRAY(argv_compile_files); }
  10640.       FREE_DYNAMIC_ARRAY(argv_init_files); }
  10641.       #ifdef GRAPHICS_SWITCH
  10642.       switch_text_mode(); # Rückkehr zum normalen Text-Modus
  10643.       #endif
  10644.       #if (defined(UNIX) && !defined(NEXTAPP)) || defined(AMIGAOS) || defined(RISCOS)
  10645.       terminal_sane(); # Terminal wieder in Normalzustand schalten
  10646.       #endif
  10647.       #ifdef DJUNIX
  10648.       if (cbrk) { setcbrk(cbrk); } # Ctrl-Break wieder zulassen
  10649.       _go32_want_ctrl_break(0); # Ctrl-Break wieder normal
  10650.       #endif
  10651.       #if defined(UNIX) || (defined(MSDOS) && !defined(WINDOWS)) || defined(RISCOS) || defined(WIN32_UNIX)
  10652.         _exit(exitcode);
  10653.       #endif
  10654.       #ifdef AMIGAOS
  10655.         exit_amiga(exitcode ? RETURN_FAIL : RETURN_OK);
  10656.       #endif
  10657.       # Wenn das nichts geholfen haben sollte:
  10658.       return exitcode;
  10659.     }}
  10660.  
  10661. # LISP-Interpreter verlassen
  10662. # > final_exitcode: 0 bei normalem Ende, 1 bei Abbruch
  10663.   nonreturning_function(global, quit, (void));
  10664.   global boolean final_exitcode = 0;
  10665.   global void quit()
  10666.     { # Erst den STACK bis STACK-Ende "unwinden":
  10667.       value1 = NIL; mv_count=0; # Bei UNWIND-PROTECT-Frames keine Werte retten
  10668.       unwind_protect_to_save.fun = (restart)&quit;
  10669.       loop
  10670.         { # Hört der STACK hier auf?
  10671.           if (eq(STACK_0,nullobj) && eq(STACK_1,nullobj)) break;
  10672.           if (mtypecode(STACK_0) & bit(frame_bit_t))
  10673.             # Bei STACK_0 beginnt ein Frame
  10674.             { unwind(); } # Frame auflösen
  10675.             else
  10676.             # STACK_0 enthält ein normales LISP-Objekt
  10677.             { skipSTACK(1); }
  10678.         }
  10679.       # Dann eine Abschiedsmeldung:
  10680.       { funcall(L(fresh_line),0); # (FRESH-LINE [*standard-output*])
  10681.         if (!argv_quiet)
  10682.           { # (WRITE-LINE "Bye." [*standard-output*]) :
  10683.             pushSTACK(OL(bye_string)); funcall(L(write_line),1);
  10684.       }   }
  10685.       close_all_files(); # alle Files schließen
  10686.       #ifdef DYNAMIC_FFI
  10687.       exit_ffi(); # FFI herunterfahren
  10688.       #endif
  10689.       #ifdef REXX
  10690.       close_rexx(); # Rexx-Kommunikation herunterfahren
  10691.       #endif
  10692.       #ifdef NEXTAPP
  10693.       nxterminal_exit(); # Terminal-Stream-Kommunikation herunterfahren
  10694.       #endif
  10695.       quit_sofort(final_exitcode); # Programm verlassen
  10696.     }
  10697.  
  10698. # ------------------------------------------------------------------------------
  10699. #                  Speichern und Laden von MEM-Files
  10700.  
  10701. #if defined(UNIX) || defined(DJUNIX) || defined(EMUNIX) || defined(WATCOM) || defined(RISCOS) || defined(WIN32_DOS) || defined(WIN32_UNIX)
  10702.   # Betriebssystem-Funktion read sichtbar machen:
  10703.     #undef read
  10704. #endif
  10705.  
  10706. # Flags, von denen das Format eines MEM-Files abhängt:
  10707.   local uint32 memflags =
  10708.     # Typcodeverteilung:
  10709.     #ifdef STANDARD_TYPECODES
  10710.       bit(0) |
  10711.     #endif
  10712.     #ifdef PACKED_TYPECODES
  10713.       bit(1) |
  10714.     #endif
  10715.     #ifdef SEVENBIT_TYPECODES
  10716.       bit(2) |
  10717.     #endif
  10718.     #ifdef SIXBIT_TYPECODES
  10719.       bit(3) |
  10720.     #endif
  10721.     #ifdef case_structure
  10722.       bit(4) |
  10723.     #endif
  10724.     #ifdef case_stream
  10725.       bit(5) |
  10726.     #endif
  10727.     #ifdef IMMUTABLE
  10728.       bit(6) |
  10729.     #endif
  10730.     # Codierung von Zahlen:
  10731.     #ifdef FAST_FLOAT
  10732.       bit(7) |
  10733.     #endif
  10734.     #ifdef FAST_DOUBLE
  10735.       bit(8) |
  10736.     #endif
  10737.     # Codierung von Streams:
  10738.     #ifdef STRM_WR_SS
  10739.       bit(9) |
  10740.     #endif
  10741.     # Codierung von strmtype:
  10742.     #ifdef HANDLES
  10743.       bit(10) |
  10744.     #endif
  10745.     #ifdef KEYBOARD
  10746.       bit(11) |
  10747.     #endif
  10748.     #ifdef SCREEN
  10749.       bit(12) |
  10750.     #endif
  10751.     #ifdef PRINTER
  10752.       bit(13) |
  10753.     #endif
  10754.     #ifdef PIPES
  10755.       bit(14) |
  10756.     #endif
  10757.     #ifdef XSOCKETS
  10758.       bit(15) |
  10759.     #endif
  10760.     #ifdef GENERIC_STREAMS
  10761.       bit(16) |
  10762.     #endif
  10763.     #ifdef SOCKET_STREAMS
  10764.       bit(17) |
  10765.     #endif
  10766.     0;
  10767.  
  10768. # Format:
  10769. # ein Header:
  10770.   typedef struct { uintL _magic; # Erkennung
  10771.                      #define memdump_magic  0x70768BD2UL
  10772.                    oint _oint_type_mask;
  10773.                    oint _oint_addr_mask;
  10774.                    tint _cons_type, _complex_type, _symbol_type, _system_type;
  10775.                    uintC _varobject_alignment;
  10776.                    uintC _hashtable_length;
  10777.                    uintC _pathname_length;
  10778.                    uintC _intDsize;
  10779.                    uint32 _memflags;
  10780.                    uintC _module_count;
  10781.                    uintL _module_names_size;
  10782.                    uintC _fsubr_anz;
  10783.                    uintC _pseudofun_anz;
  10784.                    uintC _symbol_anz;
  10785.                    uintL _page_alignment;
  10786.                    aint _subr_tab_addr;
  10787.                    aint _symbol_tab_addr;
  10788.                    #ifdef SPVW_MIXED_BLOCKS_OPPOSITE
  10789.                    aint _mem_varobjects_start;
  10790.                    aint _mem_varobjects_end;
  10791.                    aint _mem_conses_start;
  10792.                    aint _mem_conses_end;
  10793.                    #endif
  10794.                    #ifndef SPVW_MIXED_BLOCKS_OPPOSITE
  10795.                    uintC _heapcount;
  10796.                    #endif
  10797.                  }
  10798.           memdump_header;
  10799.   # dann die Modulnamen,
  10800.   # dann fsubr_tab, pseudofun_tab, symbol_tab,
  10801.   # und zu jedem Modul subr_addr, subr_anz, object_anz, subr_tab, object_tab,
  10802. #ifdef SPVW_MIXED_BLOCKS_OPPOSITE
  10803.   # dann die Objekte variabler Länge (zwischen mem.varobjects.heap_start und mem.varobjects.heap_end),
  10804.   # dann die Conses (zwischen mem.conses.heap_start und mem.conses.heap_end).
  10805. #else
  10806.   #if defined(SPVW_PURE_BLOCKS) || defined(TRIVIALMAP_MEMORY)
  10807.     # dann zu jedem Heap (Block) die Start- und Endadresse,
  10808.   #endif
  10809.   #ifdef SPVW_PAGES
  10810.     # SPVW_PAGES: dann zu jedem Heap die Anzahl der Pages,
  10811.     # dann zu jedem Heap und zu jeder Page des Heaps die Start- und Endadresse,
  10812.   #endif
  10813.   typedef struct { aint _page_start; aint _page_end; } memdump_page;
  10814.   # dann der Inhalt der Pages in derselben Reihenfolge.
  10815. #endif
  10816.  
  10817. # page_alignment = Alignment für die Page-Inhalte im File.
  10818. #if ((defined(SPVW_PURE_BLOCKS) && defined(SINGLEMAP_MEMORY)) || defined(TRIVIALMAP_MEMORY)) && defined(HAVE_MMAP)
  10819.   #define page_alignment  map_pagesize
  10820.   #define WRITE_page_alignment(position)  \
  10821.     { var reg4 uintL aligncount = (uintL)(-position) % page_alignment; \
  10822.       if (aligncount > 0)                                              \
  10823.         { # Ein Stück durchgenullten Speicher besorgen:                \
  10824.           var DYNAMIC_ARRAY(reg5,zeroes,uintB,aligncount);             \
  10825.           var reg1 uintB* ptr = &zeroes[0];                            \
  10826.           var reg2 uintL count;                                        \
  10827.           dotimespL(count,aligncount, { *ptr++ = 0; } );               \
  10828.           # und schreiben:                                             \
  10829.           WRITE(&zeroes[0],aligncount);                                \
  10830.           FREE_DYNAMIC_ARRAY(zeroes);                                  \
  10831.     }   }
  10832.   #define READ_page_alignment(position)  \
  10833.     { var reg4 uintL aligncount = (uintL)(-position) % page_alignment; \
  10834.       if (aligncount > 0)                                              \
  10835.         { var DYNAMIC_ARRAY(reg5,dummy,uintB,aligncount);              \
  10836.           READ(&dummy[0],aligncount);                                  \
  10837.           FREE_DYNAMIC_ARRAY(dummy);                                   \
  10838.     }   }
  10839. #else
  10840.   #define page_alignment  1
  10841.   #define WRITE_page_alignment(position)
  10842.   #define READ_page_alignment(position)
  10843. #endif
  10844.  
  10845. #ifdef AMIGA
  10846.   nonreturning_function(local, fehler_device_possibly_full, (object stream));
  10847.   local void fehler_device_possibly_full(stream)
  10848.     var reg2 object stream;
  10849.     {
  10850.       pushSTACK(TheStream(stream)->strm_file_truename); # Wert für Slot PATHNAME von FILE-ERROR
  10851.       //: DEUTSCH "Datenträger vermutlich voll."
  10852.       //: ENGLISH "device possibly full" 
  10853.       //: FRANCAIS "Disque peut-être plein."
  10854.       fehler(file_error,GETTEXT("device possibly full"));
  10855.     }
  10856. #endif
  10857. #if defined(UNIX) || defined(DJUNIX) || defined(EMUNIX) || defined(WATCOM) || defined(RISCOS)  || defined(WIN32_DOS) || defined(WIN32_UNIX)
  10858.   nonreturning_function(local, fehler_device_full, (object stream));
  10859.   local void fehler_device_full(stream)
  10860.     var reg2 object stream;
  10861.     {
  10862.       pushSTACK(TheStream(stream)->strm_file_truename); # Wert für Slot PATHNAME von FILE-ERROR
  10863.       //: DEUTSCH "Diskette/Platte voll."
  10864.       //: ENGLISH "disk full"
  10865.       //: FRANCAIS "Disque plein."
  10866.       fehler(file_error,GETTEXT("device full"));
  10867.     }
  10868. #endif
  10869.  
  10870. # UP, speichert Speicherabbild auf Diskette
  10871. # savemem(stream);
  10872. # > object stream: offener File-Output-Stream, wird geschlossen
  10873. # kann GC auslösen
  10874.   global void savemem (object stream);
  10875.   global void savemem(stream)
  10876.     var reg4 object stream;
  10877.     { # Wir brauchen den Stream nur wegen des für ihn bereitgestellten Handles.
  10878.       # Wir müssen ihn aber im Fehlerfalle schließen (der Aufrufer macht kein
  10879.       # WITH-OPEN-FILE, sondern nur OPEN). Daher bekommen wir den ganzen
  10880.       # Stream übergeben, um ihn schließen zu können.
  10881.       var reg3 Handle handle = TheHandle(TheStream(stream)->strm_file_handle);
  10882.       pushSTACK(stream); # Stream retten
  10883.       # Erst eine GC ausführen:
  10884.       gar_col();
  10885.       #ifdef AMIGAOS
  10886.         #define WRITE(buf,len)  \
  10887.           { begin_system_call();                                      \
  10888.            {var reg1 sintL ergebnis = Write(handle,(void*)buf,len);   \
  10889.             if (!(ergebnis==(sintL)(len)))                            \
  10890.               { stream_close(&STACK_0);                               \
  10891.                 if (ergebnis<0) { OS_error(); } # Fehler aufgetreten? \
  10892.                 fehler_device_possibly_full(STACK_0);                 \
  10893.               }                                                       \
  10894.             end_system_call();                                        \
  10895.           }}
  10896.       #endif
  10897.       #if defined(UNIX) || defined(DJUNIX) || defined(EMUNIX) || defined(WATCOM) || defined(RISCOS)  || defined(WIN32_DOS) || defined(WIN32_UNIX)
  10898.         #define WRITE(buf,len)  \
  10899.           { begin_system_call();                                            \
  10900.            {var reg1 sintL ergebnis = full_write(handle,(RW_BUF_T)buf,len); \
  10901.             if (!(ergebnis==(sintL)(len)))                                  \
  10902.               { stream_close(&STACK_0);                                     \
  10903.                 if (ergebnis<0) { OS_error(); } # Fehler aufgetreten?       \
  10904.                 fehler_device_full(STACK_0);                                \
  10905.               }                                                             \
  10906.             end_system_call();                                              \
  10907.           }}
  10908.       #endif
  10909.       # Grundinformation rausschreiben:
  10910.      {var memdump_header header;
  10911.       var reg7 uintL module_names_size;
  10912.       header._magic = memdump_magic;
  10913.       header._oint_type_mask = oint_type_mask;
  10914.       header._oint_addr_mask = oint_addr_mask;
  10915.       header._cons_type    = cons_type;
  10916.       header._complex_type = complex_type;
  10917.       header._symbol_type  = symbol_type;
  10918.       header._system_type  = system_type;
  10919.       header._varobject_alignment = varobject_alignment;
  10920.       header._hashtable_length = hashtable_length;
  10921.       header._pathname_length = pathname_length;
  10922.       header._intDsize = intDsize;
  10923.       header._memflags = memflags;
  10924.       header._module_count = module_count;
  10925.       { var reg1 module_* module;
  10926.         module_names_size = 0;
  10927.         for_modules(all_modules,
  10928.           { module_names_size += asciz_length(module->name)+1; }
  10929.           );
  10930.         module_names_size = round_up(module_names_size,varobject_alignment);
  10931.       }
  10932.       header._module_names_size = module_names_size;
  10933.       header._fsubr_anz     = fsubr_anz;
  10934.       header._pseudofun_anz = pseudofun_anz;
  10935.       header._symbol_anz    = symbol_anz;
  10936.       header._page_alignment = page_alignment;
  10937.       header._subr_tab_addr   = (aint)(&subr_tab);
  10938.       header._symbol_tab_addr = (aint)(&symbol_tab);
  10939.       #ifdef SPVW_MIXED_BLOCKS_OPPOSITE
  10940.       #if !defined(GENERATIONAL_GC)
  10941.       header._mem_varobjects_start = mem.varobjects.heap_start;
  10942.       header._mem_varobjects_end   = mem.varobjects.heap_end;
  10943.       header._mem_conses_start     = mem.conses.heap_start;
  10944.       header._mem_conses_end       = mem.conses.heap_end;
  10945.       #else # defined(GENERATIONAL_GC)
  10946.       header._mem_varobjects_start = mem.varobjects.heap_gen0_start;
  10947.       header._mem_varobjects_end   = mem.varobjects.heap_gen0_end;
  10948.       header._mem_conses_start     = mem.conses.heap_gen0_start;
  10949.       header._mem_conses_end       = mem.conses.heap_gen0_end;
  10950.       #endif
  10951.       #endif
  10952.       #ifndef SPVW_MIXED_BLOCKS_OPPOSITE
  10953.       header._heapcount = heapcount;
  10954.       #endif
  10955.       WRITE(&header,sizeof(header));
  10956.       # Modulnamen rausschreiben:
  10957.       { var DYNAMIC_ARRAY(_EMA_,module_names_buffer,char,module_names_size);
  10958.        {var reg2 char* ptr2 = &module_names_buffer[0];
  10959.         var reg3 module_* module;
  10960.         var reg4 uintC count;
  10961.         for_modules(all_modules,
  10962.           { var reg1 char* ptr1 = module->name;
  10963.             until ((*ptr2++ = *ptr1++) == '\0') ;
  10964.           });
  10965.         dotimesC(count,&module_names_buffer[module_names_size] - ptr2,
  10966.           { *ptr2++ = 0; }
  10967.           );
  10968.         WRITE(module_names_buffer,module_names_size);
  10969.         FREE_DYNAMIC_ARRAY(module_names_buffer);
  10970.       }}
  10971.       # fsubr_tab, pseudofun_tab, symbol_tab rausschreiben:
  10972.       WRITE(&fsubr_tab,sizeof(fsubr_tab));
  10973.       WRITE(&pseudofun_tab,sizeof(pseudofun_tab));
  10974.       WRITE(&symbol_tab,sizeof(symbol_tab));
  10975.       # Zu jedem Modul subr_addr, subr_anz, object_anz, subr_tab, object_tab rausschreiben:
  10976.       { var reg2 module_* module;
  10977.         for_modules(all_modules,
  10978.           { WRITE(&module->stab,sizeof(subr_*));
  10979.             WRITE(module->stab_size,sizeof(uintC));
  10980.             WRITE(module->otab_size,sizeof(uintC));
  10981.             WRITE(module->stab,*module->stab_size*sizeof(subr_));
  10982.             WRITE(module->otab,*module->otab_size*sizeof(object));
  10983.           });
  10984.       }
  10985.       #ifdef SPVW_MIXED_BLOCKS_OPPOSITE
  10986.       # Objekte variabler Länge rausschreiben:
  10987.       {var reg2 uintL len = header._mem_varobjects_end - header._mem_varobjects_start;
  10988.        WRITE(header._mem_varobjects_start,len);
  10989.       }
  10990.       # Conses rausschreiben:
  10991.       {var reg2 uintL len = header._mem_conses_end - header._mem_conses_start;
  10992.        WRITE(header._mem_conses_start,len);
  10993.       }
  10994.       #endif
  10995.       #ifndef SPVW_MIXED_BLOCKS_OPPOSITE
  10996.       #ifdef SPVW_PAGES
  10997.       {var reg6 uintL heapnr;
  10998.        for (heapnr=0; heapnr<heapcount; heapnr++)
  10999.          { var uintC pagecount = 0;
  11000.            map_heap(mem.heaps[heapnr],page, { pagecount++; } );
  11001.            WRITE(&pagecount,sizeof(pagecount));
  11002.       }  }
  11003.       #endif
  11004.       {var reg6 uintL heapnr;
  11005.        for (heapnr=0; heapnr<heapcount; heapnr++)
  11006.          {
  11007.            #if !defined(GENERATIONAL_GC)
  11008.            map_heap(mem.heaps[heapnr],page,
  11009.              { var memdump_page _page;
  11010.                _page._page_start = page->page_start;
  11011.                _page._page_end = page->page_end;
  11012.                WRITE(&_page,sizeof(_page));
  11013.              });
  11014.            #else # defined(GENERATIONAL_GC)
  11015.            var reg4 Heap* heap = &mem.heaps[heapnr];
  11016.            var memdump_page _page;
  11017.            _page._page_start = heap->heap_gen0_start;
  11018.            _page._page_end = heap->heap_gen0_end;
  11019.            WRITE(&_page,sizeof(_page));
  11020.            #endif
  11021.       }  }
  11022.       #if (defined(SPVW_PURE_BLOCKS) && defined(SINGLEMAP_MEMORY)) || defined(TRIVIALMAP_MEMORY)
  11023.        #if defined(HAVE_MMAP) # sonst ist page_alignment sowieso = 1
  11024.         # Alignment verwirklichen:
  11025.         { begin_system_call();
  11026.          {var reg1 sintL ergebnis = lseek(handle,0,SEEK_CUR); # File-Position holen
  11027.           end_system_call();
  11028.           if (ergebnis<0) { stream_close(&STACK_0); OS_error(); } # Fehler?
  11029.           WRITE_page_alignment(ergebnis);
  11030.         }}
  11031.        #endif
  11032.       #endif
  11033.       {var reg6 uintL heapnr;
  11034.        for (heapnr=0; heapnr<heapcount; heapnr++)
  11035.          {
  11036.            #if !defined(GENERATIONAL_GC)
  11037.            map_heap(mem.heaps[heapnr],page,
  11038.              { var reg2 uintL len = page->page_end - page->page_start;
  11039.                WRITE(page->page_start,len);
  11040.                WRITE_page_alignment(len);
  11041.              });
  11042.            #else # defined(GENERATIONAL_GC)
  11043.            var reg4 Heap* heap = &mem.heaps[heapnr];
  11044.            var reg2 uintL len = heap->heap_gen0_end - heap->heap_gen0_start;
  11045.            WRITE(heap->heap_gen0_start,len);
  11046.            WRITE_page_alignment(len);
  11047.            #endif
  11048.       }  }
  11049.       #endif
  11050.       #undef WRITE
  11051.       # Stream schließen (Stream-Buffer ist unverändert, aber dadurch wird
  11052.       # auch das Handle beim Betriebssystem geschlossen):
  11053.       stream_close(&STACK_0);
  11054.       skipSTACK(1);
  11055.     }}
  11056.  
  11057. # UP, lädt Speicherabbild von Diskette
  11058. # loadmem(filename);
  11059. # Zerstört alle LISP-Daten.
  11060.   #if defined(UNIX) || defined(WIN32_UNIX)
  11061.   local void loadmem_from_handle (int handle);
  11062.   #endif
  11063.   # Aktualisierung eines Objektes im Speicher:
  11064.   #ifdef SPVW_MIXED_BLOCKS_OPPOSITE
  11065.   local var oint offset_varobjects_o;
  11066.   local var oint offset_conses_o;
  11067.   #endif
  11068.   #ifdef TRIVIALMAP_MEMORY
  11069.   local var oint offset_heaps_o[heapcount];
  11070.   #define offset_varobjects_o  offset_heaps_o[0]
  11071.   #define offset_conses_o      offset_heaps_o[1]
  11072.   #endif
  11073.   #ifdef SPVW_PAGES
  11074.   local var struct { aint old_page_start; oint offset_page_o; } *offset_pages;
  11075.   #define addr_mask  ~(((oint_addr_mask>>oint_addr_shift) & ~ (wbit(oint_addr_relevant_len)-1)) << addr_shift) # meist = ~0
  11076.   #define pagenr_of(addr)  floor(addr,min_page_size_brutto)
  11077.   #define offset_pages_len  (pagenr_of((wbit(oint_addr_relevant_len)-1)<<addr_shift)+1)
  11078.   #endif
  11079.   #if !defined(SINGLEMAP_MEMORY)
  11080.   local var oint offset_symbols_o;
  11081.   #if !defined(MULTIMAP_MEMORY_TABLES)
  11082.   local var oint old_symbol_tab_o;
  11083.   #endif
  11084.   #endif
  11085.   typedef struct { oint low_o; oint high_o; oint offset_o; } offset_subrs_t;
  11086.   local var offset_subrs_t* offset_subrs;
  11087.   local var uintC offset_subrs_anz;
  11088.   local var struct fsubr_tab_ old_fsubr_tab;
  11089.   local var struct pseudofun_tab_ old_pseudofun_tab;
  11090.   local void loadmem_aktualisiere (object* objptr);
  11091.   local void loadmem_aktualisiere(objptr)
  11092.     var reg3 object* objptr;
  11093.     { switch (mtypecode(*objptr))
  11094.         { case_symbol: # Symbol
  11095.             #ifndef SPVW_PURE_BLOCKS
  11096.             #if !defined(MULTIMAP_MEMORY_TABLES)
  11097.             if (as_oint(*objptr) - old_symbol_tab_o
  11098.                 < ((oint)sizeof(symbol_tab)<<(oint_addr_shift-addr_shift))
  11099.                )
  11100.               # Symbol aus symbol_tab
  11101.               { *(oint*)objptr += offset_symbols_o; break; }
  11102.             #else
  11103.             if (as_oint(*objptr) - (oint)(&symbol_tab)
  11104.                 < (sizeof(symbol_tab)<<(oint_addr_shift-addr_shift))
  11105.                )
  11106.               # Symbol aus symbol_tab erfährt keine Verschiebung
  11107.               { break; }
  11108.             #endif
  11109.             # sonstige Symbole sind Objekte variabler Länge.
  11110.             #endif
  11111.           case_array:
  11112.           case_record:
  11113.           case_bignum:
  11114.           #ifndef WIDE
  11115.           case_ffloat:
  11116.           #endif
  11117.           case_dfloat:
  11118.           case_lfloat:
  11119.             # Objekt variabler Länge
  11120.             #ifdef SPVW_MIXED_BLOCKS
  11121.             *(oint*)objptr += offset_varobjects_o; break;
  11122.             #endif
  11123.           case_cons: case_ratio: case_complex:
  11124.             # Zwei-Pointer-Objekt
  11125.             #ifdef SPVW_MIXED_BLOCKS
  11126.             *(oint*)objptr += offset_conses_o; break;
  11127.             #endif
  11128.             #ifdef SPVW_PAGES
  11129.             {var reg2 aint addr = upointer(*(object*)objptr); # Adresse
  11130.              # Da Pages eine minimale Länge haben, also die Anfangsadressen
  11131.              # unterschiedlicher Pages sich um mindestens min_page_size_brutto
  11132.              # unterscheiden, ist es ganz einfach, aus der Adresse auf die
  11133.              # Page zurückzuschließen:
  11134.              var reg1 uintL pagenr = pagenr_of(addr & addr_mask);
  11135.              if (addr < offset_pages[pagenr].old_page_start) { pagenr--; }
  11136.              *(oint*)objptr += offset_pages[pagenr].offset_page_o;
  11137.             }
  11138.             break;
  11139.             #endif
  11140.             #ifdef SPVW_PURE_BLOCKS # SINGLEMAP_MEMORY
  11141.             break; # Alles Bisherige erfährt keine Verschiebung
  11142.             #endif
  11143.           case_subr: # SUBR
  11144.             {var reg2 oint addr = *(oint*)objptr;
  11145.              var reg3 offset_subrs_t* ptr = offset_subrs;
  11146.              var reg4 uintC count;
  11147.              dotimespC(count,offset_subrs_anz,
  11148.                { if ((ptr->low_o <= addr) && (addr < ptr->high_o))
  11149.                    { *(oint*)objptr += ptr->offset_o; goto found_subr; }
  11150.                  ptr++;
  11151.                });
  11152.             }
  11153.             # SUBR nicht gefunden -> #<UNBOUND>
  11154.             *objptr = unbound;
  11155.             found_subr:
  11156.             break;
  11157.           case_system: # Frame-Pointer oder Read-Label oder System-Konstante
  11158.             if ((*(oint*)objptr & wbit(0+oint_addr_shift)) ==0)
  11159.               # Frame-Pointer -> #<DISABLED>
  11160.               { *objptr = disabled; }
  11161.             break;
  11162.           case_machine: # Pseudo-Funktion/Fsubr-Funktion oder sonstiger Maschinenpointer
  11163.             # Umsetzung old_fsubr_tab -> fsubr_tab, old_pseudofun_tab -> pseudofun_tab :
  11164.             {
  11165.               #if (machine_type==0)
  11166.               var reg4 void* addr = (void*)ThePseudofun(*objptr);
  11167.               #else # muß zum Vergleichen die Typinfo wegnehmen
  11168.               var reg4 void* addr = (void*)upointer(*objptr);
  11169.               #endif
  11170.               { var reg2 uintC i = fsubr_anz;
  11171.                 var reg1 fsubr_* ptr = &((fsubr_*)(&old_fsubr_tab))[fsubr_anz];
  11172.                 until (i==0)
  11173.                   { i--;
  11174.                     if ((void*) *--ptr == addr)
  11175.                       { # Fsubr-Funktion
  11176.                         *objptr = type_pointer_object(machine_type,((fsubr_*)(&fsubr_tab))[i]);
  11177.                         break;
  11178.               }   }   }
  11179.               { var reg2 uintC i = pseudofun_anz;
  11180.                 var reg1 Pseudofun* ptr = &((Pseudofun*)(&old_pseudofun_tab))[pseudofun_anz];
  11181.                 until (i==0)
  11182.                   { i--;
  11183.                     if ((void*) *--ptr == addr)
  11184.                       { # Pseudo-Funktion
  11185.                         *objptr = type_pointer_object(machine_type,((Pseudofun*)(&pseudofun_tab))[i]);
  11186.                         break;
  11187.               }   }   }
  11188.               # sonstiger Maschinenpointer
  11189.               break;
  11190.             }
  11191.           case_char:
  11192.           case_fixnum:
  11193.           case_sfloat:
  11194.           #ifdef WIDE
  11195.           case_ffloat:
  11196.           #endif
  11197.             break;
  11198.           default: /*NOTREACHED*/ abort();
  11199.     }   }
  11200.  
  11201.   #ifdef AMIGAOS
  11202.     #define READ(buf,len)  \
  11203.       { begin_system_call();                                   \
  11204.        {var reg1 sintL ergebnis = Read(handle,(void*)buf,len); \
  11205.         end_system_call();                                     \
  11206.         if (ergebnis<0) return -1;                             \
  11207.         if (!(ergebnis==(sintL)(len))) return -2;              \
  11208.       }}
  11209.   #endif
  11210.   #if defined(UNIX) || defined(DJUNIX) || defined(EMUNIX) || defined(WATCOM) || defined(RISCOS) || defined(WIN32_DOS) || defined(WIN32_UNIX)
  11211.     #define READ(buf,len)  \
  11212.       { begin_system_call();                                           \
  11213.        {var reg1 sintL ergebnis = full_read(handle,(RW_BUF_T)buf,len); \
  11214.         end_system_call();                                             \
  11215.         if (ergebnis<0) return -1;                                     \
  11216.         if (!(ergebnis==(sintL)(len))) return -2;                      \
  11217.         file_offset+=len;                                              \
  11218.       }}
  11219.   #endif
  11220.  
  11221.   local sintL read_old_subr_tab (module_ **old_module, uintC old_subr_anz, int handle);
  11222.   local sintL read_old_subr_tab(old_module, old_subr_anz, handle)
  11223.     var reg4 module_ **old_module;
  11224.     var reg5 uintC old_subr_anz;
  11225.     var reg6 int handle;
  11226.     { var reg7 sintL file_offset = 0;
  11227.       var DYNAMIC_ARRAY(_EMA_,old_subr_tab,subr_,old_subr_anz);
  11228.       READ(old_subr_tab,old_subr_anz*sizeof(subr_));
  11229.      {var reg2 subr_* ptr1 = old_subr_tab;
  11230.       var reg1 subr_* ptr2 = (*old_module)->stab;
  11231.       var reg3 uintC count;
  11232.       #define PRINT_VALS(field) \
  11233.         asciz_out(STRINGIFY(field)); \
  11234.         asciz_out(":  "); \
  11235.         dez_out(ptr1->field); \
  11236.         asciz_out(" / "); \
  11237.         dez_out(ptr2->field); \
  11238.         asciz_out(NLstring);
  11239.       dotimespC(count,old_subr_anz,
  11240.         { 
  11241.           if (!(   (ptr1->req_anz == ptr2->req_anz)
  11242.                 && (ptr1->opt_anz == ptr2->opt_anz)
  11243.                 && (ptr1->rest_flag == ptr2->rest_flag)
  11244.                 && (ptr1->key_flag == ptr2->key_flag)
  11245.                 && (ptr1->key_anz == ptr2->key_anz)
  11246.              ) )
  11247.            {
  11248.              PRINT_VALS(req_anz);
  11249.              PRINT_VALS(opt_anz);
  11250.              PRINT_VALS(rest_flag);
  11251.              PRINT_VALS(key_flag);
  11252.              PRINT_VALS(key_anz);
  11253.              return -2;
  11254.            }
  11255.           ptr2->name = ptr1->name; ptr2->keywords = ptr1->keywords;
  11256.           ptr2->argtype = ptr1->argtype;
  11257.           ptr1++; ptr2++;
  11258.         });
  11259.       #undef PRINT_VALS
  11260.      }
  11261.      FREE_DYNAMIC_ARRAY(old_subr_tab);
  11262.      return file_offset;
  11263.     }
  11264.  
  11265.   local sintL read_subr_and_object_tab (uintC module_count, module_ **old_modules, int handle);
  11266.   local sintL read_subr_and_object_tab(module_count, old_modules, handle)
  11267.     uintC module_count;
  11268.     module_ **old_modules;
  11269.     int handle;
  11270.     # Zu jedem Modul subr_addr, subr_anz, object_anz, subr_tab, object_tab lesen:
  11271.     {var reg4 module_* * old_module = &old_modules[0];
  11272.      var reg5 offset_subrs_t* offset_subrs_ptr = &offset_subrs[0];
  11273.      var reg6 uintC count;
  11274.      var reg7 uintL file_offset = 0;
  11275.      dotimespC(count,1+module_count,
  11276.        { var subr_* old_subr_addr;
  11277.          var uintC old_subr_anz;
  11278.          var uintC old_object_anz;
  11279.          READ(&old_subr_addr,sizeof(subr_*));
  11280.          READ(&old_subr_anz,sizeof(uintC));
  11281.          READ(&old_object_anz,sizeof(uintC));
  11282.          if (!(old_subr_anz == *(*old_module)->stab_size)) return -2;
  11283.          if (!(old_object_anz == *(*old_module)->otab_size)) return -2;
  11284.          offset_subrs_ptr->low_o = as_oint(subr_tab_ptr_as_object(old_subr_addr));
  11285.          offset_subrs_ptr->high_o = as_oint(subr_tab_ptr_as_object(old_subr_addr+old_subr_anz));
  11286.          offset_subrs_ptr->offset_o = as_oint(subr_tab_ptr_as_object((*old_module)->stab)) - offset_subrs_ptr->low_o;
  11287.          if (old_subr_anz > 0) 
  11288.            { var reg8 sintL offset = read_old_subr_tab(old_module, old_subr_anz, handle);
  11289.              if (offset < 0) return offset;
  11290.              file_offset += offset;
  11291.            }
  11292.          if (old_object_anz > 0)
  11293.            { READ((*old_module)->otab,old_object_anz*sizeof(object)); }
  11294.          old_module++; offset_subrs_ptr++;
  11295.        });
  11296.        return file_offset;
  11297.     }
  11298.   #undef READ
  11299.  
  11300.   local void loadmem(filename)
  11301.     char* filename;
  11302.     { # File zum Lesen öffnen:
  11303.       begin_system_call();
  11304.      {
  11305.       #ifdef AMIGAOS
  11306.       var reg4 Handle handle = Open(filename,MODE_OLDFILE);
  11307.       if (handle==Handle_NULL) goto abbruch1;
  11308.       #endif
  11309.       #if defined(DJUNIX) || defined(EMUNIX) || defined(WATCOM) || defined(WIN32_DOS) || defined(WIN32_UNIX)
  11310.       var reg4 int handle = open(filename,O_RDONLY);
  11311.       if (handle<0) goto abbruch1;
  11312.       setmode(handle,O_BINARY);
  11313.       #endif
  11314.       #if defined(UNIX) || defined(RISCOS)
  11315.       var reg4 int handle = OPEN(filename,O_RDONLY,my_open_mask);
  11316.       if (handle<0) goto abbruch1;
  11317.       #endif
  11318.       end_system_call();
  11319.   #if defined(UNIX) || defined(WIN32_UNIX)
  11320.       loadmem_from_handle(handle);
  11321.       return;
  11322.       abbruch1:
  11323.         {var reg3 int abbruch_errno = errno;
  11324.          asciz_out(program_name); asciz_out(": ");
  11325.          //: DEUTSCH "Betriebssystem-Fehler beim Versuch, das Initialisierungsfile `"
  11326.          //: ENGLISH "operating system error during load of initialisation file `"
  11327.          //: FRANCAIS "Erreur système pendant le chargement du fichier d'initialisation `"
  11328.          asciz_out(GETTEXT("OS error during load of init file `'"));
  11329.          asciz_out(filename);
  11330.          //: DEUTSCH "' zu laden."
  11331.          //: ENGLISH "'"
  11332.          //: FRANCAIS "'."
  11333.          asciz_out(GETTEXT("[end]operating system error during load of initialisation file"));
  11334.          errno_out(abbruch_errno);
  11335.         }
  11336.         goto abbruch_quit;
  11337.       abbruch_quit:
  11338.         # Abbruch.
  11339.         quit_sofort(1);
  11340.     }}
  11341.   local void loadmem_from_handle(handle)
  11342.     var reg4 int handle;
  11343.     {{
  11344.   #endif
  11345.       {
  11346.        #if (defined(SPVW_PURE_BLOCKS) && defined(SINGLEMAP_MEMORY)) || defined(TRIVIALMAP_MEMORY)
  11347.          #if defined(HAVE_MMAP)
  11348.          local var boolean use_mmap = TRUE;
  11349.          #endif
  11350.          var reg9 uintL file_offset;
  11351.          #define set_file_offset(x)  file_offset = (x)
  11352.          #define inc_file_offset(x)  file_offset += (uintL)(x)
  11353.        #else
  11354.          #define set_file_offset(x)
  11355.          #define inc_file_offset(x)
  11356.        #endif
  11357.        #ifdef AMIGAOS
  11358.          #define READ(buf,len)  \
  11359.            { begin_system_call();                                   \
  11360.             {var reg1 sintL ergebnis = Read(handle,(void*)buf,len); \
  11361.              end_system_call();                                     \
  11362.              if (ergebnis<0) goto abbruch1;                         \
  11363.              if (!(ergebnis==(sintL)(len))) goto abbruch2;          \
  11364.            }}
  11365.        #endif
  11366.        #if defined(UNIX) || defined(DJUNIX) || defined(EMUNIX) || defined(WATCOM) || defined(RISCOS) || defined(WIN32_DOS) || defined(WIN32_UNIX)
  11367.          #define READ(buf,len)  \
  11368.            { begin_system_call();                                           \
  11369.             {var reg1 sintL ergebnis = full_read(handle,(RW_BUF_T)buf,len); \
  11370.              end_system_call();                                             \
  11371.              if (ergebnis<0) goto abbruch1;                                 \
  11372.              if (!(ergebnis==(sintL)(len))) goto abbruch2;                  \
  11373.              inc_file_offset(len);                                          \
  11374.            }}
  11375.        #endif
  11376.        begin_read:
  11377.        set_file_offset(0);
  11378.        # Grundinformation lesen:
  11379.        {var memdump_header header;
  11380.         READ(&header,sizeof(header));
  11381.         if (!(header._magic == memdump_magic))
  11382.           {
  11383.             #if defined(UNIX) || defined(WIN32_UNIX)
  11384.             # Versuche, das File on the fly mit GZIP zu dekomprimieren.
  11385.             var reg1 uintB* file_header = (uintB*)&header; # benutze sizeof(header) >= 2
  11386.             if (file_header[0] == '#' && file_header[1] == '!') # executable magic ?
  11387.               { # erste Textzeile überlesen
  11388.                 var char c;
  11389.                 begin_system_call();
  11390.                 if ( lseek(handle,-(long)sizeof(header),SEEK_CUR) <0) goto abbruch1; # im File zurück an den Anfang
  11391.                 do { READ(&c,1); } until (c=='\n');
  11392.                 end_system_call();
  11393.                 #if ((defined(SPVW_PURE_BLOCKS) && defined(SINGLEMAP_MEMORY)) || defined(TRIVIALMAP_MEMORY)) && defined(HAVE_MMAP)
  11394.                 use_mmap = FALSE; # Die File-Offsets haben sich verschoben!
  11395.                 #endif
  11396.                 goto begin_read;
  11397.               }
  11398.             if (file_header[0] == 0x1F && file_header[1] == 0x8B) # gzip magic ?
  11399.               { # Pipe aufmachen, siehe make_pipe_input_stream in STREAM.D
  11400.                 var int handles[2];
  11401.                 var reg2 int child;
  11402.                 begin_system_call();
  11403.                 if ( lseek(handle,-(long)sizeof(header),SEEK_CUR) <0) goto abbruch1; # im File zurück an den Anfang
  11404.                 if (!( pipe(handles) ==0)) goto abbruch1;
  11405.                 if ((child = vfork()) ==0)
  11406.                   { if ( dup2(handles[1],stdout_handle) >=0)
  11407.                       if ( CLOSE(handles[1]) ==0)
  11408.                         if ( CLOSE(handles[0]) ==0)
  11409.                           if ( dup2(handle,stdin_handle) >=0) # Das File sei der Input der Dekompression
  11410.                             # Dekompressor aufrufen. NB: "gzip -d" == "gunzip"
  11411.                             #if 0
  11412.                                execl("/bin/sh","/bin/sh","-c","gzip -d -c",NULL);
  11413.                             #else # so geht's auch ohne die Shell
  11414.                               execlp("gzip","gzip","-d","-c",NULL);
  11415.                             #endif
  11416.                     _exit(-1);
  11417.                   }
  11418.                 if (child==-1)
  11419.                   { CLOSE(handles[1]); CLOSE(handles[0]); goto abbruch1; }
  11420.                 if (!( CLOSE(handles[1]) ==0)) goto abbruch1;
  11421.                 if (!( CLOSE(handle) ==0)) goto abbruch1;
  11422.                 end_system_call();
  11423.                 #if ((defined(SPVW_PURE_BLOCKS) && defined(SINGLEMAP_MEMORY)) || defined(TRIVIALMAP_MEMORY)) && defined(HAVE_MMAP)
  11424.                 use_mmap = FALSE; # Von einer Pipe kann man kein mmap() machen!
  11425.                 #endif
  11426.                 loadmem_from_handle(handles[0]); # Wir lesen ab jetzt von der Pipe
  11427.                 begin_system_call();
  11428.                 wait2(child); # Zombie-Child entfernen
  11429.                 end_system_call();
  11430.                 return;
  11431.               }
  11432.             #endif
  11433.             goto abbruch2;
  11434.           }
  11435.         if (!(header._oint_type_mask == oint_type_mask)) goto abbruch2;
  11436.         if (!(header._oint_addr_mask == oint_addr_mask)) goto abbruch2;
  11437.         if (!(header._cons_type == cons_type)) goto abbruch2;
  11438.         if (!(header._complex_type == complex_type)) goto abbruch2;
  11439.         if (!(header._symbol_type == symbol_type)) goto abbruch2;
  11440.         if (!(header._system_type == system_type)) goto abbruch2;
  11441.         if (!(header._varobject_alignment == varobject_alignment)) goto abbruch2;
  11442.         if (!(header._hashtable_length == hashtable_length)) goto abbruch2;
  11443.         if (!(header._pathname_length == pathname_length)) goto abbruch2;
  11444.         if (!(header._intDsize == intDsize)) goto abbruch2;
  11445.         if (!(header._memflags == memflags)) goto abbruch2;
  11446.         if (!(header._fsubr_anz == fsubr_anz)) goto abbruch2;
  11447.         if (!(header._pseudofun_anz == pseudofun_anz)) goto abbruch2;
  11448.         if (!(header._symbol_anz == symbol_anz)) goto abbruch2;
  11449.         if (!(header._page_alignment == page_alignment)) goto abbruch2;
  11450.         #ifndef SPVW_MIXED_BLOCKS_OPPOSITE
  11451.         if (!(header._heapcount == heapcount)) goto abbruch2;
  11452.         #endif
  11453.         #ifdef SPVW_MIXED_BLOCKS_OPPOSITE
  11454.         # Offsets berechnen (Offset = neue Adresse - alte Adresse):
  11455.         {var reg5 sintL offset_varobjects = # Offset für Objekte variabler Länge
  11456.            mem.varobjects.heap_start - header._mem_varobjects_start;
  11457.          var reg5 sintL offset_conses = # Offset für Zwei-Pointer-Objekte
  11458.            mem.conses.heap_end - header._mem_conses_end;
  11459.          # neue Speicheraufteilung berechnen:
  11460.          mem.varobjects.heap_end = header._mem_varobjects_end + offset_varobjects;
  11461.          mem.conses.heap_start = header._mem_conses_start + offset_conses;
  11462.          # Feststellen, ob der Speicherplatz reicht:
  11463.          # Er reicht genau dann, wenn
  11464.          # geforderter Platz <= vorhandener Platz  <==>
  11465.          # header._mem_conses_end-header._mem_conses_start + header._mem_varobjects_end-header._mem_varobjects_start
  11466.          #   <= mem.conses.heap_end - mem.varobjects.heap_start  <==>
  11467.          # header._mem_varobjects_end + mem.varobjects.heap_start-header._mem_varobjects_start
  11468.          #   <= header._mem_conses_start + mem.conses.heap_end-header._mem_conses_end  <==>
  11469.          # mem.varobjects.heap_end <= mem.conses.heap_start
  11470.          if (!( (saint)(mem.varobjects.heap_end) <= (saint)(mem.conses.heap_start) )) goto abbruch3;
  11471.          # Aktualisierung vorbereiten:
  11472.          offset_varobjects_o = (oint)offset_varobjects << (oint_addr_shift-addr_shift);
  11473.          offset_conses_o = (oint)offset_conses << (oint_addr_shift-addr_shift);
  11474.         }
  11475.         #endif
  11476.         #ifdef SPVW_PURE_BLOCKS # SINGLEMAP_MEMORY
  11477.         if (!((aint)(&subr_tab) == header._subr_tab_addr)) goto abbruch2;
  11478.         if (!((aint)(&symbol_tab) == header._symbol_tab_addr)) goto abbruch2;
  11479.         #else
  11480.         offset_symbols_o = ((oint)(aint)(&symbol_tab) - (oint)header._symbol_tab_addr) << (oint_addr_shift-addr_shift);
  11481.         #ifdef MULTIMAP_MEMORY_TABLES
  11482.         if (!(offset_symbols_o == 0)) goto abbruch2;
  11483.         #else
  11484.         old_symbol_tab_o = as_oint(type_pointer_object(symbol_type,header._symbol_tab_addr));
  11485.         #endif
  11486.         #endif
  11487.         # Offset-der-SUBRs-Tabelle initialisieren:
  11488.         offset_subrs_anz = 1+header._module_count;
  11489.         begin_system_call();
  11490.         offset_subrs = malloc(offset_subrs_anz*sizeof(*offset_subrs));
  11491.         end_system_call();
  11492.         if (offset_subrs==NULL) goto abbruch3;
  11493.         # Modulnamen lesen und mit den existierenden Modulen vergleichen:
  11494.         {var DYNAMIC_ARRAY(_EMA_,old_modules,module_*,1+header._module_count);
  11495.          {var DYNAMIC_ARRAY(_EMA_,module_names_buffer,char,header._module_names_size);
  11496.           READ(module_names_buffer,header._module_names_size);
  11497.           { var reg4 module_* * old_module = &old_modules[0];
  11498.             var reg3 char* old_name = &module_names_buffer[0];
  11499.             var reg2 uintC count;
  11500.             dotimespC(count,1+header._module_count,
  11501.               { var reg1 module_* module;
  11502.                 for_modules(all_modules,
  11503.                   { if (asciz_equal(old_name,module->name))
  11504.                       goto found_module;
  11505.                   });
  11506.                 # old_name nicht gefunden
  11507.                 goto abbruch2;
  11508.                 found_module:
  11509.                 # Das Lesen der Moduldaten vom File initialisiert das Modul.
  11510.                 module->initialized = TRUE;
  11511.                 *old_module++ = module;
  11512.                 old_name += asciz_length(old_name)+1;
  11513.               });
  11514.           }
  11515.           FREE_DYNAMIC_ARRAY(module_names_buffer);
  11516.          }
  11517.          # fsubr_tab, pseudofun_tab, symbol_tab lesen:
  11518.          READ(&old_fsubr_tab,sizeof(fsubr_tab));
  11519.          READ(&old_pseudofun_tab,sizeof(pseudofun_tab));
  11520.          READ(&symbol_tab,sizeof(symbol_tab));
  11521.  
  11522.          { sintL offset = read_subr_and_object_tab (header._module_count, old_modules, handle);
  11523.            if (offset == -1) goto abbruch1;
  11524.            elif (offset == -2) goto abbruch2;
  11525.            elif (offset < 0) { abort(); }
  11526.            else inc_file_offset(offset);
  11527.          }
  11528.  
  11529.          # subr_tab, object_tab der anderen Module vorinitialisieren:
  11530.          { var reg3 module_* module;
  11531.            for_modules(all_modules,
  11532.              { if (!module->initialized)
  11533.                  { { var reg1 subr_* ptr = module->stab; # subr_tab durchgehen
  11534.                      var reg2 uintC count;
  11535.                      dotimesC(count,*module->stab_size, { ptr->name = NIL; ptr->keywords = NIL; ptr++; });
  11536.                    }
  11537.                    { var reg1 object* ptr = module->otab; # object_tab durchgehen
  11538.                      var reg2 uintC count;
  11539.                      dotimesC(count,*module->otab_size, { *ptr++ = NIL; });
  11540.                  } }
  11541.              });
  11542.          }
  11543.          #ifdef SPVW_PURE_BLOCKS
  11544.          # Start- und Endadressen jedes Heaps gleich in mem.heaps[] übernehmen:
  11545.          {var reg6 uintL heapnr;
  11546.           for (heapnr=0; heapnr<heapcount; heapnr++)
  11547.             { map_heap(mem.heaps[heapnr],page,
  11548.                 { var memdump_page _page;
  11549.                   READ(&_page,sizeof(_page));
  11550.                   page->page_start = _page._page_start;
  11551.                   page->page_end = _page._page_end;
  11552.                 });
  11553.          }  }
  11554.          #endif
  11555.          #ifdef TRIVIALMAP_MEMORY
  11556.          # Start- und Endadressen jedes Heaps lesen und die Größe in mem.heaps[]
  11557.          # auf dieselbe Länge bringen:
  11558.          {var reg6 uintL heapnr;
  11559.           for (heapnr=0; heapnr<heapcount; heapnr++)
  11560.             { map_heap(mem.heaps[heapnr],page,
  11561.                 { var memdump_page _page;
  11562.                   READ(&_page,sizeof(_page));
  11563.                   page->page_end = page->page_start + (_page._page_end - _page._page_start);
  11564.                   offset_heaps_o[heapnr] = (oint)(sintL)(page->page_start - _page._page_start) << (oint_addr_shift-addr_shift);
  11565.                 });
  11566.          }  }
  11567.          #endif
  11568.          #ifdef SPVW_PAGES
  11569.          {var reg8 uintC total_pagecount;
  11570.           #ifdef SPVW_BLOCKS
  11571.           total_pagecount = heapcount;
  11572.           #endif
  11573.           #ifdef SPVW_PAGES
  11574.           var uintC pagecounts[heapcount];
  11575.           # Pages-per-Heap-Tabelle initialisieren:
  11576.           READ(&pagecounts,sizeof(pagecounts));
  11577.           # total_pagecount berechnen:
  11578.           {var reg1 uintL heapnr;
  11579.            total_pagecount = 0;
  11580.            for (heapnr=0; heapnr<heapcount; heapnr++)
  11581.              { total_pagecount += pagecounts[heapnr]; }
  11582.           }
  11583.           #endif
  11584.           # Offset-per-Page-Tabelle initialisieren:
  11585.           begin_system_call();
  11586.           offset_pages = malloc(offset_pages_len*sizeof(*offset_pages));
  11587.           end_system_call();
  11588.           if (offset_pages==NULL) goto abbruch3;
  11589.           {var reg1 uintL pagenr;
  11590.            for (pagenr=0; pagenr<offset_pages_len; pagenr++)
  11591.              { offset_pages[pagenr].old_page_start = ~0L;
  11592.                offset_pages[pagenr].offset_page_o = 0;
  11593.           }  }
  11594.           # Adressen und Größen der Pages lesen und Pages allozieren:
  11595.           { var DYNAMIC_ARRAY(reg10,old_pages,memdump_page,total_pagecount);
  11596.             READ(old_pages,total_pagecount*sizeof(memdump_page));
  11597.            {var DYNAMIC_ARRAY(reg10,new_pages,aint,total_pagecount);
  11598.             {var reg6 memdump_page* old_page_ptr = &old_pages[0];
  11599.              var reg6 aint* new_page_ptr = &new_pages[0];
  11600.              var reg6 uintL heapnr;
  11601.              for (heapnr=0; heapnr<heapcount; heapnr++)
  11602.                {var reg6 Pages* pages_ptr = &mem.heaps[heapnr].inuse;
  11603.                 #ifdef SPVW_PAGES
  11604.                 var reg5 uintC pagecount = pagecounts[heapnr];
  11605.                 until (pagecount==0)
  11606.                   {
  11607.                 #endif
  11608.                     var reg5 uintL need = old_page_ptr->_page_end - old_page_ptr->_page_start;
  11609.                     var reg5 uintL size1 = round_up(need,sizeof(cons_));
  11610.                     if (size1 < std_page_size) { size1 = std_page_size; }
  11611.                     { var reg7 uintL size2 = size1 + sizeof_NODE + (varobject_alignment-1);
  11612.                       var reg6 aint addr = (aint)mymalloc(size2);
  11613.                       var reg1 Pages page;
  11614.                       if ((void*)addr == NULL) goto abbruch3;
  11615.                       #if !defined(AVL_SEPARATE)
  11616.                       page = (Pages)addr;
  11617.                       #else
  11618.                       begin_system_call();
  11619.                       page = (NODE*)malloc(sizeof(NODE));
  11620.                       end_system_call();
  11621.                       if (page == NULL) goto abbruch3;
  11622.                       #endif
  11623.                       # Page vom Betriebssystem bekommen.
  11624.                       page->m_start = addr; page->m_length = size2;
  11625.                       # Initialisieren:
  11626.                       page->page_start = page_start0(page);
  11627.                       page->page_end = page->page_start + need;
  11628.                       page->page_room = size1 - need;
  11629.                       # Diesem Heap zuschlagen:
  11630.                       *pages_ptr = AVL(AVLID,insert1)(page,*pages_ptr);
  11631.                       *new_page_ptr = page->page_start;
  11632.                       {var reg4 aint old_page_start = old_page_ptr->_page_start;
  11633.                        var reg4 aint old_page_end = old_page_ptr->_page_end;
  11634.                        var reg4 oint offset_page_o = ((oint)page->page_start - (oint)old_page_start) << (oint_addr_shift-addr_shift);
  11635.                        var reg1 uintL pagenr = pagenr_of(old_page_start & addr_mask);
  11636.                        do { if (!(offset_pages[pagenr].old_page_start == ~0L)) { abort(); }
  11637.                             offset_pages[pagenr].old_page_start = old_page_start;
  11638.                             offset_pages[pagenr].offset_page_o = offset_page_o;
  11639.                             pagenr++;
  11640.                           }
  11641.                           while (pagenr < pagenr_of(old_page_end & addr_mask));
  11642.                     } }
  11643.                     old_page_ptr++; new_page_ptr++;
  11644.                 #ifdef SPVW_PAGES
  11645.                     pagecount--;
  11646.                   }
  11647.                 #endif
  11648.             }  }
  11649.             # Inhalt der Pages lesen:
  11650.             {var reg6 memdump_page* old_page_ptr = &old_pages[0];
  11651.              var reg6 aint* new_page_ptr = &new_pages[0];
  11652.              until (total_pagecount == 0)
  11653.                { var reg2 uintL len = old_page_ptr->_page_end - old_page_ptr->_page_start;
  11654.                  READ(*new_page_ptr,len);
  11655.                  old_page_ptr++; new_page_ptr++;
  11656.                  total_pagecount--;
  11657.             }  }
  11658.             FREE_DYNAMIC_ARRAY(new_pages);
  11659.            }
  11660.            FREE_DYNAMIC_ARRAY(old_pages);
  11661.           }
  11662.          }
  11663.          #endif
  11664.          #if defined(SPVW_PURE_BLOCKS) || defined(TRIVIALMAP_MEMORY) # SINGLEMAP_MEMORY || TRIVIALMAP_MEMORY
  11665.          # Alignment verwirklichen:
  11666.          READ_page_alignment(file_offset);
  11667.          # Inhalt der Blöcke lesen:
  11668.          {var reg6 uintL heapnr;
  11669.           for (heapnr=0; heapnr<heapcount; heapnr++)
  11670.             { var reg2 Heap* heapptr = &mem.heaps[heapnr];
  11671.               var reg3 uintL len = heapptr->heap_end - heapptr->heap_start;
  11672.               var reg4 uintL map_len = round_up(len,map_pagesize);
  11673.               heapptr->heap_limit = heapptr->heap_start + map_len;
  11674.               if (map_len > 0)
  11675.                 {
  11676.                   #if defined(HAVE_MMAP)
  11677.                   # Wenn möglich, legen wir uns das Initialisierungsfile in den Speicher.
  11678.                   # Das sollte den Start beschleunigen und unnötiges Laden bis zur
  11679.                   # ersten GC verzögern.
  11680.                   # Hierzu ist das page_alignment nötig!
  11681.                   if (use_mmap)
  11682.                     { if (!( (void*) mmap((void*)(heapptr->heap_start),map_len,
  11683.                                           PROT_READ | PROT_WRITE,
  11684.                                           MAP_FIXED | MAP_PRIVATE,
  11685.                                           handle,file_offset
  11686.                                          )
  11687.                              == (void*)(-1)
  11688.                          ) )
  11689.                         {
  11690.                           #if 0 # unnötig, da mmap() kein lseek() braucht und danach nur noch CLOSE(handle) kommt.
  11691.                           if ( lseek(handle,map_len,SEEK_CUR) <0) goto abbruch1;
  11692.                           #endif
  11693.                           inc_file_offset(map_len);
  11694.                           goto block_done;
  11695.                         }
  11696.                         else
  11697.                         { 
  11698.                           //: DEUTSCH "Kann das Initialisierungsfile nicht in den Speicher legen."
  11699.                           //: ENGLISH "Cannot map the initialisation file into memory."
  11700.                           //: FRANCAIS "Ne peux placer le fichier d'initialisation en mémoire."
  11701.                           asciz_out(GETTEXT("cannot map the initialisation file into memory"));
  11702.                           errno_out(errno);
  11703.                           use_mmap = FALSE;
  11704.                           # Bevor es mit READ(handle) weitergeht, ist evtl. ein lseek() nötig.
  11705.                           if ( lseek(handle,file_offset,SEEK_SET) <0) goto abbruch1;
  11706.                         }
  11707.                     }
  11708.                   #endif
  11709.                   if (zeromap((void*)(heapptr->heap_start),map_len) <0) goto abbruch3;
  11710.                   READ(heapptr->heap_start,len);
  11711.                   READ_page_alignment(len);
  11712.                   block_done: ;
  11713.          }  }   }
  11714.          #endif
  11715.          #ifdef SPVW_MIXED_BLOCKS_OPPOSITE
  11716.          # Objekte variabler Länge lesen:
  11717.          {var reg2 uintL len = header._mem_varobjects_end - header._mem_varobjects_start;
  11718.           READ(mem.varobjects.heap_start,len);
  11719.          }
  11720.          # Conses lesen:
  11721.          {var reg2 uintL len = header._mem_conses_end - header._mem_conses_start;
  11722.           READ(mem.conses.heap_start,len);
  11723.          }
  11724.          #endif
  11725.          # File schließen:
  11726.          #undef READ
  11727.          begin_system_call();
  11728.          #if defined(UNIX) || defined(DJUNIX) || defined(EMUNIX) || defined(WATCOM) || defined(RISCOS) || defined(WIN32_DOS) || defined(WIN32_UNIX)
  11729.          if ( CLOSE(handle) <0) goto abbruch1;
  11730.          #elif defined(AMIGAOS)
  11731.          # Never close handles twice
  11732.          if ( CLOSE(handle) <0) { handle = Handle_NULL; goto abbruch1; }
  11733.          #endif
  11734.          end_system_call();
  11735.          # Durchlaufen durch alle LISP-Objekte und aktualisieren:
  11736.            #define aktualisiere  loadmem_aktualisiere
  11737.            # Programmkonstanten aktualisieren:
  11738.              aktualisiere_tab();
  11739.            # Pointer in den Cons-Zellen aktualisieren:
  11740.              aktualisiere_conses();
  11741.            # Pointer in den Objekten variabler Länge aktualisieren:
  11742.              #define aktualisiere_page  aktualisiere_page_normal
  11743.              #ifdef FOREIGN
  11744.                #define aktualisiere_fpointer_invalid  TRUE
  11745.              #else
  11746.                #define aktualisiere_fpointer_invalid  FALSE
  11747.              #endif
  11748.              aktualisiere_varobjects();
  11749.              #undef aktualisiere_fpointer_invalid
  11750.              #undef aktualisiere_page
  11751.            #undef aktualisiere
  11752.          #ifdef SPVW_PAGES
  11753.          begin_system_call(); free(offset_pages); end_system_call();
  11754.          recalc_space(FALSE);
  11755.          #endif
  11756.          #if defined(SPVW_PURE_BLOCKS) || defined(TRIVIALMAP_MEMORY) || defined(GENERATIONAL_GC) # SINGLEMAP_MEMORY || TRIVIALMAP_MEMORY || GENERATIONAL_GC
  11757.          #ifdef GENERATIONAL_GC
  11758.          { var reg6 uintL heapnr;
  11759.            for (heapnr=0; heapnr<heapcount; heapnr++)
  11760.              { var reg2 Heap* heapptr = &mem.heaps[heapnr];
  11761.                heapptr->heap_gen0_start = heapptr->heap_start;
  11762.                heapptr->heap_gen0_end = heapptr->heap_end;
  11763.                #ifdef SPVW_MIXED_BLOCKS_OPPOSITE
  11764.                if (is_cons_heap(heapnr))
  11765.                  { heapptr->heap_start = heapptr->heap_gen1_end = heapptr->heap_start & -physpagesize; }
  11766.                  else
  11767.                  { heapptr->heap_gen1_start = heapptr->heap_end = (heapptr->heap_end + (physpagesize-1)) & -physpagesize; }
  11768.                #else # defined(SPVW_PURE_BLOCKS) || defined(TRIVIALMAP_MEMORY)
  11769.                heapptr->heap_gen1_start = heapptr->heap_end = heapptr->heap_limit;
  11770.                #endif
  11771.                heapptr->physpages = NULL;
  11772.                if (!is_unused_heap(heapnr))
  11773.                  { build_old_generation_cache(heapnr); }
  11774.          }   }
  11775.          #ifdef SPVW_MIXED_BLOCKS_OPPOSITE
  11776.          if (!(mem.varobjects.heap_end <= mem.conses.heap_start)) goto abbruch3;
  11777.          #endif
  11778.          # Ab jetzt brauchen wir den SIGSEGV-Handler.
  11779.          install_segv_handler();
  11780.          #endif
  11781.          { var reg2 uintL space = used_space();
  11782.            set_total_room(space); # bis zur nächsten GC haben wir viel Zeit
  11783.            #ifdef GENERATIONAL_GC
  11784.            mem.last_gcend_space0 = space;
  11785.            mem.last_gcend_space1 = 0;
  11786.            #endif
  11787.          }
  11788.          #endif
  11789.          FREE_DYNAMIC_ARRAY(old_modules);
  11790.         }
  11791.         begin_system_call(); free(offset_subrs); end_system_call();
  11792.       }}
  11793.       # offene Files für geschlossen erklären:
  11794.       closed_all_files();
  11795.       #ifdef GENERATIONAL_GC
  11796.       # bisher keine GCs:
  11797.       O(gc_count) = Fixnum_0;
  11798.       #endif
  11799.       #ifdef MACHINE_KNOWN
  11800.         # (MACHINE-TYPE), (MACHINE-VERSION), (MACHINE-INSTANCE)
  11801.         # wieder für unbekannt erklären:
  11802.         O(machine_type_string) = NIL;
  11803.         O(machine_version_string) = NIL;
  11804.         O(machine_instance_string) = NIL;
  11805.       #endif
  11806.       #ifdef DYNBIND_LIST
  11807.       init_dynbind_list();
  11808.       #endif
  11809.       CHECK_AVL_CONSISTENCY();
  11810.       CHECK_GC_CONSISTENCY();
  11811.       CHECK_GC_UNMARKED(); CHECK_NULLOBJ(); CHECK_GC_CACHE(); CHECK_GC_GENERATIONAL(); SAVE_GC_DATA();
  11812.       CHECK_PACK_CONSISTENCY();
  11813.       return;
  11814.       abbruch1:
  11815.         #if defined(UNIX) || defined(DJUNIX) || defined(EMUNIX) || defined(WATCOM) || defined(RISCOS) || defined(WIN32_DOS) || defined(WIN32_UNIX)
  11816.         {var reg3 int abbruch_errno = errno;
  11817.         #endif
  11818.          asciz_out(program_name); asciz_out(": ");
  11819.          //: DEUTSCH "Betriebssystem-Fehler beim Versuch, das Initialisierungsfile zu laden."
  11820.          //: ENGLISH "operating system error during load of initialisation file"
  11821.          //: FRANCAIS "Erreur système pendant le chargement du fichier d'initialisation."
  11822.          asciz_out(GETTEXT("OS error during load of init file."));
  11823.          asciz_out(CRLFstring);
  11824.         #if defined(UNIX) || defined(DJUNIX) || defined(EMUNIX) || defined(WATCOM) || defined(RISCOS) || defined(WIN32_DOS) || defined(WIN32_UNIX)
  11825.          errno_out(abbruch_errno);
  11826.         }
  11827.         #endif
  11828.         goto abbruch_quit;
  11829.       abbruch2:
  11830.         asciz_out(program_name); asciz_out(": ");
  11831.         //: DEUTSCH "Initialisierungsfile wurde nicht von dieser LISP-Version erzeugt."
  11832.         //: ENGLISH "initialisation file was not created by this version of LISP"
  11833.         //: FRANCAIS "Le fichier d'initialisation ne provient pas de cette version de LISP."
  11834.         asciz_out(GETTEXT("initialisation file was not created by this version of LISP"));
  11835.         asciz_out(CRLFstring);
  11836.         goto abbruch_quit;
  11837.       abbruch3:
  11838.         asciz_out(program_name); asciz_out(": ");
  11839.         //: DEUTSCH "Speicherplatz reicht für Initialisierung nicht aus."
  11840.         //: ENGLISH "not enough memory for initialisation"
  11841.         //: FRANCAIS "Il n'y a pas assez de mémoire pour l'initialisation."
  11842.         asciz_out(GETTEXT("not enough memory for initialisation"));
  11843.         asciz_out(CRLFstring);
  11844.         goto abbruch_quit;
  11845.       abbruch_quit:
  11846.         # Abbruch.
  11847.         # Zuvor die Datei schließen, falls sie erfolgreich geöffnet worden war.
  11848.         # (Hierbei werden Fehler nun aber wirklich ignoriert!)
  11849.         #ifdef AMIGAOS
  11850.         if (!(handle==Handle_NULL))
  11851.           { begin_system_call(); CLOSE(handle); end_system_call(); }
  11852.         #endif
  11853.         #if defined(UNIX) || defined(DJUNIX) || defined(EMUNIX) || defined(WATCOM) || defined(RISCOS) || defined(WIN32_DOS) || defined(WIN32_UNIX)
  11854.         if (!(handle<0))
  11855.           { begin_system_call(); CLOSE(handle); end_system_call(); }
  11856.         #endif
  11857.         quit_sofort(1);
  11858.     }}
  11859.  
  11860. # ------------------------------------------------------------------------------
  11861. # ------------------------------------------------------------------------------
  11862. #                                Version
  11863. #ifdef AMIGAOS
  11864. # Es gibt eine Utility, die ein Executable nach einem Versionsstring absucht.
  11865.   global const char version_string[] =
  11866.     "$VER: CLISP"
  11867.     #if defined(WIDE)
  11868.       "-wide"
  11869.     #elif defined(AMIGA3000)
  11870.       "-high"
  11871.     #elif defined(MC68000)
  11872.       "-68000"
  11873.     #else
  11874.       "-low"
  11875.     #endif
  11876.     " "STRINGIFY(VERSION_YYYY)"."STRINGIFY(VERSION_MM) # version.revision
  11877.     " (" VERSION ")\r\n"; # Datum in Klammern
  11878. #endif
  11879.  
  11880. # ------------------------------------------------------------------------------
  11881.  
  11882.