home *** CD-ROM | disk | FTP | other *** search
/ Il CD di internet / CD.iso / SOURCE / D / CLISP / CLISPSRC.TAR / clisp-1995-01-01 / src / spvw.d < prev    next >
Encoding:
Text File  |  1994-12-30  |  507.3 KB  |  11,315 lines
  1. # Speicherverwaltung fⁿr CLISP
  2. # Bruno Haible 30.12.1994
  3.  
  4. # Inhalt:
  5. # Modulverwaltung
  6. # Zeitmessungsfunktionen
  7. # Debug-Hilfen
  8. # Speichergr÷▀e
  9. # SpeicherlΣngenbestimmung
  10. # Garbage Collection
  11. # Speicherbereitstellungsfunktionen
  12. # ZirkularitΣtenfeststellung
  13. # elementare Stringfunktionen
  14. # andere globale Hilfsfunktionen
  15. # Initialisierung
  16. # Speichern und Laden von MEM-Files
  17. # Fremdprogrammaufruf
  18.  
  19. #include "lispbibl.c"
  20. #include "aridecl.c" # fⁿr NUM_STACK
  21.  
  22. #include "version.h" # fⁿr O(lisp_implementation_version_string)
  23.  
  24. # In diesem File haben die Tabellenmacros eine andere Verwendung:
  25.   #undef LISPSPECFORM
  26.   #undef LISPFUN
  27.   #undef LISPSYM
  28.   #undef LISPOBJ
  29.  
  30. # Tabelle aller SUBRs: ausgelagert nach SPVWTABF
  31. # Gr÷▀e dieser Tabelle:
  32.   #define subr_anz  (sizeof(subr_tab)/sizeof(subr_))
  33.  
  34. # Tabelle aller FSUBRs: ausgelagert nach CONTROL
  35. # Gr÷▀e dieser Tabelle:
  36.   #define fsubr_anz  (sizeof(fsubr_tab)/sizeof(fsubr_))
  37.  
  38. # Tabelle aller Pseudofunktionen: ausgelagert nach STREAM
  39. # Gr÷▀e dieser Tabelle:
  40.   #define pseudofun_anz  (sizeof(pseudofun_tab)/sizeof(Pseudofun))
  41.  
  42. # Tabelle aller festen Symbole: ausgelagert nach SPVWTABS
  43. # Gr÷▀e dieser Tabelle:
  44.   #define symbol_anz  (sizeof(symbol_tab)/sizeof(symbol_))
  45.  
  46. # Tabelle aller sonstigen festen Objekte: ausgelagert nach SPVWTABO
  47. # Gr÷▀e dieser Tabelle:
  48.   #define object_anz  (sizeof(object_tab)/sizeof(object))
  49.  
  50. # Durchlaufen durch subr_tab:
  51. # (NB: subr_tab_ptr_as_object(ptr) wandelt einen durchlaufenden Pointer
  52. # in ein echtes Lisp-Objekt um.)
  53.   #ifdef MAP_MEMORY
  54.     local uintC total_subr_anz;
  55.     #define for_all_subrs(statement)  \
  56.       { var reg6 subr_* ptr = (subr_*)&subr_tab; # subr_tab durchgehen \
  57.         var reg5 uintC count;                                          \
  58.         dotimesC(count,total_subr_anz, { statement; ptr++; } );        \
  59.       }
  60.   #else
  61.     #define for_all_subrs(statement)  \
  62.       { var reg7 module_* module; # modules durchgehen                  \
  63.         for_modules(all_modules,                                        \
  64.           { var reg5 subr_* ptr = module->stab;                         \
  65.             var reg6 uintC count;                                       \
  66.             dotimesC(count,*module->stab_size, { statement; ptr++; } ); \
  67.           });                                                           \
  68.       }
  69.   #endif
  70.  
  71. # Beim Durchlaufen durch symbol_tab:
  72. # Wandelt einen durchlaufenden Pointer in ein echtes Lisp-Objekt um.
  73.   #ifdef MAP_MEMORY
  74.     #define symbol_tab_ptr_as_object(ptr)  ((object)(ptr))
  75.   #else
  76.     #define symbol_tab_ptr_as_object(ptr)  type_pointer_object(symbol_type,ptr)
  77.   #endif
  78. # Durchlaufen durch symbol_tab:
  79.   #define for_all_constsyms(statement)  \
  80.     { var reg6 symbol_* ptr = (symbol_*)&symbol_tab; # symbol_tab durchgehen \
  81.       var reg5 uintC count;                                                  \
  82.       dotimesC(count,symbol_anz, { statement; ptr++; } );                    \
  83.     }
  84.  
  85. # Durchlaufen durch object_tab:
  86.   #define for_all_constobjs(statement)  \
  87.     { var reg5 module_* module; # modules durchgehen                      \
  88.       for_modules(all_modules,                                            \
  89.         { var reg3 object* objptr = module->otab; # object_tab durchgehen \
  90.           var reg4 uintC count;                                           \
  91.           dotimesC(count,*module->otab_size, { statement; objptr++; } );  \
  92.         });                                                               \
  93.     }
  94.  
  95. # Semaphoren: entscheiden, ob eine Unterbrechung (Atari: mit Shift/Ctrl/Alt)
  96. # unwirksam (/=0) oder wirksam (alle = 0) ist.
  97. # Werden mit set_break_sem_x gesetzt und mit clr_break_sem_x wieder gel÷scht.
  98.   global break_sems_ break_sems;
  99.   # break_sem_1 == break_sems.einzeln[0]
  100.   #   gesetzt, solange die Speicherverwaltung eine Unterbrechung verbietet
  101.   #   (damit leerer Speicher nicht von der GC durchlaufen werden kann)
  102.   # break_sem_2 == break_sems.einzeln[1]
  103.   #   fⁿr Package-Verwaltung auf unterem Niveau und Hashtable-Verwaltung
  104.   # break_sem_3 == break_sems.einzeln[2]
  105.   #   fⁿr Package-Verwaltung auf h÷herem Niveau
  106.   # break_sem_4 == break_sems.einzeln[3]
  107.   #   gesetzt, solange (ATARI) eine GEMDOS-SFIRST/SNEXT-Suche lΣuft
  108.   #   bzw. (AMIGAOS) DOS oder externe Funktionen aufgerufen werden.
  109.  
  110. # GC-Statistik:
  111.   local uintL  gc_count = 0;      # ZΣhler fⁿr GC-Aufrufe
  112.   local uintL2 gc_space =         # Gr÷▀e des von der GC insgesamt bisher
  113.                                   # wiederbeschafften Platzes (64-Bit-Akku)
  114.     #ifdef intQsize
  115.       0
  116.     #else
  117.       {0,0}
  118.     #endif
  119.     ;
  120.  
  121. # ------------------------------------------------------------------------------
  122. #                          Modulverwaltung
  123.  
  124. #ifdef DYNAMIC_MODULES
  125.  
  126.   extern uintC subr_tab_data_size;
  127.   extern uintC object_tab_size;
  128.   local module_ main_module =
  129.     { "clisp",
  130.       (subr_*)&subr_tab_data, &subr_tab_data_size,
  131.       (object*)&object_tab, &object_tab_size,
  132.       TRUE, NULL, NULL,
  133.       NULL # Hier beginnt die Liste der anderen Module
  134.     };
  135.   local module_ ** last_module = &main_module.next; # zeigt aufs Ende der Liste
  136.   global uintC module_count = 0;
  137.  
  138.   global void add_module (module_ * new_module);
  139.   global void add_module(module)
  140.     var reg1 module_ * module;
  141.     { *last_module = module; last_module = &module->next;
  142.       module_count++;
  143.     }
  144.  
  145.   #define for_modules(which,statement)  \
  146.     module = (which); until (module==NULL) { statement; module = module->next; }
  147.   #define all_modules  &main_module
  148.   #define all_other_modules  main_module.next
  149.  
  150. #else
  151.  
  152.   #define main_module  modules[0]
  153.  
  154.   #define for_modules(which,statement)  \
  155.     module = (which); until (module->name==NULL) { statement; module++; }
  156.   #define all_modules  &modules[0]
  157.   #define all_other_modules  &modules[1]
  158.  
  159. #endif
  160.  
  161. # ------------------------------------------------------------------------------
  162. #                          Zeitmessung
  163.  
  164. # Variablen fⁿr Zeitmessung:
  165. #ifdef TIME_ATARI
  166.   # (Grundeinheit ist 1/200 sec, ein 32-Bit-ZΣhler reicht also
  167.   # fⁿr 248d 13h 13m 56.48s, und keine LISP-Session dauert 248 Tage.)
  168. #endif
  169. #ifdef TIME_AMIGAOS
  170.   # (Grundeinheit ist 1/50 sec, ein 32-Bit-ZΣhler reicht also
  171.   # fⁿr 994d 4h 55m 45.92s, und keine LISP-Session dauert 2.7 Jahre.)
  172. #endif
  173. #ifdef TIME_MSDOS
  174.   # (Grundeinheit ist 1/100 sec, ein 32-Bit-ZΣhler reicht also
  175.   # fⁿr 497d 2h 27m 52.96s, und keine LISP-Session dauert 1.3 Jahre.)
  176. #endif
  177. #if defined(TIME_UNIX_TIMES) || defined(TIME_RISCOS)
  178.   # (Grundeinheit ist etwa 1/60 sec oder 1/100 sec, ein 32-Bit-ZΣhler reicht
  179.   # also eine ganze Weile.)
  180. #endif
  181. #ifdef TIME_UNIX
  182.   # Grundeinheit ist 1 ╡sec.
  183.   # (Egal, ob der Systemtakt nun - abhΣngig vom lokalen Stromnetz - 60 Hz
  184.   # oder 50 Hz betrΣgt oder eine genauere Uhr eingebaut ist.)
  185. #endif
  186.   # Zeit, die ablΣuft:
  187.     local internal_time realstart_time;  # Real-Time beim LISP-Start
  188.   # Zeit, die die GC verbraucht:
  189.     local internal_time gc_time =        # GC-Zeitverbrauch bisher insgesamt
  190.       #ifdef TIME_1
  191.       0
  192.       #endif
  193.       #ifdef TIME_2
  194.       {0,0}
  195.       #endif
  196.       ;
  197. #ifndef HAVE_RUN_TIME
  198.   # Zeit, die das LISP insgesamt verbraucht:
  199.     local uintL run_time = 0;       # Runtime bisher insgesamt
  200.     local uintL runstop_time;       # bei laufender Run-Time-Stoppuhr:
  201.                                     # Zeitpunkt des letzten Run/Stop-Wechsels
  202.     local boolean run_flag = FALSE; # /= 0 wenn die Run-Time-Stoppuhr lΣuft
  203. #endif
  204.  
  205. #ifdef TIME_RELATIVE
  206.  
  207. # UP: greift die aktuelle Zeit ab
  208. # get_time()
  209.  #ifdef TIME_ATARI
  210. # < uintL ergebnis : aktueller Stand des 200Hz-ZΣhlers
  211.   local uintL time_now;
  212.   local void get_time_200 (void);
  213.   local void get_time_200() # aktuellen Stand des 200-Hz-ZΣhlers merken
  214.     { time_now = *(uintL*)0x04BA; } # nur im Supervisor-Modus aufzurufen!
  215.   local uintL get_time (void);
  216.   local uintL get_time()
  217.     { Supervisor_Exec(get_time_200); return time_now; }
  218.  #endif
  219.  #ifdef TIME_AMIGAOS
  220. # < uintL ergebnis : aktueller Stand des 50Hz-ZΣhlers
  221.   local uintL get_time(void);
  222.   local uintL get_time()
  223.     { var struct DateStamp datestamp;
  224.       begin_system_call();
  225.       DateStamp(&datestamp); # aktuelle Uhrzeit holen
  226.       end_system_call();
  227.       # und in Ticks ab 1.1.1978 00:00:00 umrechnen:
  228.       return ((uintL)(datestamp.ds_Days)*24*60 + (uintL)(datestamp.ds_Minute))
  229.              *60*ticks_per_second + (uintL)(datestamp.ds_Tick);
  230.     }
  231.  #endif
  232.  #ifdef TIME_MSDOS
  233. # < uintL ergebnis : aktueller Stand des 100Hz-ZΣhlers
  234.   local uintL get_time(void);
  235.   #if defined(DJUNIX) && 0 # Vorsicht: das geht eine Stunde nach!!
  236.     local uintL get_time()
  237.       { var struct timeval real_time;
  238.         gettimeofday(&real_time,NULL);
  239.         return (uintL)(real_time.tv_sec) * 100
  240.                + (uintL)((uintW)((uintL)(real_time.tv_usec) / 16) / 625); # tv_usec/10000
  241.       }
  242.   #endif
  243.   #if defined(DJUNIX) || defined(WATCOM) || defined(EMUNIX_OLD_8d) || defined(WINDOWS)
  244.     typedef struct { uintW year;  # Jahr (1980..2099)
  245.                      uintB month; # Monat (1..12)
  246.                      uintB day;   # Tag (1..31)
  247.                      uintB hour;  # Stunde (0..23)
  248.                      uintB min;   # Minute (0..59)
  249.                      uintB sec;   # Sekunde (0..59)
  250.                      uintB hsec;  # Hundertstel Sekunde (0..59)
  251.                    }
  252.             internal_decoded_time;
  253.     local void get_decoded_time (internal_decoded_time* timepoint);
  254.     local void get_decoded_time(timepoint)
  255.       var reg1 internal_decoded_time* timepoint;
  256.       #if defined(DJUNIX) || defined(WATCOM) || (defined(EMUNIX) && defined(WINDOWS))
  257.       { var union REGS in;
  258.         var union REGS out;
  259.         begin_system_call();
  260.         loop
  261.           { # Datum-Teil holen:
  262.             in.regB.ah = 0x2A; # DOS Get Date
  263.             intdos(&in,&out);
  264.             timepoint->year = out.regW.cx;
  265.             timepoint->month = out.regB.dh;
  266.             timepoint->day = out.regB.dl;
  267.             # Uhrzeit-Teil holen:
  268.             in.regB.ah = 0x2C; # DOS Get Time
  269.             intdos(&in,&out);
  270.             timepoint->hour = out.regB.ch;
  271.             timepoint->min = out.regB.cl;
  272.             timepoint->sec = out.regB.dh;
  273.             timepoint->hsec = out.regB.dl;
  274.             # und auf Tageswechsel ⁿberprⁿfen:
  275.             if (!(timepoint->sec == 0)) break;
  276.             if (!(timepoint->min == 0)) break;
  277.             if (!(timepoint->hour == 0)) break;
  278.             in.regB.ah = 0x2A; # DOS Get Date
  279.             intdos(&in,&out);
  280.             if (timepoint->day == out.regB.dl) break;
  281.             # Datum hat sich zwischenzeitlich verΣndert -> wiederholen
  282.           }
  283.         end_system_call();
  284.       }
  285.       #endif
  286.       #if defined(EMUNIX) && !defined(WINDOWS)
  287.       # [Σltere Version fⁿr EMX 0.8c, noch ohne ftime(): siehe emx08c-1.d]
  288.       { var struct _dtd datetime;
  289.         # Uhrzeit holen:
  290.         begin_system_call();
  291.         __ftime(&datetime);
  292.         end_system_call();
  293.         # und nach *timepoint umfⁿllen:
  294.         timepoint->year  = datetime.year;
  295.         timepoint->month = datetime.month;
  296.         timepoint->day   = datetime.day;
  297.         timepoint->hour  = datetime.hour;
  298.         timepoint->min   = datetime.min;
  299.         timepoint->sec   = datetime.sec;
  300.         timepoint->hsec  = datetime.hsec;
  301.       }
  302.       #endif
  303.     local uintL get_time()
  304.       { var internal_decoded_time timepoint;
  305.         get_decoded_time(&timepoint);
  306.        {local var uintW monthoffsets[12] = { # Jahrtag ab dem letzten 1. MΣrz
  307.           # Monat  1   2   3  4  5  6  7   8   9   10  11  12
  308.                   306,337, 0,31,61,92,122,153,184,214,245,275,
  309.           };
  310.         var reg1 uintL UTTag;
  311.         timepoint.year -= 1980;
  312.         if (timepoint.month >= 3) { timepoint.year += 1; }
  313.         UTTag = (uintL)timepoint.year * 365 + (uintL)ceiling(timepoint.year,4)
  314.                 + (uintL)monthoffsets[timepoint.month-1] + (uintL)timepoint.day + 3345;
  315.         # Zeitzone mitberⁿcksichtigen??
  316.         return (((UTTag * 24 + (uintL)timepoint.hour)
  317.                         * 60 + (uintL)timepoint.min)
  318.                         * 60 + (uintL)timepoint.sec)
  319.                         * 100 + (uintL)timepoint.hsec;
  320.       }}
  321.   #endif
  322.   #if defined(EMUNIX_NEW_8e) && !defined(WINDOWS)
  323.     local uintL get_time()
  324.       { var struct timeb real_time;
  325.         begin_system_call();
  326.         __ftime(&real_time);
  327.         end_system_call();
  328.         return (uintL)(real_time.time) * ticks_per_second
  329.                + (uintL)((uintW)(real_time.millitm) / (1000/ticks_per_second));
  330.       }
  331.   #endif
  332.  #endif
  333.  #ifdef TIME_UNIX_TIMES
  334. # < uintL ergebnis : aktueller Stand des CLK_TCK Hz - ZΣhlers
  335.   local uintL get_time(void);
  336.   local uintL get_time()
  337.     { var struct tms buffer;
  338.       return (uintL)times(&buffer);
  339.     }
  340.  #endif
  341.  #ifdef TIME_RISCOS
  342. # < uintL ergebnis : aktueller Stand des CLK_TCK Hz - ZΣhlers
  343.   local uintL get_time(void);
  344.   #include <sys/os.h>
  345.   local uintL get_time()
  346.     { var int regs[10];
  347.       var os_error * err;
  348.       begin_system_call();
  349.       err = os_swi(0x42,regs);
  350.       if (err) { __seterr(err); OS_error(); }
  351.       end_system_call();
  352.       return (uintL)(regs[0]);
  353.     }
  354.  #endif
  355.  
  356. #ifndef HAVE_RUN_TIME
  357.  
  358. # UP: HΣlt die Run-Time-Stoppuhr an
  359. # run_time_stop();
  360.   global void run_time_stop (void);
  361.   global void run_time_stop()
  362.     { if (!run_flag) return; # Run-Time-Stoppuhr ist schon angehalten -> OK
  363.       # zuletzt verbrauchte Run-Time zur bisherigen Run-Time addieren:
  364.       run_time += get_time()-runstop_time;
  365.       run_flag = FALSE; # Run-Time-Stoppuhr steht
  366.     }
  367.  
  368. # UP: LΣ▀t die Run-Time-Stoppuhr weiterlaufen
  369. # run_time_restart();
  370.   global void run_time_restart (void);
  371.   global void run_time_restart()
  372.     { if (run_flag) return; # Run-Time-Stoppuhr lΣuft schon -> OK
  373.       runstop_time = get_time(); # aktuelle Zeit abspeichern
  374.       run_flag = TRUE; # Run-Time-Stoppuhr lΣuft
  375.     }
  376.  
  377. #endif
  378.  
  379. # UP: Liefert die Real-Time
  380. # get_real_time()
  381. # < uintL ergebnis: Zeit seit LISP-System-Start (in 1/200 sec bzw. in 1/50 sec bzw. in 1/100 sec bzw. in 1/CLK_TCK sec)
  382.   global uintL get_real_time (void);
  383.   global uintL get_real_time()
  384.     { return get_time()-realstart_time; }
  385.  
  386. #endif
  387.  
  388. #ifdef TIME_UNIX_TIMES
  389.  
  390. # UP: Liefert die Run-Time
  391. # get_run_time(&runtime);
  392. # < internal_time runtime: Run-Time seit LISP-System-Start (in Ticks)
  393. # < uintL ergebnis: wie get_time()
  394.   local uintL get_run_time (internal_time* runtime);
  395.   local uintL get_run_time(runtime)
  396.     var reg1 internal_time* runtime;
  397.     { var struct tms tms;
  398.       var reg2 uintL now_time;
  399.       begin_system_call();
  400.       now_time = times(&tms);
  401.       end_system_call();
  402.       *runtime = tms.tms_utime + tms.tms_stime; # User time + System time
  403.       return now_time; # vgl. get_time()
  404.     }
  405.  
  406. #endif
  407.  
  408. #ifdef TIME_UNIX
  409.  
  410. # UP: Liefert die Real-Time
  411. # get_real_time()
  412. # < internal_time* ergebnis: absolute Zeit
  413.   global internal_time* get_real_time (void);
  414.   global internal_time* get_real_time()
  415.     {
  416.      #ifdef HAVE_GETTIMEOFDAY
  417.       static union { struct timeval tv; internal_time it; } real_time;
  418.       begin_system_call();
  419.       if (!( gettimeofday(&real_time.tv,NULL) ==0)) { OS_error(); }
  420.       end_system_call();
  421.       return &real_time.it;
  422.      #elif defined(HAVE_FTIME)
  423.       static internal_time it;
  424.       var struct timeb timebuf;
  425.       begin_system_call();
  426.       ftime(&timebuf);
  427.       end_system_call();
  428.       it.tv_sec = timebuf.time;
  429.       it.tv_usec = (uintL)(timebuf.millitm) * (ticks_per_second/1000);
  430.       return ⁢
  431.      #endif
  432.     }
  433.  
  434. # UP: Liefert die Run-Time
  435. # get_run_time(&runtime);
  436. # < internal_time runtime: Run-Time seit LISP-System-Start (in Ticks)
  437.   local void get_run_time (internal_time* runtime);
  438.   local void get_run_time(runtime)
  439.     var reg1 internal_time* runtime;
  440.     {
  441.       #if defined(HAVE_GETRUSAGE)
  442.       var struct rusage rusage;
  443.       begin_system_call();
  444.       if (!( getrusage(RUSAGE_SELF,&rusage) ==0)) { OS_error(); }
  445.       end_system_call();
  446.       # runtime = rusage.ru_utime + rusage.ru_stime; # User time + System time
  447.       add_internal_time(rusage.ru_utime,rusage.ru_stime, *runtime);
  448.       #elif defined(HAVE_SYS_TIMES_H)
  449.       var reg2 uintL used_time; # verbrauchte Zeit, gemessen in 1/HZ Sekunden
  450.       var struct tms tms;
  451.       begin_system_call();
  452.       if (times(&tms) == (CLOCK_T)(-1))
  453.         { used_time = 0; } # times scheitert -> used_time unbekannt
  454.         else
  455.         { used_time = tms.tms_utime + tms.tms_stime; } # User time + System time
  456.       end_system_call();
  457.       # in Sekunden und Mikrosekunden umwandeln: # verwende HZ oder CLK_TCK ??
  458.       runtime->tv_sec = floor(used_time,HZ);
  459.       runtime->tv_usec = (used_time % HZ) * floor(2*1000000+HZ,2*HZ);
  460.       #endif
  461.     }
  462.  
  463. #endif
  464.  
  465. # UP: Liefert die Run-Time
  466. # get_running_times(×core);
  467. # < timescore.runtime:  Run-Time seit LISP-System-Start (in Ticks)
  468. # < timescore.realtime: Real-Time seit LISP-System-Start (in Ticks)
  469. # < timescore.gctime:   GC-Time seit LISP-System-Start (in Ticks)
  470. # < timescore.gccount:  Anzahl der GC's seit LISP-System-Start
  471. # < timescore.gcfreed:  Gr÷▀e des von den GC's bisher wiederbeschafften Platzes
  472.   global void get_running_times (timescore*);
  473.   global void get_running_times (tm)
  474.     var reg1 timescore* tm;
  475.     {
  476.      #ifndef HAVE_RUN_TIME
  477.       var reg2 uintL time = get_time();
  478.       tm->realtime = time - realstart_time;
  479.       tm->runtime = (run_flag ?
  480.                       time - runstop_time + run_time : # Run-Time-Stoppuhr lΣuft noch
  481.                       run_time # Run-Time-Stoppuhr steht
  482.                     );
  483.      #endif
  484.      #ifdef TIME_UNIX
  485.       # Real-Time holen:
  486.       var reg2 internal_time* real_time = get_real_time();
  487.       tm->realtime.tv_sec = real_time->tv_sec - realstart_time.tv_sec;
  488.       tm->realtime.tv_usec = real_time->tv_usec;
  489.       # Run-Time holen:
  490.       get_run_time(&tm->runtime);
  491.      #endif
  492.      #ifdef TIME_UNIX_TIMES
  493.       # Run-Time und Real-Time auf einmal holen:
  494.       tm->realtime = get_run_time(&tm->runtime) - realstart_time; # vgl. get_real_time()
  495.      #endif
  496.       tm->gctime = gc_time;
  497.       tm->gccount = gc_count;
  498.       tm->gcfreed = gc_space;
  499.     }
  500.  
  501. #if defined(ATARI) || defined(MSDOS)
  502. # UP: Wandelt das Atari-Zeitformat in Decoded-Time um.
  503. # convert_timedate(time,date,&timepoint)
  504. # > uintW time: Uhrzeit
  505. #         Als Word: Bits 15..11: Stunde in {0,...,23},
  506. #                   Bits 10..5:  Minute in {0,...,59},
  507. #                   Bits 4..0:   Sekunde/2 in {0,...,29}.
  508. # > uintW date: Datum
  509. #         Als Word: Bits 15..9: Jahr-1980 in {0,...,119},
  510. #                   Bits 8..5:  Monat in {1,...,12},
  511. #                   Bits 4..0:  Tag in {1,...,31}.
  512. # < timepoint.Sekunden, timepoint.Minuten, timepoint.Stunden,
  513. #   timepoint.Tag, timepoint.Monat, timepoint.Jahr, jeweils als Fixnums
  514.   global void convert_timedate (uintW time, uintW date, decoded_time* timepoint);
  515.   global void convert_timedate(time,date, timepoint)
  516.     var reg2 uintW time;
  517.     var reg2 uintW date;
  518.     var reg1 decoded_time* timepoint;
  519.     { timepoint->Sekunden = fixnum( (time & (bit(5) - 1)) << 1 );
  520.       time = time>>5;
  521.       timepoint->Minuten = fixnum( time & (bit(6) - 1));
  522.       time = time>>6;
  523.       timepoint->Stunden = fixnum( time);
  524.       timepoint->Tag = fixnum( date & (bit(5) - 1));
  525.       date = date>>5;
  526.       timepoint->Monat = fixnum( date & (bit(4) - 1));
  527.       date = date>>4;
  528.       timepoint->Jahr = fixnum( date+1980);
  529.     }
  530. #endif
  531. #ifdef AMIGAOS
  532. # UP: Wandelt das Amiga-Zeitformat in Decoded-Time um.
  533. # convert_time(&datestamp,&timepoint);
  534. # > struct DateStamp datestamp: Uhrzeit
  535. #          datestamp.ds_Days   : Anzahl Tage seit 1.1.1978
  536. #          datestamp.ds_Minute : Anzahl Minuten seit 00:00 des Tages
  537. #          datestamp.ds_Tick   : Anzahl Ticks seit Beginn der Minute
  538. # < timepoint.Sekunden, timepoint.Minuten, timepoint.Stunden,
  539. #   timepoint.Tag, timepoint.Monat, timepoint.Jahr, jeweils als Fixnums
  540.   #include "arilev0.c"  # fⁿr Division
  541.   global void convert_time (struct DateStamp * datestamp, decoded_time* timepoint);
  542.   global void convert_time(datestamp,timepoint)
  543.     var reg2 struct DateStamp * datestamp;
  544.     var reg1 decoded_time* timepoint;
  545.     { # Methode:
  546.       # ds_Tick durch ticks_per_second dividieren, liefert Sekunden.
  547.       # ds_Minute durch 60 dividierem liefert Stunden und (als Rest) Minuten.
  548.       # ds_Days in Tag, Monat, Jahr umrechnen:
  549.       #   d := ds_Days - 790; # Tage seit 1.3.1980 (Schaltjahr)
  550.       #   y := floor((4*d+3)/1461); # MΣrz-Jahre ab 1.3.1980
  551.       #   d := d - floor(y*1461/4); # Tage ab letztem MΣrz-Jahres-Anfang
  552.       #   (Diese Rechnung geht gut, solange jedes vierte Jahr ein Schaltjahr
  553.       #    ist, d.h. bis zum Jahr 2099.)
  554.       #   m := floor((5*d+2)/153); # Monat ab letztem MΣrz
  555.       #   d := d - floor((153*m+2)/5); # Tag ab letztem Monatsanfang
  556.       #   m := m+2; if (m>=12) then { m:=m-12; y:=y+1; } # auf Jahre umrechnen
  557.       #   Tag d+1, Monat m+1, Jahr 1980+y.
  558.       {var reg3 uintL sec;
  559.        divu_3216_1616(datestamp->ds_Tick,ticks_per_second,sec=,);
  560.        timepoint->Sekunden = fixnum(sec);
  561.       }
  562.       {var reg3 uintL std;
  563.        var reg4 uintL min;
  564.        divu_3216_1616(datestamp->ds_Minute,60,std=,min=);
  565.        timepoint->Minuten = fixnum(min);
  566.        timepoint->Stunden = fixnum(std);
  567.       }
  568.       {var reg5 uintL y;
  569.        var reg4 uintW m;
  570.        var reg3 uintW d;
  571.        divu_3216_1616(4*(datestamp->ds_Days - 424),1461,y=,d=); # y = MΣrz-Jahre ab 1.1.1979
  572.        d = floor(d,4); # Tage ab dem letzten MΣrz-Jahres-Anfang
  573.        divu_1616_1616(5*d+2,153,m=,d=); # m = Monat ab letztem MΣrz
  574.        d = floor(d,5); # Tag ab letztem Monatsanfang
  575.        # m=0..9 -> Monat MΣrz..Dezember des Jahres 1979+y,
  576.        # m=10..11 -> Monat Januar..Februar des Jahres 1980+y.
  577.        if (m<10) { m += 12; y -= 1; } # auf Jahre umrechnen
  578.        timepoint->Tag = fixnum(1+(uintL)d);
  579.        timepoint->Monat = fixnum(-9+(uintL)m);
  580.        timepoint->Jahr = fixnum(1980+y);
  581.     } }
  582. #endif
  583. #if defined(UNIX) || defined(MSDOS) || defined(RISCOS)
  584. # UP: Wandelt das System-Zeitformat in Decoded-Time um.
  585. # convert_time(&time,&timepoint);
  586. # > time_t time: Zeit im System-Zeitformat
  587. # < timepoint.Sekunden, timepoint.Minuten, timepoint.Stunden,
  588. #   timepoint.Tag, timepoint.Monat, timepoint.Jahr, jeweils als Fixnums
  589.   global void convert_time (time_t* time, decoded_time* timepoint);
  590.   global void convert_time(time,timepoint)
  591.     var reg3 time_t* time;
  592.     var reg1 decoded_time* timepoint;
  593.     { begin_system_call();
  594.      {var reg2 struct tm * tm = localtime(time); # decodieren
  595.       # (Das Zeitformat des Systems mu▀ auch das System auseinandernehmen.)
  596.       end_system_call();
  597.       if (!(tm==NULL))
  598.         # localtime war erfolgreich
  599.         { timepoint->Sekunden = fixnum(tm->tm_sec);
  600.           timepoint->Minuten  = fixnum(tm->tm_min);
  601.           timepoint->Stunden  = fixnum(tm->tm_hour);
  602.           timepoint->Tag      = fixnum(tm->tm_mday);
  603.           timepoint->Monat    = fixnum(1+tm->tm_mon);
  604.           timepoint->Jahr     = fixnum(1900+tm->tm_year);
  605.         }
  606.         else
  607.         # gescheitert -> verwende 1.1.1900, 00:00:00 als Default
  608.         { timepoint->Sekunden = Fixnum_0;
  609.           timepoint->Minuten  = Fixnum_0;
  610.           timepoint->Stunden  = Fixnum_0;
  611.           timepoint->Tag      = Fixnum_1;
  612.           timepoint->Monat    = Fixnum_1;
  613.           timepoint->Jahr     = fixnum(1900);
  614.         }
  615.     }}
  616. #endif
  617.  
  618. # ------------------------------------------------------------------------------
  619. #                            Debug-Hilfen
  620.  
  621. # uintL in Dezimalnotation direkt ⁿbers Betriebssystem ausgeben:
  622. # dez_out(zahl)
  623.   global void dez_out_ (uintL zahl);
  624.   global void dez_out_(zahl)
  625.     var reg1 uintL zahl;
  626.     { var struct { uintB contents[10+1]; } buffer;
  627.       # 10-Byte-Buffer reicht, da zahl < 2^32 <= 10^10 .
  628.       var reg2 uintB* bufptr = &buffer.contents[10]; # Pointer in den Buffer
  629.       *bufptr = 0; # ASCIZ-String-Ende
  630.       do { *--bufptr = '0'+(zahl%10); zahl=floor(zahl,10); }
  631.          until (zahl==0);
  632.       asciz_out((char*)bufptr);
  633.     }
  634.  
  635. # uintL in Hexadezimalnotation direkt ⁿbers Betriebssystem ausgeben:
  636. # hex_out(zahl)
  637.   global void hex_out_ (unsigned long zahl);
  638.   local char hex_table[] = "0123456789ABCDEF";
  639.   global void hex_out_(zahl)
  640.     var reg1 unsigned long zahl;
  641.     { var struct { uintB contents[2*sizeof(unsigned long)+1]; } buffer;
  642.       # 8/16-Byte-Buffer reicht, da zahl < 2^32 <= 16^8 bzw. zahl < 2^64 <= 16^16 .
  643.       var reg2 uintB* bufptr = &buffer.contents[2*sizeof(unsigned long)]; # Pointer in den Buffer
  644.       *bufptr = 0; # ASCIZ-String-Ende
  645.       do { *--bufptr = hex_table[zahl%16]; zahl=floor(zahl,16); }
  646.          until (zahl==0);
  647.       asciz_out((char*)bufptr);
  648.     }
  649.  
  650. # Speicherbereich in Hexadezimalnotation direkt ⁿbers Betriebssystem ausgeben:
  651. # mem_hex_out(buf,count);
  652.   global void mem_hex_out (void* buf, uintL count);
  653.   global void mem_hex_out(buf,count)
  654.     var reg5 void* buf;
  655.     var reg3 uintL count;
  656.     { var DYNAMIC_ARRAY(reg4,cbuf,char,3*count+1);
  657.       var reg2 uintB* ptr1 = buf;
  658.       var reg1 char* ptr2 = &cbuf[0];
  659.       dotimesL(count,count,
  660.         { *ptr2++ = ' ';
  661.           *ptr2++ = hex_table[floor(*ptr1,16)]; *ptr2++ = hex_table[*ptr1 % 16];
  662.           ptr1++;
  663.         });
  664.       *ptr2 = '\0';
  665.       asciz_out(cbuf);
  666.       FREE_DYNAMIC_ARRAY(cbuf);
  667.     }
  668.  
  669. # Lisp-Objekt in Lisp-Notation relativ direkt ⁿbers Betriebssystem ausgeben:
  670. # object_out(obj);
  671. # kann GC ausl÷sen
  672.   global void object_out (object obj);
  673.   global void object_out(obj)
  674.     var object obj;
  675.     { pushSTACK(obj);
  676.       pushSTACK(var_stream(S(terminal_io))); # Stream *TERMINAL-IO*
  677.       prin1(&STACK_0,STACK_1); # Objekt ausgeben
  678.       terpri(&STACK_0); # Newline ausgeben
  679.       skipSTACK(2);
  680.     }
  681.  
  682. # ------------------------------------------------------------------------------
  683. #                         Schnelles Programm-Ende
  684.  
  685. # jmp_buf zur Rⁿckkehr zum Original-Wert des SP beim Programmstart:
  686.   local jmp_buf original_context;
  687.  
  688. # LISP sofort verlassen:
  689. # quit_sofort(exitcode);
  690. # > exitcode: 0 bei normalem, 1 bei abnormalem Programmende
  691.   # Wir mⁿssen den SP auf den ursprⁿnglichen Wert setzen.
  692.   # (Bei manchen Betriebssystemen wird erst der vom Programm belegte
  693.   # Speicher mit free() zurⁿckgegeben, bevor ihm die Kontrolle entzogen
  694.   # wird. Fⁿr diese kurze Zeit mu▀ man den SP vernⁿnftig setzen.)
  695.   local int exitcode;
  696.   #define quit_sofort(xcode)  exitcode = xcode; longjmp(&!original_context,1)
  697.  
  698. # ------------------------------------------------------------------------------
  699. #                         Speicherverwaltung allgemein
  700.  
  701. /*
  702.  
  703. Overview over CLISP's garbage collection
  704. ----------------------------------------
  705.  
  706. Knowing that most malloc() implementations are buggy and/or slow, and
  707. because CLISP needs to perform garbage collection, CLISP has its own memory
  708. management subsystem in spvw.d.
  709.  
  710. Three kinds of storage are distinguished:
  711.   * Lisp data (the "heap"), i.e. storage which contains Lisp objects and
  712.     is managed by the garbage collector.
  713.   * Lisp stack (called STACK), contains Lisp objects,
  714.   * C data (including program text, data, malloc()ed memory).
  715.  
  716. A Lisp object is one word, containing a tag (partial type information)
  717. and either immediate data (e.g. fixnums or short floats) or a pointer
  718. to storage. Pointers to C data have tag = machine_type = 0, pointers to
  719. Lisp stack have tag = system_type, most other pointers point to Lisp data.
  720.  
  721. Let's turn to these Lisp objects that consume regular Lisp memory.
  722. Every Lisp object has a size which is determined when the object is
  723. allocated (using one of the allocate_... routines). The size can be
  724. computed from the type tag and - if necessary - the length field of
  725. the object's header. The length field always contains the number of
  726. elements of the object. The number of bytes is given by the function
  727. speicher_laenge().
  728.  
  729. Lisp objects which contain exactly 2 Lisp objects (i.e. conses, complex
  730. numbers, ratios) are stored in a separate area and occupy 2 words each.
  731. All other Lisp objects have "varying length" (well, more precisely,
  732. not a fixed length) and include a word for garbage collection purposes
  733. at their beginning.
  734.  
  735. The garbage collector is invoked when an allocate_...() request
  736. cannot be fulfilled. It marks all objects which are "live" (may be
  737. reached from the "roots"), compacts these objects and unmarks them.
  738. Non-live objects are lost; their storage is reclaimed.
  739.  
  740. 2-pointer objects are compacted by a simple hole-filling algorithm:
  741. fill the most-left object into the most-right hole, and so on, until
  742. the objects are contiguous at the right and the hole is contiguous at the
  743. left.
  744.  
  745. Variable-length objects are compacted by sliding them down (their address
  746. decreases).
  747.  
  748. There are 4 memory models. Which one is used, depends on the operating system.
  749.  
  750. SPVW_MIXED_BLOCKS_OPPOSITE: The heap consists of one block of fixed length
  751. (allocated at startup). The variable-length objects are allocated from
  752. the left, the 2-pointer objects are allocated from the right. There is a
  753. hole between them. When the hole shrinks to 0, GC is invoked. GC slides
  754. the variable-length objects to the left and concentrates the 2-pointer
  755. objects at the right end of the block again.
  756. When no more room is available, some reserve area beyond the right end
  757. of the block is halved, and the 2-pointer objects are moved to the right
  758. accordingly.
  759. (+) Simple management.
  760. (+) No fragmentation at all.
  761. (-) The total heap size is limited.
  762.  
  763. SPVW_MIXED_BLOCKS && TRIVIALMAP_MEMORY: The heap consists of two big blocks,
  764. one for variable-length objects and one for 2-pointer objects. Both have a
  765. hole to the right, but are extensible to the right.
  766. (+) Total heap size grows depending on the application's needs.
  767. (+) No fragmentation at all.
  768. (*) Works only when SINGLEMAP_MEMORY were possible as well.
  769.  
  770. SPVW_MIXED_PAGES: The heap consists of many small pages (usually around
  771. 8 KB). There are two kinds of pages: one for 2-pointer objects, one for
  772. variable-length objects. The set of all pages of a fixed kind is called
  773. a "Heap". Each page has its hole (free space) at its end. For every heap,
  774. the pages are kept sorted according to the size of their hole, using AVL
  775. trees. Garbage collection is invoked when the used space has grown by
  776. 25% since the last GC; until that point new pages are allocated from
  777. the operating system. The GC compacts the data in each page separately:
  778. data is moved to the left. Emptied pages are given back to the OS.
  779. If the holes then make up more than 25% of the occupied storage, a second
  780. GC turn moves objects across pages, from nearly empty ones to nearly full
  781. ones, with the aim to free as most pages as possible.
  782.  
  783. (-) every allocation requires AVL tree operations -> slower
  784. (+) Total heap size grows depending on the application's needs.
  785. (+) Works on operating systems which don't provide large contiguous areas.
  786.  
  787. SPVW_PURE_PAGES: Just like SPVW_MIXED_PAGES, except that every page contains
  788. data of only a single type tag, i.e. there is a Heap for every type tag.
  789.  
  790. (-) every allocation requires AVL tree operations -> slower
  791. (+) Total heap size grows depending on the application's needs.
  792. (+) Works on operating systems which don't provide large contiguous areas.
  793. (-) More fragmentation because objects of different type never fit into
  794.     the same page.
  795.  
  796. SPVW_PURE_BLOCKS: There is a big block of storage for each type tag.
  797. Each of these blocks has its data to the left and the hole to the right,
  798. but these blocks are extensible to the right (because there's enough room
  799. between them). A garbage collection is triggered when the allocation amount
  800. since the last GC reaches 50% of the amount of used space at the last GC,
  801. but at least 512 KB. The garbage collection cleans up each block separately:
  802. data is moved left.
  803.  
  804. (+) Total heap size grows depending on the application's needs.
  805. (+) No 16 MB total size limit.
  806. (*) Works only in combination with SINGLEMAP_MEMORY.
  807.  
  808.  
  809. The burden of GC upon the rest of CLISP:
  810.  
  811. Every subroutine marked with "kann GC ausl÷sen" may invoke GC. GC moves
  812. all the Lisp objects and updates the pointers. But the GC looks only
  813. on the STACK and not in the C variables. (Anything else wouldn't be portable.)
  814. Therefore at every "unsafe" point - i.e. every call to such a subroutine -
  815. all the C variables of type `object' MUST BE ASSUMED TO BECOME GARBAGE.
  816. (Except for `object's that are known to be unmovable, e.g. immediate data
  817. or Subrs.) Pointers inside Lisp data (e.g. to the characters of a string or
  818. to the elements of a simple-vector) become INVALID as well.
  819.  
  820. The workaround is usually to allocate all the needed Lisp data first and
  821. do the rest of the computation with C variables, without calling unsafe
  822. routines, and without worrying about GC.
  823.  
  824.  
  825. Foreign Pointers
  826. ----------------
  827.  
  828. Pointers to C functions and to malloc()ed data can be hidden in Lisp
  829. objects of type machine_type; GC will not modify its value. But one should
  830. not dare to assume that a C stack pointer or the address of a C function
  831. in a shared library fulfills the same requirements.
  832.  
  833. If another pointer is to be viewed as a Lisp object, it is best to box it,
  834. e.g. in a simple-bit-vector. (See allocate_foreign().)
  835.  
  836. */
  837.  
  838.  
  839. # Methode der Speicherverwaltung:
  840. #if defined(SPVW_BLOCKS) && defined(SPVW_MIXED) # z.B. ATARI
  841.   #define SPVW_MIXED_BLOCKS
  842.   #if !defined(TRIVIALMAP_MEMORY)
  843.     # Blocks grow like this:       |******-->     <--****|
  844.     #define SPVW_MIXED_BLOCKS_OPPOSITE
  845.   #else # defined(TRIVIALMAP_MEMORY)
  846.     # Blocks grow like this:       |******-->      |***-->
  847.   #endif
  848. #endif
  849. #if defined(SPVW_BLOCKS) && defined(SPVW_PURE) # z.B. UNIX_LINUX ab Linux 0.99.7
  850.   #define SPVW_PURE_BLOCKS
  851. #endif
  852. #if defined(SPVW_PAGES) && defined(SPVW_MIXED) # z.B. SUN3, AMIGA, HP9000_800
  853.   #define SPVW_MIXED_PAGES
  854. #endif
  855. #if defined(SPVW_PAGES) && defined(SPVW_PURE) # z.B. SUN4, SUN386
  856.   #define SPVW_PURE_PAGES
  857. #endif
  858.  
  859. # Algorithmus nach Morris, der die Conses kompaktiert, ohne sie dabei
  860. # durcheinanderzuwⁿrfeln:
  861. #if defined(SPVW_BLOCKS) && defined(VIRTUAL_MEMORY) && !defined(MULTIMAP_MEMORY) && !defined(NO_MORRIS_GC)
  862.   #define MORRIS_GC
  863. #endif
  864.  
  865. # Gesamtspeicheraufteilung:
  866. # 1. C-Programm. Speicher wird vom Betriebssystem zugeteilt.
  867. #    Nach Programmstart unverschieblich.
  868. #    Auf dem ATARI:
  869. #                |Base|Text|Data|BSS|
  870. #                |Page|Hauptprogramm|
  871. # 2. C-Stack. Speicher wird vom C-Programm geholt.
  872. #    Unverschieblich.
  873. #    Auf dem ATARI:
  874. #               |     SP-Stack     |
  875. #               |                  |
  876. #               SP_BOUND           |
  877. # 3. C-Heap. Hier unbenutzt.
  878. #ifdef SPVW_MIXED_BLOCKS
  879. # 4. LISP-Stack und LISP-Daten.
  880. #    4a. LISP-Stack. Unverschieblich.
  881. #    4b. Objekte variabler LΣnge. (Unverschieblich).
  882. #    4c. Conses u.Σ. Verschieblich mit move_conses.
  883. #    Speicher hierfⁿr wird vom Betriebssystem angefordert (hat den Vorteil,
  884. #    da▀ bei EXECUTE dem auszufⁿhrenden Fremdprogramm der ganze Speicher
  885. #    zur Verfⁿgung gestellt werden kann, den LISP gerade nicht braucht).
  886. #    Auf eine Unterteilung in einzelne Pages wird hier verzichtet.
  887. #          || LISP-      |Objekte         |    leer  |Conses| Reserve |
  888. #          || Stack      |variabler LΣnge              u.Σ. |         |
  889. #          |STACK_BOUND  |         objects.end   conses.start |         |
  890. #        MEMBOT   objects.start                         conses.end    MEMTOP
  891. #endif
  892. #ifdef SPVW_PURE_BLOCKS
  893. # 4. LISP-Stack. Unverschieblich.
  894. # 5. LISP-Daten. Fⁿr jeden Typ ein gro▀er Block von Objekten.
  895. #endif
  896. #ifdef SPVW_MIXED_PAGES
  897. # 4. LISP-Stack. Unverschieblich.
  898. # 5. LISP-Daten.
  899. #    Unterteilt in Pages fⁿr Objekte variabler LΣnge und Pages fⁿr Conses u.Σ.
  900. #endif
  901. #ifdef SPVW_PURE_PAGES
  902. # 4. LISP-Stack. Unverschieblich.
  903. # 5. LISP-Daten. Unterteilt in Pages, die nur Objekte desselben Typs enthalten.
  904. #endif
  905.  
  906. # ------------------------------------------------------------------------------
  907. #                          Eigenes malloc(), free()
  908.  
  909. #ifdef AMIGAOS
  910.  
  911. # Eigenes malloc(), free() n÷tig wegen Resource Tracking.
  912.  
  913.   # Flag, das anzeigt, ob der Prozessor ein 68000 ist.
  914.   local boolean cpu_is_68000;
  915.   #if defined(MC68000)
  916.     #define CPU_IS_68000  TRUE
  917.   #elif defined(MC680Y0)
  918.     #define CPU_IS_68000  FALSE
  919.   #else
  920.     #define CPU_IS_68000  cpu_is_68000
  921.   #endif
  922.  
  923.   # Flag fⁿr AllocMem().
  924.   #define default_allocmemflag  MEMF_ANY
  925.   #if !(defined(WIDE) || defined(MC68000))
  926.     # Es kann sein, da▀ wir mit MEMF_ANY Speicher au▀erhalb des
  927.     # 24/26-Bit-Adre▀raums bekommen, den wir nicht nutzen k÷nnen.
  928.     # Dann versuchen wir's nochmal.
  929.     local uintL retry_allocmemflag;  # wird in init_amiga() gesetzt.
  930.   #endif
  931.  
  932.   # Doppelt verkettete Liste aller bisher belegten Speicherbl÷cke fⁿhren:
  933.   typedef struct MemBlockHeader { struct MemBlockHeader * next;
  934.                                   #ifdef SPVW_PAGES
  935.                                   struct MemBlockHeader * * prev;
  936.                                   #endif
  937.                                   uintL size;
  938.                                   oint usable_memory[unspecified]; # "oint" erzwingt Alignment
  939.                                 }
  940.           MemBlockHeader;
  941.   local MemBlockHeader* allocmemblocks = NULL;
  942.   #ifdef SPVW_PAGES
  943.   # Fⁿr alle p = allocmemblocks{->next}^n (n=0,1,...) mit !(p==NULL) gilt
  944.   # *(p->prev) = p.
  945.   #endif
  946.  
  947.   # Speicher vom Betriebssystem holen:
  948.   local void* allocmem (uintL amount, uintL allocmemflag);
  949.   local void* allocmem(amount,allocmemflag)
  950.     var reg2 uintL amount;
  951.     var reg3 uintL allocmemflag;
  952.     { amount = round_up(amount+offsetofa(MemBlockHeader,usable_memory),4);
  953.      {var reg1 void* address = AllocMem(amount,allocmemflag);
  954.       if (!(address==NULL))
  955.         { ((MemBlockHeader*)address)->size = amount;
  956.           ((MemBlockHeader*)address)->next = allocmemblocks;
  957.           #ifdef SPVW_PAGES
  958.           ((MemBlockHeader*)address)->prev = &allocmemblocks;
  959.           if (!(allocmemblocks == NULL))
  960.             { if (allocmemblocks->prev == &allocmemblocks) # Sicherheits-Check
  961.                 { allocmemblocks->prev = &((MemBlockHeader*)address)->next; }
  962.                 else
  963.                 { abort(); }
  964.             }
  965.           #endif
  966.           allocmemblocks = (MemBlockHeader*)address;
  967.           address = &((MemBlockHeader*)address)->usable_memory[0];
  968.         }
  969.       return address;
  970.     }}
  971.  
  972.   # Speicher dem Betriebssystem zurⁿckgeben:
  973.   local void freemem (void* address);
  974.   local void freemem(address)
  975.     var reg2 void* address;
  976.     { var reg1 MemBlockHeader* ptr = (MemBlockHeader*)((aint)address - offsetofa(MemBlockHeader,usable_memory));
  977.       #ifdef SPVW_PAGES
  978.       if (*(ptr->prev) == ptr) # Sicherheits-Check
  979.         { var reg2 MemBlockHeader* ptrnext = ptr->next;
  980.           *(ptr->prev) = ptrnext; # ptr durch ptr->next ersetzen
  981.           if (!(ptrnext == NULL)) { ptrnext->prev = ptr->prev; }
  982.           FreeMem(ptr,ptr->size);
  983.           return;
  984.         }
  985.       #else
  986.       # Spar-Implementation, die nur in der Lage ist, den letzten allozierten
  987.       # Block zurⁿckzugeben:
  988.       if (allocmem == ptr) # Sicherheits-Check
  989.         { allocmem = ptr->next; # ptr durch ptr->next ersetzen
  990.           FreeMem(ptr,ptr->size);
  991.           return;
  992.         }
  993.       #endif
  994.         else
  995.         { abort(); }
  996.     }
  997.  
  998.   #define malloc(amount)  allocmem(amount,default_allocmemflag)
  999.   #define free  freemem
  1000.  
  1001. #endif
  1002.  
  1003. #ifdef NEED_MALLOCA
  1004.  
  1005. # Eigener alloca()-Ersatz.
  1006. # ptr = malloca(size) liefert einen Speicherblock gegebener Gr÷▀e. Er kann
  1007. # (mu▀ aber nicht) mit freea(ptr) freigegeben werden.
  1008. # freea(ptr) gibt alle seit der Allozierung von ptr per malloca()
  1009. # gelieferten Speicherbl÷cke zurⁿck, einschlie▀lich ptr selbst.
  1010.  
  1011. # Die so allozierten Speicherbl÷cke bilden eine verkettete Liste.
  1012. typedef struct malloca_header
  1013.                { struct malloca_header * next;
  1014.                  oint usable_memory[unspecified]; # "oint" erzwingt Alignment
  1015.                }
  1016.         malloca_header;
  1017.  
  1018. # Verkettete Liste der Speicherbl÷cke, der jⁿngste ganz vorn, der Σlteste
  1019. # ganz hinten.
  1020.   local malloca_header* malloca_list = NULL;
  1021.  
  1022. # malloca(size) liefert einen Speicherblock der Gr÷▀e size.
  1023.   global void* malloca (size_t size);
  1024.   global void* malloca(size)
  1025.     var reg2 size_t size;
  1026.     { var reg1 malloca_header* ptr = (malloca_header*)malloc(offsetofa(malloca_header,usable_memory) + size);
  1027.       if (!(ptr == NULL))
  1028.         { ptr->next = malloca_list;
  1029.           malloca_list = ptr;
  1030.           return &ptr->usable_memory;
  1031.         }
  1032.         else
  1033.         {
  1034.           #ifdef VIRTUAL_MEMORY
  1035.           asciz_out( DEUTSCH ? CRLFstring "*** - " "Kein virtueller Speicher mehr verfⁿgbar: RESET" :
  1036.                      ENGLISH ? CRLFstring "*** - " "Virtual memory exhausted. RESET" :
  1037.                      FRANCAIS ? CRLFstring "*** - " "La mΘmoire virtuelle est ΘpuisΘe : RAZ" :
  1038.                      ""
  1039.                    );
  1040.           #else
  1041.           asciz_out( DEUTSCH ? CRLFstring "*** - " "Speicher voll: RESET" :
  1042.                      ENGLISH ? CRLFstring "*** - " "Memory exhausted. RESET" :
  1043.                      FRANCAIS ? CRLFstring "*** - " "La mΘmoire est ΘpuisΘe : RAZ" :
  1044.                      ""
  1045.                    );
  1046.           #endif
  1047.           reset();
  1048.     }   }
  1049.  
  1050. # freea(ptr) gibt den Speicherblock ab ptr und alle jⁿngeren frei.
  1051.   global void freea (void* ptr);
  1052.   global void freea(address)
  1053.     var reg4 void* address;
  1054.     { var reg3 malloca_header* ptr = (malloca_header*)
  1055.         ((aint)address - offsetofa(malloca_header,usable_memory));
  1056.       var reg1 malloca_header* p = malloca_list;
  1057.       loop
  1058.         { var reg2 malloca_header* n = p->next;
  1059.           free(p);
  1060.           if (!(p == ptr))
  1061.             { p = n; }
  1062.             else
  1063.             { malloca_list = n; break; }
  1064.         }
  1065.     }
  1066.  
  1067. #endif # NEED_MALLOCA
  1068.  
  1069. # ------------------------------------------------------------------------------
  1070. #                          Page-Allozierung
  1071.  
  1072. #ifdef MULTIMAP_MEMORY
  1073.  
  1074. # Das Betriebssystem erlaubt es, denselben (virtuellen) Speicher unter
  1075. # verschiedenen Adressen anzusprechen.
  1076. # Dabei gibt es allerdings Restriktionen:
  1077. # - Die Adressenabbildung kann nur fⁿr ganze Speicherseiten auf einmal
  1078. #   erstellt werden.
  1079. # - Wir brauchen zwar nur diesen Adre▀raum und nicht seinen Inhalt, mⁿssen
  1080. #   ihn aber mallozieren und dⁿrfen ihn nicht freigeben, da er in unserer
  1081. #   Kontrolle bleiben soll.
  1082.  
  1083. # LΣnge einer Speicherseite des Betriebssystems:
  1084.   local /* uintL */ aint map_pagesize; # wird eine Zweierpotenz sein, meist 4096.
  1085.  
  1086. # Initialisierung:
  1087. # initmap() bzw. initmap(tmpdir)
  1088.  
  1089. # In einen Speicherbereich [map_addr,map_addr+map_len-1] leere Seiten legen:
  1090. # (map_addr und map_len durch map_pagesize teilbar.)
  1091. # zeromap(map_addr,map_len)
  1092.  
  1093. # Auf einen Speicherbereich [map_addr,map_addr+map_len-1] Seiten legen,
  1094. # die unter den Typcodes, die in typecases angegeben sind, ansprechbar
  1095. # sein sollen:
  1096. # multimap(typecases,imm_typecases,imm_flag,map_addr,map_len);
  1097.  
  1098. # Alle immutablen Objekte mutabel machen:
  1099. # immutable_off();
  1100.  
  1101. # Alle immutablen Objekte wieder immutabel machen:
  1102. # immutable_on();
  1103.  
  1104. # Beendigung:
  1105. # exitmap();
  1106.  
  1107. # Diese Typen kennzeichnen immutable Objekte:
  1108.   #ifdef IMMUTABLE
  1109.     #define IMM_FLAG  TRUE
  1110.     #ifdef IMMUTABLE_CONS
  1111.       #define IMM_TYPECASES_1  case imm_cons_type:
  1112.     #else
  1113.       #define IMM_TYPECASES_1
  1114.     #endif
  1115.     #ifdef IMMUTABLE_ARRAY
  1116.       #define IMM_TYPECASES_2  \
  1117.         case imm_sbvector_type: case imm_sstring_type: case imm_svector_type: case imm_array_type: \
  1118.         case imm_bvector_type: case imm_string_type: case imm_vector_type:
  1119.     #else
  1120.       #define IMM_TYPECASES_2
  1121.     #endif
  1122.     #define IMM_TYPECASES  IMM_TYPECASES_1 IMM_TYPECASES_2
  1123.     local tint imm_types[] =
  1124.       {
  1125.         #ifdef IMMUTABLE_CONS
  1126.         imm_cons_type,
  1127.         #endif
  1128.         #ifdef IMMUTABLE_ARRAY
  1129.         imm_sbvector_type,
  1130.         imm_sstring_type,
  1131.         imm_svector_type,
  1132.         imm_array_type,
  1133.         imm_bvector_type,
  1134.         imm_string_type,
  1135.         imm_vector_type,
  1136.         #endif
  1137.       };
  1138.     #define imm_types_count  (sizeof(imm_types)/sizeof(tint))
  1139.   #else
  1140.     #define IMM_FLAG  FALSE
  1141.     #define IMM_TYPECASES
  1142.   #endif
  1143.  
  1144. #ifdef MULTIMAP_MEMORY_VIA_FILE
  1145.  
  1146.   local char tempfilename[MAXPATHLEN]; # Name eines temporΣren Files
  1147.   local int zero_fd; # Handle von /dev/zero
  1148.  
  1149.   local int initmap (char* tmpdir);
  1150.   local int initmap(tmpdir)
  1151.     var reg3 char* tmpdir;
  1152.     # Virtual Memory Mapping aufbauen:
  1153.     { # Wir brauchen ein temporΣres File.
  1154.       # tempfilename := (string-concat tmpdir "/" "lisptemp.mem")
  1155.       {var reg1 char* ptr1 = tmpdir;
  1156.        var reg2 char* ptr2 = &tempfilename[0];
  1157.        while (!(*ptr1 == '\0')) { *ptr2++ = *ptr1++; }
  1158.        if (!((ptr2 > &tempfilename[0]) && (ptr2[-1] == '/')))
  1159.          { *ptr2++ = '/'; }
  1160.        ptr1 = "lisptemp.mem";
  1161.        while (!(*ptr1 == '\0')) { *ptr2++ = *ptr1++; }
  1162.        *ptr2 = '\0';
  1163.       }
  1164.       { var reg1 int fd = OPEN("/dev/zero",O_RDWR,my_open_mask);
  1165.         if (fd<0)
  1166.           { asciz_out(DEUTSCH ? "Kann /dev/zero nicht ÷ffnen." :
  1167.                       ENGLISH ? "Cannot open /dev/zero ." :
  1168.                       FRANCAIS ? "Ne peux pas ouvrir /dev/zero ." :
  1169.                       ""
  1170.                      );
  1171.             errno_out(errno);
  1172.             return -1; # error
  1173.           }
  1174.         zero_fd = fd;
  1175.       }
  1176.       return 0;
  1177.     }
  1178.  
  1179.   local int fdmap (int fd, void* map_addr, uintL map_len, int readonly);
  1180.   local int fdmap(fd,map_addr,map_len,readonly)
  1181.     var reg3 int fd;
  1182.     var reg1 void* map_addr;
  1183.     var reg2 uintL map_len;
  1184.     var reg4 int readonly;
  1185.     { if ( (void*) mmap(map_addr, # gewⁿnschte Adresse
  1186.                         map_len, # LΣnge
  1187.                         readonly ? PROT_READ : PROT_READ | PROT_WRITE, # Zugriffsrechte
  1188.                         MAP_SHARED | MAP_FIXED, # genau an diese Adresse!
  1189.                         fd, 0 # File ab Position 0 legen
  1190.                        )
  1191.            == (void*)(-1)
  1192.          )
  1193.         { asciz_out(DEUTSCH ? "Kann keinen Speicher an Adresse 0x" :
  1194.                     ENGLISH ? "Cannot map memory to address 0x" :
  1195.                     FRANCAIS ? "Ne peux pas placer de la mΘmoire α l'adresse 0x" :
  1196.                     ""
  1197.                    );
  1198.           hex_out(map_addr);
  1199.           asciz_out(DEUTSCH ? " legen." :
  1200.                     ENGLISH ? " ." :
  1201.                     FRANCAIS ? " ." :
  1202.                     ""
  1203.                    );
  1204.           errno_out(errno);
  1205.           return -1; # error
  1206.         }
  1207.       return 0;
  1208.     }
  1209.  
  1210.   local int zeromap (void* map_addr, uintL map_len);
  1211.   local int zeromap(map_addr,map_len)
  1212.     var reg1 void* map_addr;
  1213.     var reg2 uintL map_len;
  1214.     { return fdmap(zero_fd,map_addr,map_len,FALSE); }
  1215.  
  1216.   local int open_temp_fd (uintL map_len);
  1217.   local int open_temp_fd(map_len)
  1218.     var reg2 uintL map_len;
  1219.     { var reg1 int fd = OPEN(tempfilename,O_RDWR|O_CREAT|O_TRUNC|O_EXCL,my_open_mask);
  1220.       if (fd<0)
  1221.         { asciz_out(DEUTSCH ? "Kann " :
  1222.                     ENGLISH ? "Cannot open " :
  1223.                     FRANCAIS ? "Ne peux pas ouvrir " :
  1224.                     ""
  1225.                    );
  1226.           asciz_out(tempfilename);
  1227.           asciz_out(DEUTSCH ? " nicht ÷ffnen." :
  1228.                     ENGLISH ? " ." :
  1229.                     FRANCAIS ? " ." :
  1230.                     ""
  1231.                    );
  1232.           errno_out(errno);
  1233.           return -1; # error
  1234.         }
  1235.       # und ÷ffentlich unzugΣnglich machen, indem wir es l÷schen:
  1236.       # (Das Betriebssystem l÷scht das File erst dann, wenn am Ende dieses
  1237.       # Prozesses in _exit() ein close(fd) durchgefⁿhrt wird.)
  1238.       if ( unlink(tempfilename) <0)
  1239.         { asciz_out(DEUTSCH ? "Kann " :
  1240.                     ENGLISH ? "Cannot delete " :
  1241.                     FRANCAIS ? "Ne peux pas effacer " :
  1242.                     ""
  1243.                    );
  1244.           asciz_out(tempfilename);
  1245.           asciz_out(DEUTSCH ? " nicht l÷schen." :
  1246.                     ENGLISH ? " ." :
  1247.                     FRANCAIS ? " ." :
  1248.                     ""
  1249.                    );
  1250.           errno_out(errno);
  1251.           return -1; # error
  1252.         }
  1253.       # ⁿberprⁿfen, ob genug Plattenplatz da ist:
  1254.       { var struct statfs statbuf;
  1255.         if (!( fstatfs(fd,&statbuf) <0))
  1256.           if (!(statbuf.f_bsize == (long)(-1)) && !(statbuf.f_bavail == (long)(-1)))
  1257.             { var reg2 uintL available = (uintL)(statbuf.f_bsize) * (uintL)(statbuf.f_bavail);
  1258.               if (available < map_len)
  1259.                 # auf der Platte ist voraussichtlich zu wenig Platz
  1260.                 { asciz_out(DEUTSCH ? "** WARNUNG: ** Zu wenig freier Plattenplatz fⁿr " :
  1261.                             ENGLISH ? "** WARNING: ** Too few free disk space for " :
  1262.                             FRANCAIS ? "** AVERTISSEMENT : ** Trop peu de place disque restante sur " :
  1263.                             ""
  1264.                            );
  1265.                   asciz_out(tempfilename);
  1266.                   asciz_out(DEUTSCH ? " ." CRLFstring :
  1267.                             ENGLISH ? " ." CRLFstring :
  1268.                             FRANCAIS ? " ." CRLFstring :
  1269.                             ""
  1270.                            );
  1271.                   asciz_out(DEUTSCH ? "Bitte LISP mit weniger Speicher (Option -m) neu starten." CRLFstring :
  1272.                             ENGLISH ? "Please restart LISP with fewer memory (option -m)." CRLFstring :
  1273.                             FRANCAIS ? "PriΦre de relancer LISP avec moins de mΘmoire (option -m)." CRLFstring :
  1274.                             ""
  1275.                            );
  1276.       }     }   }
  1277.       # Auf Gr÷▀e map_len aufblΣhen:
  1278.       { var uintB dummy = 0;
  1279.         if (( lseek(fd,map_len-1,SEEK_SET) <0) || (!( full_write(fd,&dummy,1) ==1)))
  1280.           { asciz_out(DEUTSCH ? "Kann " :
  1281.                       ENGLISH ? "Cannot make " :
  1282.                       FRANCAIS ? "Ne peux pas agrandir " :
  1283.                       ""
  1284.                      );
  1285.             asciz_out(tempfilename);
  1286.             asciz_out(DEUTSCH ? " nicht aufblΣhen." :
  1287.                       ENGLISH ? " long enough." :
  1288.                       FRANCAIS ? " ." :
  1289.                       ""
  1290.                      );
  1291.             errno_out(errno);
  1292.             return -1; # error
  1293.       }   }
  1294.       return fd;
  1295.     }
  1296.  
  1297.   local int close_temp_fd (int fd);
  1298.   local int close_temp_fd(fd)
  1299.     var reg1 int fd;
  1300.     { if ( CLOSE(fd) <0)
  1301.         { asciz_out(DEUTSCH ? "Kann " :
  1302.                     ENGLISH ? "Cannot close " :
  1303.                     FRANCAIS ? "Ne peux pas fermer " :
  1304.                     ""
  1305.                    );
  1306.           asciz_out(tempfilename);
  1307.           asciz_out(DEUTSCH ? " nicht schlie▀en." :
  1308.                     ENGLISH ? " ." :
  1309.                     FRANCAIS ? " ." :
  1310.                     ""
  1311.                    );
  1312.           errno_out(errno);
  1313.           return -1; # error
  1314.         }
  1315.       return 0;
  1316.     }
  1317.  
  1318.   # Vorgehen bei multimap:
  1319.   # 1. TemporΣres File aufmachen
  1320.     #define open_mapid(map_len)  open_temp_fd(map_len) # -> fd
  1321.   # 2. File mehrfach ⁿberlagert in den Speicher legen
  1322.     #define map_mapid(fd,map_addr,map_len,readonly)  fdmap(fd,map_addr,map_len,readonly)
  1323.   # 3. File schlie▀en
  1324.   # (Das Betriebssystem schlie▀t und l÷scht das File erst dann, wenn am
  1325.   # Ende dieses Prozesses in _exit() ein munmap() durchgefⁿhrt wird.)
  1326.     #define close_mapid(fd)  close_temp_fd(fd)
  1327.  
  1328.   #ifndef IMMUTABLE
  1329.     #define multimap(typecases,imm_typecases,imm_flag,map_addr,map_len)  \
  1330.       { # TemporΣres File aufmachen:                            \
  1331.         var reg2 int mapid = open_mapid(map_len);               \
  1332.         if (mapid<0) goto no_mem;                               \
  1333.         # und mehrfach ⁿberlagert in den Speicher legen:        \
  1334.         { var reg1 oint type;                                   \
  1335.           for (type=0; type < bit(oint_type_len<=8 ? oint_type_len : 8); type++) \
  1336.             { switch (type)                                     \
  1337.                 { typecases                                     \
  1338.                     if ( map_mapid(mapid,ThePointer(type_pointer_object(type,map_addr)),map_len,FALSE) <0) \
  1339.                       goto no_mem;                              \
  1340.                     break;                                      \
  1341.                   default: break;                               \
  1342.         }   }   }                                               \
  1343.         # und ÷ffentlich unzugΣnglich machen:                   \
  1344.         if ( close_mapid(mapid) <0)                             \
  1345.           goto no_mem;                                          \
  1346.       }
  1347.     #define immutable_off()
  1348.     #define immutable_on()
  1349.     #define exitmap()
  1350.   #else # IMMUTABLE
  1351.     typedef struct { int mm_mapid; aint mm_addr; uintL mm_len; } mmapping;
  1352.     local mmapping bigblock[1];
  1353.     local mmapping* bigblock_ptr = &bigblock[0];
  1354.     #define multimap(typecases,imm_typecases,imm_flag,map_addr,map_len)  \
  1355.       { # TemporΣres File aufmachen:                            \
  1356.         var reg2 int mapid = open_mapid(map_len);               \
  1357.         if (mapid<0) goto no_mem;                               \
  1358.         # und mehrfach ⁿberlagert in den Speicher legen:        \
  1359.         { var reg1 oint type;                                   \
  1360.           for (type=0; type < bit(oint_type_len<=8 ? oint_type_len : 8); type++) \
  1361.             { var reg3 int readonly;                            \
  1362.               switch (type)                                     \
  1363.                 { typecases                                     \
  1364.                     switch (type)                               \
  1365.                       { imm_typecases  readonly = TRUE; break;  \
  1366.                         default:       readonly = FALSE; break; \
  1367.                       }                                         \
  1368.                     if ( map_mapid(mapid,ThePointer(type_pointer_object(type,map_addr)),map_len,readonly) <0) \
  1369.                       goto no_mem;                              \
  1370.                     break;                                      \
  1371.                   default: break;                               \
  1372.         }   }   }                                               \
  1373.         # und evtl. ÷ffentlich unzugΣnglich machen:             \
  1374.         if (imm_flag)                                           \
  1375.           { bigblock[0].mm_mapid = mapid;                       \
  1376.             bigblock[0].mm_addr = map_addr; bigblock[0].mm_len = map_len; \
  1377.             bigblock_ptr++;                                     \
  1378.           }                                                     \
  1379.           else                                                  \
  1380.           { if ( close_mapid(mapid) <0)                         \
  1381.               goto no_mem;                                      \
  1382.           }                                                     \
  1383.       }
  1384.     local void immutable_off (void);
  1385.     local void immutable_off()
  1386.       { var reg1 tint* tptr = &imm_types[0];
  1387.         var reg2 uintC count;
  1388.         dotimesC(count,imm_types_count,
  1389.           { var reg3 void* map_addr = ThePointer(type_pointer_object(*tptr,bigblock[0].mm_addr));
  1390.             if (map_mapid(bigblock[0].mm_mapid,map_addr,bigblock[0].mm_len,FALSE) <0)
  1391.               { asciz_out("Cannot remap immutable objects read/write.");
  1392.                 errno_out(errno);
  1393.                 quit_sofort(1);
  1394.               }
  1395.             tptr++;
  1396.           });
  1397.       }
  1398.     local void immutable_on (void);
  1399.     local void immutable_on()
  1400.       { var reg1 tint* tptr = &imm_types[0];
  1401.         var reg2 uintC count;
  1402.         dotimesC(count,imm_types_count,
  1403.           { var reg3 void* map_addr = ThePointer(type_pointer_object(*tptr,bigblock[0].mm_addr));
  1404.             if (map_mapid(bigblock[0].mm_mapid,map_addr,bigblock[0].mm_len,TRUE) <0)
  1405.               { asciz_out("Cannot remap immutable objects read-only.");
  1406.                 errno_out(errno);
  1407.                 quit_sofort(1);
  1408.               }
  1409.             tptr++;
  1410.           });
  1411.       }
  1412.     #define exitmap()  \
  1413.       { if (!(bigblock_ptr == &bigblock[0])) \
  1414.           close_mapid(bigblock[0].mm_mapid); \
  1415.       }
  1416.   #endif
  1417.  
  1418. #endif # MULTIMAP_MEMORY_VIA_FILE
  1419.  
  1420. #ifdef MULTIMAP_MEMORY_VIA_SHM
  1421.  
  1422. # Virtual Memory Mapping ⁿber Shared Memory aufbauen:
  1423.  
  1424.   local int initmap (void);
  1425.   local int initmap()
  1426.     {
  1427.      #ifdef UNIX_LINUX
  1428.       { var struct shminfo shminfo;
  1429.         if ( shmctl(0,IPC_INFO,(struct shmid_ds *)&shminfo) <0)
  1430.           if (errno==ENOSYS)
  1431.             { asciz_out(DEUTSCH ? "Compilieren Sie Ihr Betriebssystem neu mit Unterstⁿtzung von SYSV IPC." CRLFstring :
  1432.                         ENGLISH ? "Recompile your operating system with SYSV IPC support." CRLFstring :
  1433.                         FRANCAIS ? "Recompilez votre systΦme opΘrationnel tel qu'il comprenne IPC SYSV." CRLFstring :
  1434.                         ""
  1435.                        );
  1436.               return -1; # error
  1437.       }     }
  1438.      #endif
  1439.      return 0;
  1440.     }
  1441.  
  1442.   local int open_shmid (uintL map_len);
  1443.   local int open_shmid(map_len)
  1444.     var reg2 uintL map_len;
  1445.     { var reg1 int shmid = shmget(IPC_PRIVATE,map_len,0600|IPC_CREAT); # 0600 = 'Read/Write nur fⁿr mich'
  1446.       if (shmid<0)
  1447.         { asciz_out(DEUTSCH ? "Kann kein privates Shared-Memory-Segment aufmachen." :
  1448.                     ENGLISH ? "Cannot allocate private shared memory segment." :
  1449.                     FRANCAIS ? "Ne peux pas allouer de segment privΘ de mΘmoire partagΘe." :
  1450.                     ""
  1451.                    );
  1452.           errno_out(errno);
  1453.           return -1; # error
  1454.         }
  1455.       return shmid;
  1456.     }
  1457.  
  1458.   #ifndef SHM_REMAP  # Nur UNIX_LINUX ben÷tigt SHM_REMAP in den shmflags
  1459.     #define SHM_REMAP  0
  1460.   #endif
  1461.   local int idmap (int shmid, void* map_addr, int shmflags);
  1462.   local int idmap(shmid,map_addr,shmflags)
  1463.     var reg2 int shmid;
  1464.     var reg1 void* map_addr;
  1465.     var reg3 int shmflags;
  1466.     { if ( shmat(shmid,
  1467.                  map_addr, # Adresse
  1468.                  shmflags # Flags (Default: Read/Write)
  1469.                 )
  1470.            == (void*)(-1)
  1471.          )
  1472.         { asciz_out(DEUTSCH ? "Kann kein Shared-Memory an Adresse 0x" :
  1473.                     ENGLISH ? "Cannot map shared memory to address 0x" :
  1474.                     FRANCAIS ? "Ne peux pas placer de la mΘmoire partagΘe α l'adresse 0x" :
  1475.                     ""
  1476.                    );
  1477.           hex_out(map_addr);
  1478.           asciz_out(DEUTSCH ? " legen." :
  1479.                     ENGLISH ? "." :
  1480.                     FRANCAIS ? "." :
  1481.                     ""
  1482.                    );
  1483.           errno_out(errno);
  1484.           return -1; # error
  1485.         }
  1486.       return 0;
  1487.     }
  1488.  
  1489.   local int close_shmid (int shmid);
  1490.   local int close_shmid(shmid)
  1491.     var reg1 int shmid;
  1492.     { if ( shmctl(shmid,IPC_RMID,NULL) <0)
  1493.         { asciz_out(DEUTSCH ? "Kann Shared-Memory-Segment nicht entfernen." :
  1494.                     ENGLISH ? "Cannot remove shared memory segment." :
  1495.                     FRANCAIS ? "Ne peux pas retirer un segment de mΘmoire partagΘe." :
  1496.                     ""
  1497.                    );
  1498.           errno_out(errno);
  1499.           return -1; # error
  1500.         }
  1501.       return 0;
  1502.     }
  1503.  
  1504.   local int zeromap (void* map_addr, uintL map_len);
  1505.   local int zeromap(map_addr,map_len)
  1506.     var reg3 void* map_addr;
  1507.     var reg2 uintL map_len;
  1508.     { var reg1 int shmid = open_shmid(map_len);
  1509.       if (shmid<0)
  1510.         { return -1; } # error
  1511.       if (idmap(shmid,map_addr,0) < 0)
  1512.         { return -1; } # error
  1513.       return close_shmid(shmid);
  1514.     }
  1515.  
  1516.   # Vorgehen bei multimap:
  1517.   # 1. Shared-Memory-Bereich zur Verfⁿgung stellen
  1518.     #define open_mapid(map_len)  open_shmid(map_len) # -> shmid
  1519.   # 2. Shared-Memory mehrfach ⁿberlagert in den Speicher legen
  1520.     #define map_mapid(shmid,map_addr,map_len,flags)  idmap(shmid,map_addr,flags)
  1521.   # 3. ÷ffentlich unzugΣnglich machen, indem wir ihn l÷schen:
  1522.   # (Das Betriebssystem l÷scht den Shared Memory erst dann, wenn am
  1523.   # Ende dieses Prozesses in _exit() ein munmap() durchgefⁿhrt wird.)
  1524.     #define close_mapid(shmid)  close_shmid(shmid)
  1525.  
  1526.   #ifndef IMMUTABLE
  1527.     #define multimap(typecases,imm_typecases,imm_flag,total_map_addr,total_map_len)  \
  1528.       { var reg4 uintL remaining_len = total_map_len;                                    \
  1529.         var reg5 aint map_addr = total_map_addr;                                         \
  1530.         do { var reg3 uintL map_len = (remaining_len > SHMMAX ? SHMMAX : remaining_len); \
  1531.              # Shared-Memory-Bereich aufmachen:                                          \
  1532.              var reg2 int mapid = open_mapid(map_len);                                   \
  1533.              if (mapid<0) goto no_mem;                                                   \
  1534.              # und mehrfach ⁿberlagert in den Speicher legen:                            \
  1535.              { var reg1 oint type;                                                       \
  1536.                for (type=0; type < bit(oint_type_len<=8 ? oint_type_len : 8); type++)    \
  1537.                  { switch (type)                                                         \
  1538.                      { typecases                                                         \
  1539.                          if ( map_mapid(mapid, ThePointer(type_pointer_object(type,map_addr)), map_len, \
  1540.                                         (type==0 ? SHM_REMAP : 0)                        \
  1541.                                        )                                                 \
  1542.                               <0                                                         \
  1543.                             )                                                            \
  1544.                            goto no_mem;                                                  \
  1545.                          break;                                                          \
  1546.                        default: break;                                                   \
  1547.              }   }   }                                                                   \
  1548.              # und ÷ffentlich unzugΣnglich machen:                                       \
  1549.              if ( close_mapid(mapid) <0)                                                 \
  1550.                goto no_mem;                                                              \
  1551.              map_addr += map_len; remaining_len -= map_len;                              \
  1552.            }                                                                             \
  1553.            until (remaining_len==0);                                                     \
  1554.       }
  1555.     #define immutable_off()
  1556.     #define immutable_on()
  1557.     #define exitmap()
  1558.   #else # IMMUTABLE
  1559.     typedef struct { int mm_mapid; aint mm_addr; uintL mm_len; } mmapping;
  1560.     local mmapping bigblock[256]; # Hoffentlich reicht 256, da 256*64KB = 2^24 ??
  1561.     local mmapping* bigblock_ptr = &bigblock[0];
  1562.     # Wann werden Shared-Memory-Segmente freigegeben? Je nachdem,
  1563.     # ob shmat() auf einem Shared-Memory-Segment funktioniert, das bereits
  1564.     # mit shmctl(..,IPC_RMID,NULL) entfernt wurde, aber noch nattch > 0 hat.
  1565.     #ifdef SHM_RMID_VALID # UNIX_LINUX || ...
  1566.       #define SHM_RM_atonce  TRUE
  1567.       #define SHM_RM_atexit  FALSE
  1568.     #else # UNIX_SUNOS4 || ...
  1569.       #define SHM_RM_atonce  FALSE
  1570.       #define SHM_RM_atexit  TRUE
  1571.     #endif
  1572.     #define multimap(typecases,imm_typecases,imm_flag,total_map_addr,total_map_len)  \
  1573.       { var reg4 uintL remaining_len = total_map_len;                                    \
  1574.         var reg5 aint map_addr = total_map_addr;                                         \
  1575.         do { var reg3 uintL map_len = (remaining_len > SHMMAX ? SHMMAX : remaining_len); \
  1576.              # Shared-Memory-Bereich aufmachen:                                          \
  1577.              var reg2 int mapid = open_mapid(map_len);                                   \
  1578.              if (mapid<0) goto no_mem;                                                   \
  1579.              # und mehrfach ⁿberlagert in den Speicher legen:                            \
  1580.              { var reg1 oint type;                                                       \
  1581.                for (type=0; type < bit(oint_type_len<=8 ? oint_type_len : 8); type++)    \
  1582.                  { var reg6 int readonly;                                                \
  1583.                    switch (type)                                                         \
  1584.                      { typecases                                                         \
  1585.                          switch (type)                                                   \
  1586.                            { imm_typecases  readonly = TRUE; break;                      \
  1587.                              default:       readonly = FALSE; break;                     \
  1588.                            }                                                             \
  1589.                          if ( map_mapid(mapid, ThePointer(type_pointer_object(type,map_addr)), map_len, \
  1590.                                         (readonly ? SHM_RDONLY : 0) | (type==0 ? SHM_REMAP : 0) \
  1591.                                        )                                                 \
  1592.                               <0                                                         \
  1593.                             )                                                            \
  1594.                            goto no_mem;                                                  \
  1595.                          break;                                                          \
  1596.                        default: break;                                                   \
  1597.              }   }   }                                                                   \
  1598.              # und evtl. ÷ffentlich unzugΣnglich machen:                                 \
  1599.              if (imm_flag)                                                               \
  1600.                { bigblock_ptr->mm_mapid = mapid;                                         \
  1601.                  bigblock_ptr->mm_addr = map_addr; bigblock_ptr->mm_len = map_len;       \
  1602.                  bigblock_ptr++;                                                         \
  1603.                  if (SHM_RM_atonce)                                                      \
  1604.                    { if ( close_mapid(mapid) <0)                                         \
  1605.                        goto no_mem;                                                      \
  1606.                    }                                                                     \
  1607.                }                                                                         \
  1608.                else                                                                      \
  1609.                { if ( close_mapid(mapid) <0)                                             \
  1610.                    goto no_mem;                                                          \
  1611.                }                                                                         \
  1612.              map_addr += map_len; remaining_len -= map_len;                              \
  1613.            }                                                                             \
  1614.            until (remaining_len==0);                                                     \
  1615.       }
  1616.     local void immutable_off (void);
  1617.     local void immutable_off()
  1618.       { var reg3 tint* tptr = &imm_types[0];
  1619.         var reg4 uintC count;
  1620.         dotimesC(count,imm_types_count,
  1621.           { var reg1 mmapping* ptr = &bigblock[0];
  1622.             until (ptr==bigblock_ptr)
  1623.               { var reg2 void* map_addr = ThePointer(type_pointer_object(*tptr,ptr->mm_addr));
  1624.                 if ((shmdt(map_addr) <0) ||
  1625.                     (map_mapid(ptr->mm_mapid, map_addr, ptr->mm_len, 0) <0))
  1626.                   { asciz_out("Cannot remap immutable objects read/write.");
  1627.                     errno_out(errno);
  1628.                     quit_sofort(1);
  1629.                   }
  1630.                 ptr++;
  1631.               }
  1632.             tptr++;
  1633.           });
  1634.       }
  1635.     local void immutable_on (void);
  1636.     local void immutable_on()
  1637.       { var reg3 tint* tptr = &imm_types[0];
  1638.         var reg4 uintC count;
  1639.         dotimesC(count,imm_types_count,
  1640.           { var reg1 mmapping* ptr = &bigblock[0];
  1641.             until (ptr==bigblock_ptr)
  1642.               { var reg2 void* map_addr = ThePointer(type_pointer_object(*tptr,ptr->mm_addr));
  1643.                 if ((shmdt(map_addr) <0) ||
  1644.                     (map_mapid(ptr->mm_mapid, map_addr, ptr->mm_len, SHM_RDONLY) <0))
  1645.                   { asciz_out("Cannot remap immutable objects read-only.");
  1646.                     errno_out(errno);
  1647.                     quit_sofort(1);
  1648.                   }
  1649.                 ptr++;
  1650.               }
  1651.             tptr++;
  1652.           });
  1653.       }
  1654.     #if SHM_RM_atexit
  1655.       #define exitmap()  \
  1656.         { var reg1 mmapping* ptr = &bigblock[0];                           \
  1657.           until (ptr==bigblock_ptr) { close_mapid(ptr->mm_mapid); ptr++; } \
  1658.         }
  1659.     #else
  1660.       #define exitmap()
  1661.     #endif
  1662.   #endif
  1663.  
  1664. #endif # MULTIMAP_MEMORY_VIA_SHM
  1665.  
  1666. #endif # MULTIMAP_MEMORY
  1667.  
  1668. #if defined(SINGLEMAP_MEMORY) || defined(TRIVIALMAP_MEMORY)
  1669.  
  1670. # Das Betriebssystem erlaubt es, an willkⁿrlichen Adressen Speicher hinzulegen,
  1671. # der sich genauso benimmt wie malloc()-allozierter Speicher.
  1672.  
  1673. # LΣnge einer Speicherseite des Betriebssystems:
  1674.   local /* uintL */ aint map_pagesize; # wird eine Zweierpotenz sein, meist 4096.
  1675.  
  1676. # Initialisierung:
  1677. # initmap()
  1678.  
  1679. # In einen Speicherbereich [map_addr,map_addr+map_len-1] leere Seiten legen:
  1680. # (map_addr und map_len durch map_pagesize teilbar.)
  1681. # zeromap(map_addr,map_len)
  1682.  
  1683. #ifdef HAVE_MACH_VM
  1684.  
  1685.   local int initmap (void);
  1686.   local int initmap()
  1687.     { return 0; }
  1688.  
  1689.   local int zeromap (void* map_addr, uintL map_len);
  1690.   local int zeromap(map_addr,map_len)
  1691.     var void* map_addr;
  1692.     var reg1 uintL map_len;
  1693.     { if (!(vm_allocate(task_self(), (vm_address_t*) &map_addr, map_len, FALSE)
  1694.             == KERN_SUCCESS
  1695.          ) )
  1696.         { asciz_out(DEUTSCH ? "Kann keinen Speicher an Adresse 0x" :
  1697.                     ENGLISH ? "Cannot map memory to address 0x" :
  1698.                     FRANCAIS ? "Ne peux pas placer de la mΘmoire α l'adresse 0x" :
  1699.                     ""
  1700.                    );
  1701.           hex_out(map_addr);
  1702.           asciz_out(DEUTSCH ? " legen." :
  1703.                     ENGLISH ? " ." :
  1704.                     FRANCAIS ? " ." :
  1705.                     ""
  1706.                    );
  1707.           asciz_out(CRLFstring);
  1708.           return -1; # error
  1709.         }
  1710.       return 0;
  1711.     }
  1712.  
  1713.   # Ein Ersatz fⁿr die mmap-Funktion. Nur fⁿr Files geeignet.
  1714.   #define MAP_FIXED    0
  1715.   #define MAP_PRIVATE  0
  1716.   global RETMMAPTYPE mmap (addr,len,prot,flags,fd,off)
  1717.     var MMAP_ADDR_T addr;
  1718.     var MMAP_SIZE_T len;
  1719.     var int prot; # sollte PROT_READ | PROT_WRITE sein??
  1720.     var int flags; # sollte MAP_FIXED | MAP_PRIVATE sein??
  1721.     var int fd; # sollte ein gⁿltiges Handle sein
  1722.     var off_t off;
  1723.     { switch (vm_allocate(task_self(), (vm_address_t*) &addr, len, FALSE))
  1724.         { case KERN_SUCCESS:
  1725.             break;
  1726.           default:
  1727.             errno = EINVAL; return (RETMMAPTYPE)(-1);
  1728.         }
  1729.       switch (map_fd(fd, off, (vm_address_t*) &addr, 0, len))
  1730.         { case KERN_SUCCESS:
  1731.             return addr;
  1732.           case KERN_INVALID_ADDRESS:
  1733.           case KERN_INVALID_ARGUMENT:
  1734.           default:
  1735.             errno = EINVAL; return (RETMMAPTYPE)(-1);
  1736.     }   }
  1737.  
  1738.   # Ein Ersatz fⁿr die munmap-Funktion.
  1739.   global int munmap(addr,len)
  1740.     var reg2 MMAP_ADDR_T addr;
  1741.     var reg3 MMAP_SIZE_T len;
  1742.     { switch (vm_deallocate(task_self(),addr,len))
  1743.         { case KERN_SUCCESS:
  1744.             return 0;
  1745.           case KERN_INVALID_ADDRESS:
  1746.           default:
  1747.             errno = EINVAL; return -1;
  1748.     }   }
  1749.  
  1750.   # Ein Ersatz fⁿr die mprotect-Funktion.
  1751.   global int mprotect(addr,len,prot)
  1752.     var reg2 MMAP_ADDR_T addr;
  1753.     var reg3 MMAP_SIZE_T len;
  1754.     var reg4 int prot;
  1755.     { switch (vm_protect(task_self(),addr,len,0,prot))
  1756.         { case KERN_SUCCESS:
  1757.             return 0;
  1758.           case KERN_PROTECTION_FAILURE:
  1759.             errno = EACCES; return -1;
  1760.           case KERN_INVALID_ADDRESS:
  1761.           default:
  1762.             errno = EINVAL; return -1;
  1763.     }   }
  1764.  
  1765. #else
  1766.  
  1767. # Beide mmap()-Methoden gleichzeitig anzuwenden, ist unn÷tig:
  1768. #ifdef HAVE_MMAP_ANON
  1769.   #undef HAVE_MMAP_DEVZERO
  1770. #endif
  1771.  
  1772. #ifdef HAVE_MMAP_DEVZERO
  1773.   local int zero_fd; # Handle von /dev/zero
  1774.   # Zugriff auf /dev/zero: /dev/zero hat manchmal Permissions 0644. Daher
  1775.   # OPEN() mit nur O_RDONLY statt O_RDWR. Daher MAP_PRIVATE statt MAP_SHARED.
  1776.   #ifdef MAP_FILE
  1777.     #define map_flags  MAP_FILE | MAP_PRIVATE
  1778.   #else
  1779.     #define map_flags  MAP_PRIVATE
  1780.   #endif
  1781. #endif
  1782. #ifdef HAVE_MMAP_ANON
  1783.   #define zero_fd  -1 # irgendein ungⁿltiges Handle geht!
  1784.   #define map_flags  MAP_ANON | MAP_PRIVATE
  1785. #endif
  1786.  
  1787.   local int initmap (void);
  1788.   local int initmap()
  1789.     {
  1790.       #ifdef HAVE_MMAP_DEVZERO
  1791.       { var reg1 int fd = OPEN("/dev/zero",O_RDONLY,my_open_mask);
  1792.         if (fd<0)
  1793.           { asciz_out(DEUTSCH ? "Kann /dev/zero nicht ÷ffnen." :
  1794.                       ENGLISH ? "Cannot open /dev/zero ." :
  1795.                       FRANCAIS ? "Ne peux pas ouvrir /dev/zero ." :
  1796.                       ""
  1797.                      );
  1798.             errno_out(errno);
  1799.             return -1; # error
  1800.           }
  1801.         zero_fd = fd;
  1802.       }
  1803.       #endif
  1804.       return 0;
  1805.     }
  1806.  
  1807.   local int zeromap (void* map_addr, uintL map_len);
  1808.   local int zeromap(map_addr,map_len)
  1809.     var reg1 void* map_addr;
  1810.     var reg2 uintL map_len;
  1811.     { if ( (void*) mmap(map_addr, # gewⁿnschte Adresse
  1812.                         map_len, # LΣnge
  1813.                         PROT_READ | PROT_WRITE, # Zugriffsrechte
  1814.                         map_flags | MAP_FIXED, # genau an diese Adresse!
  1815.                         zero_fd, 0 # leere Seiten legen
  1816.                        )
  1817.            == (void*)(-1)
  1818.          )
  1819.         { asciz_out(DEUTSCH ? "Kann keinen Speicher an Adresse 0x" :
  1820.                     ENGLISH ? "Cannot map memory to address 0x" :
  1821.                     FRANCAIS ? "Ne peux pas placer de la mΘmoire α l'adresse 0x" :
  1822.                     ""
  1823.                    );
  1824.           hex_out(map_addr);
  1825.           asciz_out(DEUTSCH ? " legen." :
  1826.                     ENGLISH ? " ." :
  1827.                     FRANCAIS ? " ." :
  1828.                     ""
  1829.                    );
  1830.           errno_out(errno);
  1831.           return -1; # error
  1832.         }
  1833.       return 0;
  1834.     }
  1835.  
  1836. #endif # HAVE_MACH_VM
  1837.  
  1838. #endif # SINGLEMAP_MEMORY || TRIVIALMAP_MEMORY
  1839.  
  1840. # ------------------------------------------------------------------------------
  1841. #                           Page-Verwaltung
  1842.  
  1843. # Page-Deskriptor:
  1844. typedef struct { aint start;   # Pointer auf den belegten Platz (aligned)
  1845.                  aint end;     # Pointer hinter den belegten Platz (aligned)
  1846.                  union { object firstmarked; uintL l; aint d; void* next; }
  1847.                        gcpriv; # private Variable wΣhrend GC
  1848.                }
  1849.         _Page;
  1850.  
  1851. # Page-Deskriptor samt dazugeh÷riger Verwaltungsinformation:
  1852. # typedef ... Page;
  1853. # Hat die Komponenten page_start, page_end, page_gcpriv.
  1854.  
  1855. # Eine Ansammlung von Pages:
  1856. # typedef ... Pages;
  1857.  
  1858. # Eine Ansammlung von Pages und die fⁿr sie n÷tige Verwaltungsinformation:
  1859. # typedef ... Heap;
  1860.  
  1861. #ifdef SPVW_PAGES
  1862.  
  1863. #if !defined(VIRTUAL_MEMORY) || defined(BROKEN_MALLOC)
  1864. # Jede Page enthΣlt einen Header fⁿr die AVL-Baum-Verwaltung.
  1865. # Das erlaubt es, da▀ die AVL-Baum-Verwaltung selbst keine malloc-Aufrufe
  1866. # tΣtigen mu▀.
  1867. #else # defined(VIRTUAL_MEMORY) && !defined(BROKEN_MALLOC)
  1868. # Bei Virtual Memory ist es schlecht, wenn die GC alle Seiten anfassen mu▀.
  1869. # Daher sei die AVL-Baum-Verwaltung separat.
  1870. #define AVL_SEPARATE
  1871. #endif
  1872.  
  1873. #define AVLID  spvw
  1874. #define AVL_ELEMENT  uintL
  1875. #define AVL_EQUAL(element1,element2)  ((element1)==(element2))
  1876. #define AVL_KEY  AVL_ELEMENT
  1877. #define AVL_KEYOF(element)  (element)
  1878. #define AVL_COMPARE(key1,key2)  (sintL)((key1)-(key2))
  1879. #define NO_AVL_MEMBER
  1880. #define NO_AVL_INSERT
  1881. #define NO_AVL_DELETE
  1882.  
  1883. #include "avl.c"
  1884.  
  1885. typedef struct NODE
  1886.                { NODEDATA nodedata;        # NODE fⁿr AVL-Baum-Verwaltung
  1887.                  #define page_room  nodedata.value # freier Platz in dieser Page (in Bytes)
  1888.                  _Page page;       # Page-Deskriptor, bestehend aus:
  1889.                  #define page_start  page.start  # Pointer auf den belegten Platz (aligned)
  1890.                  #define page_end    page.end    # Pointer auf den freien Platz (aligned)
  1891.                  #define page_gcpriv page.gcpriv # private Variable wΣhrend GC
  1892.                  aint m_start;     # von malloc gelieferte Startadresse (unaligned)
  1893.                  aint m_length;    # bei malloc angegebene Page-LΣnge (in Bytes)
  1894.                }
  1895.         NODE;
  1896. #define HAVE_NODE
  1897.  
  1898. #if !defined(AVL_SEPARATE)
  1899.   # NODE innerhalb der Seite
  1900.   #define sizeof_NODE  sizeof(NODE)
  1901.   #define page_start0(page)  round_up((aint)page+sizeof(NODE),Varobject_alignment)
  1902.   #define free_page(page)  begin_system_call(); free((void*)page->m_start); end_system_call();
  1903. #else
  1904.   # NODE extra
  1905.   #define sizeof_NODE  0
  1906.   #define page_start0(page)  round_up(page->m_start,Varobject_alignment)
  1907.   #define free_page(page)  begin_system_call(); free((void*)page->m_start); free((void*)page); end_system_call();
  1908. #endif
  1909.  
  1910. #include "avl.c"
  1911.  
  1912. typedef NODE Page;
  1913.  
  1914. typedef Page* Pages;
  1915.  
  1916. typedef struct { Pages inuse;     # Die gerade benutzten Pages
  1917.                  # _Page reserve; # Eine Reserve-Page ??
  1918.                  # Bei Heap fⁿr Objekte fester LΣnge:
  1919.                  Pages lastused; # Ein Cache fⁿr die letzte benutzte Page
  1920.                }
  1921.         Heap;
  1922.  
  1923. # Gr÷▀e einer normalen Page = minimale Pagegr÷▀e. Durch sizeof(cons_) teilbar.
  1924.   # Um offset_pages_len (s.u.) nicht zu gro▀ werden zu lassen, darf die
  1925.   # Pagegr÷▀e nicht zu klein sein.
  1926.   #if (oint_addr_len<=32)
  1927.     #define oint_addr_relevant_len  oint_addr_len
  1928.   #else
  1929.     #if defined(DECALPHA) && defined(UNIX_OSF)
  1930.       # Alle Adressen liegen zwischen 1*2^32 und 2*2^32. Also faktisch doch
  1931.       # nur ein Adre▀raum von 2^32.
  1932.       #define oint_addr_relevant_len  32
  1933.     #endif
  1934.   #endif
  1935.   #define min_page_size_brutto  bit(oint_addr_relevant_len/2)
  1936.   #define std_page_size  round_down(min_page_size_brutto-sizeof_NODE-(Varobject_alignment-1),sizeof(cons_))
  1937.  
  1938. # Eine Dummy-Page fⁿr lastused:
  1939.   local NODE dummy_NODE;
  1940.   #define dummy_lastused  (&dummy_NODE)
  1941.  
  1942. #endif
  1943.  
  1944. #ifdef SPVW_BLOCKS
  1945.  
  1946. typedef _Page Page;
  1947. #define page_start   start
  1948. #define page_end     end
  1949. #define page_gcpriv  gcpriv
  1950.  
  1951. typedef Page Pages;
  1952.  
  1953. #ifdef SPVW_MIXED_BLOCKS_OPPOSITE
  1954.  
  1955. typedef Pages Heap;
  1956.  
  1957. #else # SPVW_PURE_BLOCKS || (SPVW_MIXED_BLOCKS && TRIVIALMAP_MEMORY)
  1958.  
  1959. #ifdef GENERATIONAL_GC
  1960. # Fⁿr jede physikalische Speicherseite der alten Generation merken wir uns,
  1961. # um auf diese Seite nicht zugreifen zu mⁿssen, welche Pointer auf Objekte
  1962. # der neuen Generation diese enthΣlt.
  1963. # Solange man auf die Seite nicht schreibend zugreift, bleibt diese Information
  1964. # aktuell. Nachdem man auf die Seite aber schreibend zugegriffen hat, mu▀ man
  1965. # diese Information bei der nΣchsten GC neu erstellen. Dies sollte man aber
  1966. # machen, ohne auf die Seite davor oder danach zugreifen zu mⁿssen.
  1967. typedef struct { object* p; # Adresse des Pointers, innerhalb eines alten Objekts
  1968.                  object o;  # o = *p, Pointer auf ein neues Objekt
  1969.                }
  1970.         old_new_pointer;
  1971. typedef struct { # Durchlaufen der Pointer in der Seite ben÷tigt Folgendes:
  1972.                    # Fortsetzung des letzten Objekts der Seite davor:
  1973.                    object* continued_addr;
  1974.                    uintC continued_count;
  1975.                    # Erstes Objekt, das in dieser Seite (oder spΣter) beginnt:
  1976.                    aint firstobject;
  1977.                  # Der Cache der Pointer auf Objekte der neuen Generation:
  1978.                  int protection; # PROT_NONE : Nur der Cache ist gⁿltig.
  1979.                                  # PROT_READ : Seite und Cache beide gⁿltig.
  1980.                                  # PROT_READ_WRITE : Nur die Seite ist gⁿltig.
  1981.                  uintL cache_size; # Anzahl der gecacheten Pointer
  1982.                  old_new_pointer* cache; # Cache aller Pointer in die neue
  1983.                                          # Generation
  1984.                }
  1985.         physpage_state;
  1986. #endif
  1987.  
  1988. typedef struct { Pages pages;
  1989.                  aint limit;
  1990.                  #ifdef GENERATIONAL_GC
  1991.                  aint heap_gen0_start;
  1992.                  aint heap_gen0_end;
  1993.                  aint heap_gen1_start;
  1994.                  physpage_state* physpages;
  1995.                  #endif
  1996.                }
  1997.         Heap;
  1998. #define heap_start  pages.page_start
  1999. #define heap_end    pages.page_end
  2000. #define heap_limit  limit
  2001. # Stets heap_start <= heap_end <= heap_limit.
  2002. # Der Speicher zwischen heap_start und heap_end ist belegt,
  2003. # der Speicher zwischen heap_end und heap_limit ist frei.
  2004. # heap_limit wird, wenn n÷tig, vergr÷▀ert.
  2005. #ifdef GENERATIONAL_GC
  2006. # Die Generation 0 (Σltere Generation) beginnt bei heap_gen0_start,
  2007. #                                      geht bis    heap_gen0_end.
  2008. # Die Generation 1 (neuere Generation) beginnt bei heap_gen1_start,
  2009. #                                      geht bis    heap_end.
  2010. # heap_gen0_start und heap_gen1_start sind durch physpagesize teilbar.
  2011. # Zwischen heap_gen0_end und heap_gen1_start ist eine Lⁿcke von weniger als
  2012. # einer Page.
  2013. # heap_start ist entweder = heap_gen0_start oder = heap_gen1_start.
  2014. # Der Status von Adresse addr (heap_gen0_start <= addr < heap_gen0_end) wird
  2015. # von physpages[(addr>>physpageshift)-(heap_gen0_start>>physpageshift)] gegeben.
  2016. # physpages=NULL ist m÷glich, wenn nicht genⁿgend Platz da war!
  2017. #endif
  2018.  
  2019. #endif
  2020.  
  2021. #endif
  2022.  
  2023. #ifdef SPVW_MIXED
  2024.  
  2025. # Zwei Heaps: einer fⁿr Objekte variabler LΣnge, einer fⁿr Conses u.Σ.
  2026. #define heapcount  2
  2027.  
  2028. #endif
  2029.  
  2030. #ifdef SPVW_PURE
  2031.  
  2032. # Ein Heap fⁿr jeden m÷glichen Typcode
  2033. #define heapcount  bit(oint_type_len<=8 ? oint_type_len : 8)
  2034.  
  2035. #endif
  2036.  
  2037. # Fⁿr jeden m÷glichen Heap (0 <= heapnr < heapcount) den Typ des Heaps feststellen:
  2038. # is_cons_heap(heapnr)
  2039. # is_varobject_heap(heapnr)
  2040. # is_heap_containing_objects(heapnr)
  2041. # is_unused_heap(heapnr)
  2042. #ifdef SPVW_MIXED
  2043.   #define is_cons_heap(heapnr)  ((heapnr)==1)
  2044.   #define is_varobject_heap(heapnr)  ((heapnr)==0)
  2045.   #define is_heap_containing_objects(heapnr)  (TRUE)
  2046.   #define is_unused_heap(heapnr)  (FALSE)
  2047. #endif
  2048. #ifdef SPVW_PURE
  2049.   #define is_cons_heap(heapnr)  (mem.heaptype[heapnr] == 0)
  2050.   #define is_varobject_heap(heapnr)  (mem.heaptype[heapnr] > 0)
  2051.   #define is_heap_containing_objects(heapnr)  ((mem.heaptype[heapnr] >= 0) && (mem.heaptype[heapnr] < 2))
  2052.   #define is_unused_heap(heapnr)  (mem.heaptype[heapnr] < 0)
  2053. #endif
  2054.  
  2055. # Durchlaufen aller CONS-Pages:
  2056. # for_each_cons_page(page, [statement, das 'var Page* page' benutzt] );
  2057.  
  2058. # Durchlaufen aller Pages von Objekten variabler LΣnge:
  2059. # for_each_varobject_page(page, [statement, das 'var Page* page' benutzt] );
  2060.  
  2061. # Durchlaufen aller Pages:
  2062. # for_each_page(page, [statement, das 'var Page* page' benutzt] );
  2063.  
  2064. #ifdef SPVW_BLOCKS
  2065. #ifdef SPVW_MIXED_BLOCKS_OPPOSITE
  2066.   #define map_heap(heap,pagevar,statement)  \
  2067.     { var reg1 Page* pagevar = &(heap); statement; }
  2068. #else
  2069.   #define map_heap(heap,pagevar,statement)  \
  2070.     { var reg1 Page* pagevar = &(heap).pages; statement; }
  2071. #endif
  2072. #endif
  2073. #ifdef SPVW_PAGES
  2074.   #define map_heap(heap,pagevar,statement)  \
  2075.     { AVL_map((heap).inuse,pagevar,statement); }
  2076. #endif
  2077.  
  2078. #ifdef SPVW_MIXED
  2079.  
  2080. #define for_each_cons_heap(heapvar,statement)  \
  2081.   { var reg3 Heap* heapvar = &mem.conses; statement; }
  2082. #define for_each_varobject_heap(heapvar,statement)  \
  2083.   { var reg3 Heap* heapvar = &mem.objects; statement; }
  2084. #define for_each_heap(heapvar,statement)  \
  2085.   { var reg4 uintL heapnr;                                        \
  2086.     for (heapnr=0; heapnr<heapcount; heapnr++)                    \
  2087.       { var reg3 Heap* heapvar = &mem.heaps[heapnr]; statement; } \
  2088.   }
  2089.  
  2090. #define for_each_cons_page(pagevar,statement)  \
  2091.   map_heap(mem.conses,pagevar,statement)
  2092. #define for_each_cons_page_reversed for_each_cons_page
  2093. #define for_each_varobject_page(pagevar,statement)  \
  2094.   map_heap(mem.objects,pagevar,statement)
  2095. #define for_each_page(pagevar,statement)  \
  2096.   { var reg4 uintL heapnr;                           \
  2097.     for (heapnr=0; heapnr<heapcount; heapnr++)       \
  2098.       map_heap(mem.heaps[heapnr],pagevar,statement); \
  2099.   }
  2100.  
  2101. #endif
  2102.  
  2103. #ifdef SPVW_PURE
  2104.  
  2105. # Innerhalb der Schleife ist heapnr die Nummer des Heaps.
  2106.  
  2107. #define for_each_cons_heap(heapvar,statement)  \
  2108.   { var reg4 uintL heapnr;                                          \
  2109.     for (heapnr=0; heapnr<heapcount; heapnr++)                      \
  2110.       if (mem.heaptype[heapnr] == 0)                                \
  2111.         { var reg3 Heap* heapvar = &mem.heaps[heapnr]; statement; } \
  2112.   }
  2113. #define for_each_varobject_heap(heapvar,statement)  \
  2114.   { var reg4 uintL heapnr;                                          \
  2115.     for (heapnr=0; heapnr<heapcount; heapnr++)                      \
  2116.       if (mem.heaptype[heapnr] > 0)                                 \
  2117.         { var reg3 Heap* heapvar = &mem.heaps[heapnr]; statement; } \
  2118.   }
  2119. #define for_each_heap(heapvar,statement)  \
  2120.   { var reg4 uintL heapnr;                                          \
  2121.     for (heapnr=0; heapnr<heapcount; heapnr++)                      \
  2122.       if (mem.heaptype[heapnr] >= 0)                                \
  2123.         { var reg3 Heap* heapvar = &mem.heaps[heapnr]; statement; } \
  2124.   }
  2125.  
  2126. #define for_each_cons_page(pagevar,statement)  \
  2127.   { var reg4 uintL heapnr;                             \
  2128.     for (heapnr=0; heapnr<heapcount; heapnr++)         \
  2129.       if (mem.heaptype[heapnr] == 0)                   \
  2130.         map_heap(mem.heaps[heapnr],pagevar,statement); \
  2131.   }
  2132. #define for_each_cons_page_reversed(pagevar,statement)  \
  2133.   { var reg4 uintL heapnr;                             \
  2134.     for (heapnr=heapcount; heapnr-- > 0; )             \
  2135.       if (mem.heaptype[heapnr] == 0)                   \
  2136.         map_heap(mem.heaps[heapnr],pagevar,statement); \
  2137.   }
  2138. #define for_each_varobject_page(pagevar,statement)  \
  2139.   { var reg4 uintL heapnr;                             \
  2140.     for (heapnr=0; heapnr<heapcount; heapnr++)         \
  2141.       if (mem.heaptype[heapnr] > 0)                    \
  2142.         map_heap(mem.heaps[heapnr],pagevar,statement); \
  2143.   }
  2144. #define for_each_page(pagevar,statement)  \
  2145.   { var reg4 uintL heapnr;                             \
  2146.     for (heapnr=0; heapnr<heapcount; heapnr++)         \
  2147.       if (mem.heaptype[heapnr] >= 0)                   \
  2148.         map_heap(mem.heaps[heapnr],pagevar,statement); \
  2149.   }
  2150.  
  2151. #endif
  2152.  
  2153. # ------------------------------------------------------------------------------
  2154.  
  2155. # Speichergrenzen der LISP-Daten:
  2156.   local struct { aint MEMBOT;
  2157.                  # dazwischen der LISP-Stack
  2158.                  Heap heaps[heapcount];
  2159.                  #ifdef SPVW_PURE
  2160.                  sintB heaptype[heapcount];
  2161.                    # zu jedem Typcode: 0 falls Conses u.Σ.
  2162.                    #                   1 falls Objekte variabler LΣnge mit Pointern,
  2163.                    #                   2 falls Objekte variabler LΣnge ohne Pointer,
  2164.                    #                  -1 falls unbenutzter Typcode
  2165.                  #endif
  2166.                  #ifdef SPVW_MIXED
  2167.                   #define objects  heaps[0] # Objekte variabler LΣnge
  2168.                   #define conses   heaps[1] # Conses u.Σ.
  2169.                  #endif
  2170.                  #ifdef SPVW_MIXED_BLOCKS_OPPOSITE
  2171.                   # dazwischen leer, frei fⁿr LISP-Objekte
  2172.                  #define MEMRES    conses.end
  2173.                  # dazwischen Reserve
  2174.                  aint MEMTOP;
  2175.                  #endif
  2176.                  #if defined(SPVW_PURE_BLOCKS) || defined(TRIVIALMAP_MEMORY)
  2177.                  uintL total_room; # wieviel Platz belegt werden darf, ohne da▀ GC n÷tig wird
  2178.                  #ifdef GENERATIONAL_GC
  2179.                  boolean last_gc_full; # ob die letzte GC eine volle war
  2180.                  uintL last_gcend_space0; # wieviel Platz am Ende der letzten GC belegt war
  2181.                  uintL last_gcend_space1; # (von Generation 0 bzw. Generation 1)
  2182.                  #endif
  2183.                  #endif
  2184.                  #ifdef SPVW_PAGES
  2185.                  Pages free_pages; # eine Liste freier normalgro▀er Pages
  2186.                  uintL total_space; # wieviel Platz die belegten Pages ⁿberhaupt enthalten
  2187.                  uintL used_space; # wieviel Platz gerade belegt ist
  2188.                  uintL last_gcend_space; # wieviel Platz am Ende der letzten GC belegt war
  2189.                  boolean last_gc_compacted; # ob die letzte GC schon kompaktiert hat
  2190.                  uintL gctrigger_space; # wieviel Platz belegt werden darf, bis die nΣchste GC n÷tig wird
  2191.                  #endif
  2192.                }
  2193.         mem;
  2194.   #define RESERVE       0x00800L  # 2 KByte Speicherplatz als Reserve
  2195.   #define MINIMUM_SPACE 0x10000L  # 64 KByte als minimaler Speicherplatz
  2196.                                   #  fⁿr LISP-Daten
  2197.  
  2198. #ifdef ATARI
  2199.   local aint MEMBLOCK;
  2200.   # MEMBLOCK = Startadresse des vom Betriebssystem allozierten Speicherblocks
  2201.   # Der SP-Stack liegt zwischen MEMBLOCK und mem.MEMBOT.
  2202. #endif
  2203.  
  2204. # Stack-Grenzen:
  2205.   global void* SP_bound;    # SP-Wachstumsgrenze
  2206.   global void* STACK_bound; # STACK-Wachstumsgrenze
  2207.   #if defined(EMUNIX) && defined(WINDOWS)
  2208.     global void* SP_start;  # SP bei Programmstart
  2209.   #endif
  2210.  
  2211. # Bei ▄berlauf eines der Stacks:
  2212.   nonreturning_function(global, SP_ueber, (void));
  2213.   global void SP_ueber()
  2214.     { asciz_out( DEUTSCH ? CRLFstring "*** - " "Programmstack-▄berlauf: RESET" :
  2215.                  ENGLISH ? CRLFstring "*** - " "Program stack overflow. RESET" :
  2216.                  FRANCAIS ? CRLFstring "*** - " "DΘbordement de pile de programme : RAZ" :
  2217.                  ""
  2218.                );
  2219.       reset();
  2220.     }
  2221.   nonreturning_function(global, STACK_ueber, (void));
  2222.   global void STACK_ueber()
  2223.     { asciz_out( DEUTSCH ? CRLFstring "*** - " "LISP-Stack-▄berlauf: RESET" :
  2224.                  ENGLISH ? CRLFstring "*** - " "Lisp stack overflow. RESET" :
  2225.                  FRANCAIS ? CRLFstring "*** - " "DΘbordement de pile Lisp : RAZ" :
  2226.                  ""
  2227.                );
  2228.       reset();
  2229.     }
  2230.  
  2231. # ▄berprⁿfung des Speicherinhalts auf GC-Festigkeit:
  2232.   #if defined(SPVW_PAGES) && defined(DEBUG_SPVW)
  2233.     # ▄berprⁿfen, ob die Verwaltung der Pages in Ordnung ist:
  2234.       #define CHECK_AVL_CONSISTENCY()  check_avl_consistency()
  2235.       local void check_avl_consistency (void);
  2236.       local void check_avl_consistency()
  2237.         { var reg4 uintL heapnr;
  2238.           for (heapnr=0; heapnr<heapcount; heapnr++)
  2239.             { AVL(AVLID,check) (mem.heaps[heapnr].inuse); }
  2240.         }
  2241.     # ▄berprⁿfen, ob die Grenzen der Pages in Ordnung sind:
  2242.       #define CHECK_GC_CONSISTENCY()  check_gc_consistency()
  2243.       local void check_gc_consistency (void);
  2244.       local void check_gc_consistency()
  2245.         { for_each_page(page,
  2246.             if ((sintL)page->page_room < 0)
  2247.               { asciz_out("\nPage bei Adresse 0x"); hex_out(page); asciz_out(" ⁿbergelaufen!!\n"); abort(); }
  2248.             if (!(page->page_start == page_start0(page)))
  2249.               { asciz_out("\nPage bei Adresse 0x"); hex_out(page); asciz_out(" inkonsistent!!\n"); abort(); }
  2250.             if (!(page->page_end + page->page_room
  2251.                   == round_down(page->m_start + page->m_length,Varobject_alignment)
  2252.                ) )
  2253.               { asciz_out("\nPage bei Adresse 0x"); hex_out(page); asciz_out(" inkonsistent!!\n"); abort(); }
  2254.             );
  2255.         }
  2256.     # ▄berprⁿfen, ob wΣhrend der kompaktierenden GC
  2257.     # die Grenzen der Pages in Ordnung sind:
  2258.       #define CHECK_GC_CONSISTENCY_2()  check_gc_consistency_2()
  2259.       local void check_gc_consistency_2 (void);
  2260.       local void check_gc_consistency_2()
  2261.         { for_each_page(page,
  2262.             if ((sintL)page->page_room < 0)
  2263.               { asciz_out("\nPage bei Adresse 0x"); hex_out(page); asciz_out(" ⁿbergelaufen!!\n"); abort(); }
  2264.             if (!(page->page_end + page->page_room - (page->page_start - page_start0(page))
  2265.                   == round_down(page->m_start + page->m_length,Varobject_alignment)
  2266.                ) )
  2267.               { asciz_out("\nPage bei Adresse 0x"); hex_out(page); asciz_out(" inkonsistent!!\n"); abort(); }
  2268.             );
  2269.         }
  2270.   #else
  2271.     #define CHECK_AVL_CONSISTENCY()
  2272.     #define CHECK_GC_CONSISTENCY()
  2273.     #define CHECK_GC_CONSISTENCY_2()
  2274.   #endif
  2275.   #ifdef DEBUG_SPVW
  2276.     # ▄berprⁿfen, ob die Tabellen der Packages halbwegs in Ordnung sind:
  2277.       #define CHECK_PACK_CONSISTENCY()  check_pack_consistency()
  2278.       global void check_pack_consistency (void);
  2279.       global void check_pack_consistency()
  2280.         { var reg9 object plist = O(all_packages);
  2281.           while (consp(plist))
  2282.             { var reg8 object pack = Car(plist);
  2283.               var object symtabs[2];
  2284.               var uintC i;
  2285.               symtabs[0] = ThePackage(pack)->pack_external_symbols;
  2286.               symtabs[1] = ThePackage(pack)->pack_internal_symbols;
  2287.               for (i = 0; i < 2; i++)
  2288.                 { var reg6 object symtab = symtabs[i];
  2289.                   var reg4 object table = TheSvector(symtab)->data[1];
  2290.                   var reg3 uintL index = TheSvector(table)->length;
  2291.                   until (index==0)
  2292.                     { var reg1 object entry = TheSvector(table)->data[--index];
  2293.                       var reg2 uintC count = 0;
  2294.                       while (consp(entry))
  2295.                         { if (!msymbolp(Car(entry))) abort();
  2296.                           entry = Cdr(entry);
  2297.                           count++; if (count>=10000) abort();
  2298.                 }   }   }
  2299.               plist = Cdr(plist);
  2300.         }   }
  2301.   #else
  2302.       #define CHECK_PACK_CONSISTENCY()
  2303.   #endif
  2304.  
  2305. # ------------------------------------------------------------------------------
  2306. #                       Speichergr÷▀e
  2307.  
  2308. # Liefert die Gr÷▀e des von den LISP-Objekten belegten Platzes.
  2309.   global uintL used_space (void);
  2310.   #ifdef SPVW_BLOCKS
  2311.    #ifdef SPVW_MIXED_BLOCKS_OPPOSITE
  2312.     #define Heap_used_space(h)  ((uintL)((h).end - (h).start))
  2313.     global uintL used_space()
  2314.       { return Heap_used_space(mem.objects) # Platz fⁿr Objekte variabler LΣnge
  2315.                + Heap_used_space(mem.conses); # Platz fⁿr Conses
  2316.       }
  2317.    #else
  2318.     global uintL used_space()
  2319.       { var reg4 uintL sum = 0;
  2320.         #if !defined(GENERATIONAL_GC)
  2321.           for_each_page(page, { sum += page->page_end - page->page_start; } );
  2322.         #else # defined(GENERATIONAL_GC)
  2323.           for_each_heap(heap,
  2324.             { sum += (heap->heap_gen0_end - heap->heap_gen0_start)
  2325.                      + (heap->heap_end - heap->heap_gen1_start);
  2326.             });
  2327.         #endif
  2328.         return sum;
  2329.       }
  2330.    #endif
  2331.   #endif
  2332.   #ifdef SPVW_PAGES
  2333.     #if 0
  2334.     global uintL used_space()
  2335.       { var reg4 uintL sum = 0;
  2336.         for_each_page(page, { sum += page->page_end - page->page_start; } );
  2337.         return sum;
  2338.       }
  2339.     #else
  2340.     # Da die Berechnung von used_space() auf jede Page einmal zugreift, was
  2341.     # viel Paging bedeuten kann, wird das Ergebnis in mem.used_space gerettet.
  2342.     global uintL used_space()
  2343.       { return mem.used_space; }
  2344.     #endif
  2345.   #endif
  2346.  
  2347. # Liefert die Gr÷▀e des fⁿr LISP-Objekte noch verfⁿgbaren Platzes.
  2348.   global uintL free_space (void);
  2349.   #ifdef SPVW_BLOCKS
  2350.    #ifdef SPVW_MIXED_BLOCKS_OPPOSITE
  2351.     global uintL free_space()
  2352.       { return (mem.conses.start-mem.objects.end); } # Platz in der gro▀en Lⁿcke
  2353.    #else
  2354.     global uintL free_space()
  2355.       { return mem.total_room; } # Platz, der bis zur nΣchsten GC verbraucht werden darf
  2356.    #endif
  2357.   #endif
  2358.   #ifdef SPVW_PAGES
  2359.     #if 0
  2360.     global uintL free_space()
  2361.       { var reg4 uintL sum = 0;
  2362.         for_each_page(page, { sum += page->page_room; } );
  2363.         return sum;
  2364.       }
  2365.     #else
  2366.     # Da die Berechnung von free_space() auf jede Page einmal zugreift, was
  2367.     # viel Paging bedeuten kann, wird das Ergebnis mit Hilfe von mem.used_space
  2368.     # berechnet.
  2369.     global uintL free_space()
  2370.       { return mem.total_space - mem.used_space; }
  2371.     #endif
  2372.   #endif
  2373.  
  2374. #ifdef SPVW_PAGES
  2375.   # Berechnet mem.used_space und mem.total_space neu.
  2376.   # Das check-Flag gibt an, ob dabei mem.used_space gleich bleiben mu▀.
  2377.   local void recalc_space (boolean check);
  2378.   local void recalc_space(check)
  2379.     var reg6 boolean check;
  2380.     { var reg4 uintL sum_used = 0;
  2381.       var reg5 uintL sum_free = 0;
  2382.       for_each_page(page,
  2383.                     { sum_used += page->page_end - page->page_start;
  2384.                       sum_free += page->page_room;
  2385.                     }
  2386.                    );
  2387.       if (check)
  2388.         { if (!(mem.used_space == sum_used)) abort(); }
  2389.         else
  2390.         { mem.used_space = sum_used; }
  2391.       mem.total_space = sum_used + sum_free;
  2392.     }
  2393. #endif
  2394.  
  2395. # ------------------------------------------------------------------------------
  2396. #                   SpeicherlΣngenbestimmung
  2397.  
  2398. # Bei allen Objekten variabler LΣnge (die von links nach rechts wachsen)
  2399. # steht (au▀er wΣhrend der GC) in den ersten 4 Bytes ein Pointer auf sich
  2400. # selbst, bei Symbolen auch noch die Flags.
  2401.  
  2402. # Liefert den Typcode eines Objekts variabler LΣnge an einer gegebenen Adresse:
  2403.   #define typecode_at(addr)  mtypecode(((Varobject)(addr))->GCself)
  2404.   # oder (Σquivalent):
  2405.   # define typecode_at(addr)  (((((Varobject)(addr))->header_flags)>>(oint_type_shift%8))&tint_type_mask)
  2406. # Fallunterscheidungen nach diesem mⁿssen statt 'case_symbol:' ein
  2407. # 'case_symbolwithflags:' enthalten.
  2408.   #define case_symbolwithflags  \
  2409.     case symbol_type:                                        \
  2410.     case symbol_type|bit(constant_bit_t):                    \
  2411.     case symbol_type|bit(keyword_bit_t)|bit(constant_bit_t): \
  2412.     case symbol_type|bit(special_bit_t):                     \
  2413.     case symbol_type|bit(special_bit_t)|bit(constant_bit_t): \
  2414.     case symbol_type|bit(special_bit_t)|bit(keyword_bit_t)|bit(constant_bit_t)
  2415.  
  2416. # UP, bestimmt die LΣnge eines LISP-Objektes variabler LΣnge (in Bytes).
  2417. # (Sie ist durch Varobject_alignment teilbar.)
  2418.   local uintL speicher_laenge (void* addr);
  2419.   # Varobject_aligned_size(HS,ES,C) liefert die LΣnge eines Objekts variabler
  2420.   # LΣnge mit HS=Header-Size, ES=Element-Size, C=Element-Count.
  2421.   # Varobject_aligned_size(HS,ES,C) = round_up(HS+ES*C,Varobject_alignment) .
  2422.     #define Varobject_aligned_size(HS,ES,C)  \
  2423.       ((ES % Varobject_alignment) == 0               \
  2424.        ? # ES ist durch Varobject_alignment teilbar  \
  2425.          round_up(HS,Varobject_alignment) + (ES)*(C) \
  2426.        : round_up((HS)+(ES)*(C),Varobject_alignment) \
  2427.       )
  2428.   # LΣnge eines Objekts, je nach Typ:
  2429.     #define size_symbol()  # Symbol \
  2430.       round_up( sizeof(symbol_), Varobject_alignment)
  2431.     #define size_sbvector(length)  # simple-bit-vector \
  2432.       ( ceiling( (uintL)(length) + 8*offsetofa(sbvector_,data), 8*Varobject_alignment ) \
  2433.         * Varobject_alignment                                                           \
  2434.       )
  2435.     #define size_sstring(length)  # simple-string \
  2436.       round_up( (uintL)(length) + offsetofa(sstring_,data), Varobject_alignment)
  2437.     #define size_svector(length)  # simple-vector \
  2438.       Varobject_aligned_size(offsetofa(svector_,data),sizeof(object),(uintL)(length))
  2439.     #define size_array(size)  # Nicht-simpler Array, mit \
  2440.       # size = Dimensionszahl + (1 falls Fill-Pointer) + (1 falls Displaced-Offset) \
  2441.       Varobject_aligned_size(offsetofa(array_,dims),sizeof(uintL),(uintL)(size))
  2442.     #define size_record(length)  # Record \
  2443.       Varobject_aligned_size(offsetofa(record_,recdata),sizeof(object),(uintL)(length))
  2444.     #define size_bignum(length)  # Bignum \
  2445.       Varobject_aligned_size(offsetofa(bignum_,data),sizeof(uintD),(uintL)(length))
  2446.     #ifndef WIDE
  2447.     #define size_ffloat()  # Single-Float \
  2448.       round_up( sizeof(ffloat_), Varobject_alignment)
  2449.     #endif
  2450.     #define size_dfloat()  # Double-Float \
  2451.       round_up( sizeof(dfloat_), Varobject_alignment)
  2452.     #define size_lfloat(length)  # Long-Float \
  2453.       Varobject_aligned_size(offsetofa(lfloat_,data),sizeof(uintD),(uintL)(length))
  2454.  
  2455. #ifdef SPVW_MIXED
  2456.  
  2457.   local uintL speicher_laenge (addr)
  2458.     var reg2 void* addr;
  2459.     { switch (typecode_at(addr) & ~bit(garcol_bit_t)) # Typ des Objekts
  2460.         { case_symbolwithflags: # Symbol
  2461.             return size_symbol();
  2462.           case_sbvector: # simple-bit-vector
  2463.             return size_sbvector(((Sbvector)addr)->length);
  2464.           case_sstring: # simple-string
  2465.             return size_sstring(((Sstring)addr)->length);
  2466.           case_svector: # simple-vector
  2467.             return size_svector(((Svector)addr)->length);
  2468.           case_array1: case_obvector: case_ostring: case_ovector:
  2469.             # Nicht-simpler Array:
  2470.             { var reg2 uintL size;
  2471.               size = (uintL)(((Array)addr)->rank);
  2472.               if (((Array)addr)->flags & bit(arrayflags_fillp_bit)) { size += 1; }
  2473.               if (((Array)addr)->flags & bit(arrayflags_dispoffset_bit)) { size += 1; }
  2474.               # size = Dimensionszahl + (1 falls Fill-Pointer) + (1 falls Displaced-Offset)
  2475.               return size_array(size);
  2476.             }
  2477.           case_record: # Record
  2478.             return size_record(((Record)addr)->reclength);
  2479.           case_bignum: # Bignum
  2480.             return size_bignum(((Bignum)addr)->length);
  2481.           #ifndef WIDE
  2482.           case_ffloat: # Single-Float
  2483.             return size_ffloat();
  2484.           #endif
  2485.           case_dfloat: # Double-Float
  2486.             return size_dfloat();
  2487.           case_lfloat: # Long-Float
  2488.             return size_lfloat(((Lfloat)addr)->len);
  2489.           case_machine:
  2490.           case_char:
  2491.           case_subr:
  2492.           case_system:
  2493.           case_fixnum:
  2494.           case_sfloat:
  2495.           #ifdef WIDE
  2496.           case_ffloat:
  2497.           #endif
  2498.             # Das sind direkte Objekte, keine Pointer.
  2499.           /* case_ratio: */
  2500.           /* case_complex: */
  2501.           default:
  2502.             # Das sind keine Objekte variabler LΣnge.
  2503.             /*NOTREACHED*/ abort();
  2504.     }   }
  2505.  
  2506.   #define var_speicher_laenge_
  2507.   #define calc_speicher_laenge(addr)  speicher_laenge((void*)(addr))
  2508.  
  2509. #endif # SPVW_MIXED
  2510.  
  2511. #ifdef SPVW_PURE
  2512.  
  2513.   # spezielle Funktionen fⁿr jeden Typ:
  2514.   inline local uintL speicher_laenge_symbol (addr) # Symbol
  2515.     var reg1 void* addr;
  2516.     { return size_symbol(); }
  2517.   inline local uintL speicher_laenge_sbvector (addr) # simple-bit-vector
  2518.     var reg1 void* addr;
  2519.     { return size_sbvector(((Sbvector)addr)->length); }
  2520.   inline local uintL speicher_laenge_sstring (addr) # simple-string
  2521.     var reg1 void* addr;
  2522.     { return size_sstring(((Sstring)addr)->length); }
  2523.   inline local uintL speicher_laenge_svector (addr) # simple-vector
  2524.     var reg1 void* addr;
  2525.     { return size_svector(((Svector)addr)->length); }
  2526.   inline local uintL speicher_laenge_array (addr) # nicht-simpler Array
  2527.     var reg1 void* addr;
  2528.     { var reg2 uintL size;
  2529.       size = (uintL)(((Array)addr)->rank);
  2530.       if (((Array)addr)->flags & bit(arrayflags_fillp_bit)) { size += 1; }
  2531.       if (((Array)addr)->flags & bit(arrayflags_dispoffset_bit)) { size += 1; }
  2532.       # size = Dimensionszahl + (1 falls Fill-Pointer) + (1 falls Displaced-Offset)
  2533.       return size_array(size);
  2534.     }
  2535.   inline local uintL speicher_laenge_record (addr) # Record
  2536.     var reg1 void* addr;
  2537.     { return size_record(((Record)addr)->reclength); }
  2538.   inline local uintL speicher_laenge_bignum (addr) # Bignum
  2539.     var reg1 void* addr;
  2540.     { return size_bignum(((Bignum)addr)->length); }
  2541.   #ifndef WIDE
  2542.   inline local uintL speicher_laenge_ffloat (addr) # Single-Float
  2543.     var reg1 void* addr;
  2544.     { return size_ffloat(); }
  2545.   #endif
  2546.   inline local uintL speicher_laenge_dfloat (addr) # Double-Float
  2547.     var reg1 void* addr;
  2548.     { return size_dfloat(); }
  2549.   inline local uintL speicher_laenge_lfloat (addr) # Long-Float
  2550.     var reg1 void* addr;
  2551.     { return size_lfloat(((Lfloat)addr)->len); }
  2552.  
  2553.   # Tabelle von Funktionen:
  2554.   typedef uintL (*speicher_laengen_fun) (void* addr);
  2555.   local speicher_laengen_fun speicher_laengen[heapcount];
  2556.  
  2557.   local void init_speicher_laengen (void);
  2558.   local void init_speicher_laengen()
  2559.     { var reg1 uintL heapnr;
  2560.       for (heapnr=0; heapnr<heapcount; heapnr++)
  2561.         { switch (heapnr)
  2562.             { case_symbol:
  2563.                 speicher_laengen[heapnr] = &speicher_laenge_symbol; break;
  2564.               case_sbvector:
  2565.                 speicher_laengen[heapnr] = &speicher_laenge_sbvector; break;
  2566.               case_sstring:
  2567.                 speicher_laengen[heapnr] = &speicher_laenge_sstring; break;
  2568.               case_svector:
  2569.                 speicher_laengen[heapnr] = &speicher_laenge_svector; break;
  2570.               case_array1: case_obvector: case_ostring: case_ovector:
  2571.                 speicher_laengen[heapnr] = &speicher_laenge_array; break;
  2572.               case_record:
  2573.                 speicher_laengen[heapnr] = &speicher_laenge_record; break;
  2574.               case_bignum:
  2575.                 speicher_laengen[heapnr] = &speicher_laenge_bignum; break;
  2576.               #ifndef WIDE
  2577.               case_ffloat:
  2578.                 speicher_laengen[heapnr] = &speicher_laenge_ffloat; break;
  2579.               #endif
  2580.               case_dfloat:
  2581.                 speicher_laengen[heapnr] = &speicher_laenge_dfloat; break;
  2582.               case_lfloat:
  2583.                 speicher_laengen[heapnr] = &speicher_laenge_lfloat; break;
  2584.               case_machine:
  2585.               case_char:
  2586.               case_subr:
  2587.               case_system:
  2588.               case_fixnum:
  2589.               case_sfloat:
  2590.               #ifdef WIDE
  2591.               case_ffloat:
  2592.               #endif
  2593.                 # Das sind direkte Objekte, keine Pointer.
  2594.               /* case_ratio: */
  2595.               /* case_complex: */
  2596.               default:
  2597.                 # Das sind keine Objekte variabler LΣnge.
  2598.                 speicher_laengen[heapnr] = (speicher_laengen_fun)&abort; break;
  2599.     }   }   }
  2600.  
  2601.   #define var_speicher_laenge_  \
  2602.     var reg5 speicher_laengen_fun speicher_laenge_ = speicher_laengen[heapnr];
  2603.   #define calc_speicher_laenge(addr)  (*speicher_laenge_)((void*)(addr))
  2604.  
  2605. #endif # SPVW_PURE
  2606.  
  2607. # ------------------------------------------------------------------------------
  2608. #            Hilfsfunktion fⁿr den Generational Garbage-Collector
  2609.  
  2610. #ifdef GENERATIONAL_GC # impliziert SPVW_PURE_BLOCKS <==> SINGLEMAP_MEMORY
  2611.                        # oder       SPVW_MIXED_BLOCKS und TRIVIALMAP_MEMORY
  2612.  
  2613. local /* uintL */ aint physpagesize;  # = map_pagesize
  2614. local uintL physpageshift; # 2^physpageshift = physpagesize
  2615.  
  2616. local boolean handle_fault (aint address);
  2617. local boolean handle_fault(address)
  2618.   var reg6 aint address;
  2619.   { var reg5 uintL heapnr;
  2620.     #ifdef SPVW_PURE_BLOCKS
  2621.     heapnr = typecode((object)((oint)address << oint_addr_shift));
  2622.     #else
  2623.     heapnr = (address >= mem.heaps[1].heap_gen0_start ? 1 : 0);
  2624.     #endif
  2625.     if (!is_heap_containing_objects(heapnr)) goto error1;
  2626.     {var reg4 Heap* heap = &mem.heaps[heapnr];
  2627.      if (!((heap->heap_gen0_start <= address) && (address < heap->heap_gen0_end)))
  2628.        goto error2;
  2629.      if (heap->physpages == NULL)
  2630.        goto error3;
  2631.      {var reg3 physpage_state* physpage =
  2632.         &heap->physpages[(address>>physpageshift)-(heap->heap_gen0_start>>physpageshift)];
  2633.       switch (physpage->protection)
  2634.         { case PROT_NONE:
  2635.             # protection: PROT_NONE -> PROT_READ
  2636.             # Seite auf den Stand des Cache bringen:
  2637.             { var reg2 uintL count = physpage->cache_size;
  2638.               if (count > 0)
  2639.                 { var reg1 old_new_pointer* ptr = physpage->cache;
  2640.                   if (mprotect((MMAP_ADDR_T)(address & -physpagesize), physpagesize, PROT_READ_WRITE) < 0)
  2641.                     goto error4;
  2642.                   dotimespL(count,count, { *(ptr->p) = ptr->o; ptr++; } );
  2643.             }   }
  2644.             # Seite read-only einblenden:
  2645.             if (mprotect((MMAP_ADDR_T)(address & -physpagesize), physpagesize, PROT_READ) < 0)
  2646.               goto error5;
  2647.             physpage->protection = PROT_READ;
  2648.             return TRUE;
  2649.           case PROT_READ:
  2650.             # protection: PROT_READ -> PROT_READ_WRITE
  2651.             # Seite read-write einblenden:
  2652.             if (mprotect((MMAP_ADDR_T)(address & -physpagesize), physpagesize, PROT_READ_WRITE) < 0)
  2653.               goto error6;
  2654.             physpage->protection = PROT_READ_WRITE;
  2655.             return TRUE;
  2656.           default:
  2657.             goto error7;
  2658.         }
  2659.       error4:
  2660.         { var int saved_errno = errno;
  2661.           asciz_out(CRLFstring "handle_fault error4 ! mprotect(0x");
  2662.           hex_out(address & -physpagesize); asciz_out(",0x");
  2663.           hex_out(physpagesize); asciz_out(","); dez_out(PROT_READ_WRITE);
  2664.           asciz_out(") -> "); errno_out(saved_errno);
  2665.         }
  2666.         goto error;
  2667.       error5:
  2668.         { var int saved_errno = errno;
  2669.           asciz_out(CRLFstring "handle_fault error5 ! mprotect(0x");
  2670.           hex_out(address & -physpagesize); asciz_out(",0x");
  2671.           hex_out(physpagesize); asciz_out(","); dez_out(PROT_READ);
  2672.           asciz_out(") -> "); errno_out(saved_errno);
  2673.         }
  2674.         goto error;
  2675.       error6:
  2676.         { var int saved_errno = errno;
  2677.           asciz_out(CRLFstring "handle_fault error6 ! mprotect(0x");
  2678.           hex_out(address & -physpagesize); asciz_out(",0x");
  2679.           hex_out(physpagesize); asciz_out(","); dez_out(PROT_READ_WRITE);
  2680.           asciz_out(") -> "); errno_out(saved_errno);
  2681.         }
  2682.         goto error;
  2683.       error7:
  2684.         asciz_out(CRLFstring "handle_fault error7 ! protection = ");
  2685.         dez_out(physpage->protection);
  2686.         goto error;
  2687.      }
  2688.      error2:
  2689.        asciz_out(CRLFstring "handle_fault error2 ! address = 0x");
  2690.        hex_out(address); asciz_out(" not in [0x");
  2691.        hex_out(heap->heap_gen0_start); asciz_out(",0x");
  2692.        hex_out(heap->heap_gen0_end); asciz_out(") !");
  2693.        goto error;
  2694.      error3:
  2695.        asciz_out(CRLFstring "handle_fault error3 !");
  2696.        goto error;
  2697.     }
  2698.     error1:
  2699.       asciz_out(CRLFstring "handle_fault error1 !");
  2700.       goto error;
  2701.     error:
  2702.     return FALSE;
  2703.   }
  2704.  
  2705. #ifdef SPVW_MIXED_BLOCKS
  2706. # Systemaufrufe wie read() und write() melden kein SIGSEGV, sondern EFAULT.
  2707. # handle_fault_range(PROT_READ,start,end) macht einen Adre▀bereich lesbar,
  2708. # handle_fault_range(PROT_READ_WRITE,start,end) macht ihn schreibbar.
  2709. global boolean handle_fault_range (int prot, aint start_address, aint end_address);
  2710. global boolean handle_fault_range(prot,start_address,end_address)
  2711.   var reg5 int prot;
  2712.   var reg8 aint start_address;
  2713.   var reg7 aint end_address;
  2714.   { if (!(start_address < end_address)) { return TRUE; }
  2715.    {var reg6 Heap* heap = &mem.heaps[0]; # varobject_heap
  2716.     var reg4 aint address;
  2717.     for (address = start_address & -physpagesize; address < end_address; address += physpagesize)
  2718.       if ((heap->heap_gen0_start <= address) && (address < heap->heap_gen0_end))
  2719.         { if (heap->physpages == NULL) { return FALSE; }
  2720.          {var reg3 physpage_state* physpage =
  2721.             &heap->physpages[(address>>physpageshift)-(heap->heap_gen0_start>>physpageshift)];
  2722.           if (!(physpage->protection & PROT_READ) && (prot & PROT_READ_WRITE))
  2723.             # protection: PROT_NONE -> PROT_READ
  2724.             { # Seite auf den Stand des Cache bringen:
  2725.               { var reg2 uintL count = physpage->cache_size;
  2726.                 if (count > 0)
  2727.                   { var reg1 old_new_pointer* ptr = physpage->cache;
  2728.                     if (mprotect((MMAP_ADDR_T)address, physpagesize, PROT_READ_WRITE) < 0)
  2729.                       { return FALSE; }
  2730.                     dotimespL(count,count, { *(ptr->p) = ptr->o; ptr++; } );
  2731.               }   }
  2732.               # Seite read-only einblenden:
  2733.               if (mprotect((MMAP_ADDR_T)address, physpagesize, PROT_READ) < 0)
  2734.                 { return FALSE; }
  2735.               physpage->protection = PROT_READ;
  2736.             }
  2737.           if (!(physpage->protection & PROT_WRITE) && (prot & PROT_WRITE))
  2738.             # protection: PROT_READ -> PROT_READ_WRITE
  2739.             { # Seite read-write einblenden:
  2740.               if (mprotect((MMAP_ADDR_T)address, physpagesize, PROT_READ_WRITE) < 0)
  2741.                 { return FALSE; }
  2742.               physpage->protection = PROT_READ_WRITE;
  2743.             }
  2744.         }}
  2745.     return TRUE;
  2746.   }}
  2747. #endif
  2748.  
  2749. # mprotect() mit Ausstieg im Falle des Scheiterns
  2750. local void xmprotect (aint addr, uintL len, int prot);
  2751. local void xmprotect(addr,len,prot)
  2752.   var reg1 aint addr;
  2753.   var reg2 uintL len;
  2754.   var reg3 int prot;
  2755.   { if (mprotect((MMAP_ADDR_T)addr,len,prot) < 0)
  2756.       { asciz_out(DEUTSCH ? "mprotect() klappt nicht." :
  2757.                   ENGLISH ? "mprotect() fails." :
  2758.                   FRANCAIS ? "mprotect() ne fonctionne pas." :
  2759.                   ""
  2760.                  );
  2761.         errno_out(errno);
  2762.         abort();
  2763.   }   }
  2764.  
  2765. # Versionen von malloc() und realloc(), bei denen der Input auch = NULL sein darf:
  2766.   #define xfree(ptr)  \
  2767.     if (!((ptr)==NULL)) free(ptr);
  2768.   #define xrealloc(ptr,size)  \
  2769.     (((ptr)==NULL) ? (void*)malloc(size) : (void*)realloc(ptr,size))
  2770.  
  2771. #endif # GENERATIONAL_GC
  2772.  
  2773. # ------------------------------------------------------------------------------
  2774. #                       Garbage-Collector
  2775.  
  2776. # Gesamtstrategie:
  2777. # 1. Pseudorekursives Markieren durch Setzen von garcol_bit.
  2778. # 2. Verschieben der Objekte fester LΣnge (Conses u.Σ.),
  2779. #    Durchrechnen der Verschiebungen der Objekte variabler LΣnge.
  2780. # 3. Aktualisieren der Pointer.
  2781. # 4. Durchfⁿhren der Verschiebungen der Objekte variabler LΣnge.
  2782.  
  2783. #ifdef GENERATIONAL_GC
  2784.   # Alte Generation mit Hilfe des Cache auf den aktuellen Stand bringen:
  2785.   local void prepare_old_generation (void);
  2786.   local void prepare_old_generation()
  2787.     { var reg8 uintL heapnr;
  2788.       for (heapnr=0; heapnr<heapcount; heapnr++)
  2789.         if (is_heap_containing_objects(heapnr))
  2790.           { var reg7 Heap* heap = &mem.heaps[heapnr];
  2791.             var reg5 aint gen0_start = heap->heap_gen0_start;
  2792.             var reg6 aint gen0_end = heap->heap_gen0_end;
  2793.             gen0_end = (gen0_end + (physpagesize-1)) & -physpagesize;
  2794.             if (gen0_start < gen0_end)
  2795.               { if (!(heap->physpages==NULL))
  2796.                   { # Erst read-write einblenden:
  2797.                     xmprotect(gen0_start, gen0_end-gen0_start, PROT_READ_WRITE);
  2798.                     # Dann den Cache entleeren:
  2799.                     {var reg3 physpage_state* physpage = heap->physpages;
  2800.                      var reg4 uintL physpagecount;
  2801.                      dotimespL(physpagecount, (gen0_end-gen0_start) >> physpageshift,
  2802.                        { if (physpage->protection == PROT_NONE)
  2803.                            { var reg2 uintL count = physpage->cache_size;
  2804.                              if (count > 0)
  2805.                                { var reg1 old_new_pointer* ptr = physpage->cache;
  2806.                                  dotimespL(count,count, { *(ptr->p) = ptr->o; ptr++; } );
  2807.                            }   }
  2808.                          physpage->protection = PROT_READ_WRITE;
  2809.                          xfree(physpage->cache); physpage->cache = NULL;
  2810.                          physpage++;
  2811.                        });
  2812.                      /* xfree(heap->physpages); heap->physpages = NULL; */
  2813.                   } }
  2814.                 # Dann die Lⁿcke zwischen der alten und der neuen Generation so
  2815.                 # fⁿllen, da▀ die Kompaktierungs-Algorithmen funktionieren:
  2816.                 if (is_cons_heap(heapnr))
  2817.                   { var reg1 object* ptr = (object*) heap->heap_gen0_end;
  2818.                     var reg2 uintL count = (heap->heap_gen1_start - heap->heap_gen0_end)/sizeof(object);
  2819.                     dotimesL(count,count, { *ptr++ = nullobj; } );
  2820.                   }
  2821.               }
  2822.     }     }
  2823. #endif
  2824.  
  2825. # Test, ob ein Objekt obj in der gerade ignorierten Generation liegt.
  2826. # in_old_generation(obj,type,heapnr)
  2827. # > obj: Objekt mit !immediate_type_p(type = typecode(obj))
  2828. # > heapnr: 0 bei Objekt variabler LΣnge, 1 bei Cons o.Σ.
  2829. # < TRUE falls man eine "kleine" Generational GC durchfⁿhrt und
  2830. #   obj in der alten Generation liegt.
  2831. # Vorsicht bei Symbolen: Ist obj eines der konstanten Symbole, so ist das
  2832. # Ergebnis nicht spezifiziert!
  2833. #ifdef GENERATIONAL_GC
  2834.   #ifdef SPVW_PURE_BLOCKS
  2835.     #define in_old_generation(obj,type,heapnr)  \
  2836.       ((aint)ThePointer(obj) < mem.heaps[type].heap_start)
  2837.   #else # SPVW_MIXED_BLOCKS
  2838.     #define in_old_generation(obj,type,heapnr)  \
  2839.       ((aint)ThePointer(obj) < mem.heaps[heapnr].heap_start)
  2840.   #endif
  2841. #else
  2842.   #define in_old_generation(obj,type,heapnr)  FALSE
  2843. #endif
  2844.  
  2845. # Markierungs-Unterprogramm
  2846.   # Verfahren: Markierungsroutine ohne Stackbenutzung (d.h.
  2847.   #  nicht "rekursiv") durch Abstieg in die zu markierende
  2848.   #  Struktur mit Pointermodifikation (Pointer werden umgedreht,
  2849.   #  damit sie als "Ariadnefaden" zurⁿck dienen k÷nnen)
  2850.   # Konvention: ein Objekt X gilt als markiert, wenn
  2851.   #  - ein Objekt variabler LΣnge: Bit garcol_bit,(X) gesetzt
  2852.   #  - ein Zwei-Pointer-Objekt: Bit garcol_bit,(X) gesetzt
  2853.   #  - ein SUBR/FSUBR: Bit garcol_bit,(X+const_offset) gesetzt
  2854.   #  - Character, Short-Float, Fixnum etc.: stets.
  2855.   local void gc_mark (object obj);
  2856.   # Markierungsbit an einer Adresse setzen: mark(addr);
  2857.     #define mark(addr)  *(oint*)(addr) |= wbit(garcol_bit_o)
  2858.   # Markierungsbit an einer Adresse setzen: unmark(addr);
  2859.     #define unmark(addr)  *(oint*)(addr) &= ~wbit(garcol_bit_o)
  2860.   # Markierungsbit an einer Adresse abfragen: if (marked(addr)) ...
  2861.     #ifdef fast_mtypecode
  2862.       #define marked(addr)  (mtypecode(*(object*)(addr)) & bit(garcol_bit_t))
  2863.     #else
  2864.       #if !(garcol_bit_o == 32-1) || defined(WIDE)
  2865.         #define marked(addr)  (*(oint*)(addr) & wbit(garcol_bit_o))
  2866.       #else # garcol_bit_o = 32-1 = Vorzeichenbit
  2867.         #define marked(addr)  (*(sintL*)(addr) < 0)
  2868.       #endif
  2869.     #endif
  2870.   # Markierungsbit in einem Objekt setzen:
  2871.     #define with_mark_bit(obj)  as_object(as_oint(obj) | wbit(garcol_bit_o))
  2872.   # Markierungsbit in einem Objekt l÷schen:
  2873.     #define without_mark_bit(obj)  as_object(as_oint(obj) & ~wbit(garcol_bit_o))
  2874.   local void gc_mark (obj)
  2875.     var reg4 object obj;
  2876.     { var reg2 object dies = obj; # aktuelles Objekt
  2877.       var reg3 object vorg = nullobj; # VorgΣnger-Objekt
  2878.       down: # Einsprung fⁿr Abstieg.
  2879.             # dies = zu markierendes Objekt, vorg = sein VorgΣnger
  2880.             switch (typecode(dies))
  2881.               { case_cons:
  2882.                 case_ratio:
  2883.                 case_complex:
  2884.                   # Objekt mit genau 2 Pointern (Cons u.Σ.)
  2885.                   if (in_old_generation(dies,typecode(dies),1))
  2886.                     goto up; # Σltere Generation nicht markieren
  2887.                   { var reg1 oint* dies_ = (oint*)ThePointer(dies);
  2888.                     if (marked(dies_)) goto up; # markiert -> hoch
  2889.                     mark(dies_); # markieren
  2890.                   }
  2891.                   { var reg1 object dies_ = objectplus(dies,(soint)(sizeof(cons_)-sizeof(object))<<(oint_addr_shift-addr_shift));
  2892.                                           # mit dem letzten Pointer anfangen
  2893.                     var reg1 object nachf = *(object*)ThePointer(dies_); # Nachfolger
  2894.                     *(object*)ThePointer(dies_) = vorg; # VorgΣnger eintragen
  2895.                     vorg = dies_; # aktuelles Objekt wird neuer VorgΣnger
  2896.                     dies = nachf; # Nachfolger wird aktuelles Objekt
  2897.                     goto down; # und absteigen
  2898.                   }
  2899.                 case_symbol: # Symbol
  2900.                   if (in_old_generation(dies,typecode(dies),0))
  2901.                     goto up; # Σltere Generation (dazu zΣhlt auch die symbol_tab!) nicht markieren
  2902.                   { var reg1 oint* dies_ = (oint*)(TheSymbol(dies));
  2903.                     if (marked(dies_)) goto up; # markiert -> hoch
  2904.                     mark(dies_); # markieren
  2905.                     mark(pointerplus(dies_,symbol_objects_offset)); # ersten Pointer markieren
  2906.                   }
  2907.                   { var reg1 object dies_ = objectplus(dies,(soint)(sizeof(symbol_)-sizeof(object))<<(oint_addr_shift-addr_shift));
  2908.                                           # mit dem letzten Pointer anfangen
  2909.                     var reg1 object nachf = *(object*)(TheSymbol(dies_)); # Nachfolger
  2910.                     *(object*)(TheSymbol(dies_)) = vorg; # VorgΣnger eintragen
  2911.                     vorg = dies_; # aktuelles Objekt wird neuer VorgΣnger
  2912.                     dies = nachf; # Nachfolger wird aktuelles Objekt
  2913.                     goto down; # und absteigen
  2914.                   }
  2915.                 case_sbvector: # simple-bit-vector
  2916.                 case_sstring: # simple-string
  2917.                 case_bignum: # Bignum
  2918.                 #ifndef WIDE
  2919.                 case_ffloat: # Single-Float
  2920.                 #endif
  2921.                 case_dfloat: # Double-Float
  2922.                 case_lfloat: # Long-Float
  2923.                   # Objekte variabler LΣnge, die keine Pointer enthalten:
  2924.                   if (in_old_generation(dies,typecode(dies),0))
  2925.                     goto up; # Σltere Generation nicht markieren
  2926.                   mark(TheVarobject(dies)); # markieren
  2927.                   goto up; # und hoch
  2928.                 case_array1: case_obvector: case_ostring: case_ovector:
  2929.                   # Arrays, die nicht simple sind:
  2930.                   if (in_old_generation(dies,typecode(dies),0))
  2931.                     goto up; # Σltere Generation nicht markieren
  2932.                   { var reg1 oint* dies_ = (oint*)TheArray(dies);
  2933.                     if (marked(dies_)) goto up; # markiert -> hoch
  2934.                     mark(dies_); # markieren
  2935.                   }
  2936.                   { var reg1 object dies_ = objectplus(dies,(soint)(array_data_offset)<<(oint_addr_shift-addr_shift));
  2937.                                           # Datenvektor ist der erste und einzige Pointer
  2938.                     var reg1 object nachf = *(object*)TheArray(dies_); # Nachfolger
  2939.                     *(object*)TheArray(dies_) = vorg; # VorgΣnger eintragen
  2940.                     mark(TheArray(dies_)); # ersten und einzigen Pointer markieren
  2941.                     vorg = dies_; # aktuelles Objekt wird neuer VorgΣnger
  2942.                     dies = nachf; # Nachfolger wird aktuelles Objekt
  2943.                     goto down; # und absteigen
  2944.                   }
  2945.                 case_svector: # simple-vector
  2946.                   if (in_old_generation(dies,typecode(dies),0))
  2947.                     goto up; # Σltere Generation nicht markieren
  2948.                   { var reg1 oint* dies_ = (oint*)TheSvector(dies);
  2949.                     if (marked(dies_)) goto up; # markiert -> hoch
  2950.                     mark(dies_); # markieren
  2951.                   }
  2952.                   { var reg1 uintL len = TheSvector(dies)->length;
  2953.                     if (len==0) goto up; # LΣnge 0: wieder hoch
  2954.                    {var reg1 object dies_ = objectplus(dies,
  2955.                                               ((soint)offsetofa(svector_,data) << (oint_addr_shift-addr_shift))
  2956.                                               + (len * (soint)sizeof(object) << (oint_addr_shift-addr_shift))
  2957.                                               - ((soint)sizeof(object) << (oint_addr_shift-addr_shift)) );
  2958.                                               # mit dem letzten Pointer anfangen
  2959.                     var reg1 object nachf = *(object*)TheSvector(dies_); # Nachfolger
  2960.                     *(object*)TheSvector(dies_) = vorg; # VorgΣnger eintragen
  2961.                     mark(&TheSvector(dies)->data[0]); # ersten Pointer markieren
  2962.                     vorg = dies_; # aktuelles Objekt wird neuer VorgΣnger
  2963.                     dies = nachf; # Nachfolger wird aktuelles Objekt
  2964.                     goto down; # und absteigen
  2965.                   }}
  2966.                 case_record:
  2967.                   # Record:
  2968.                   if (in_old_generation(dies,typecode(dies),0))
  2969.                     goto up; # Σltere Generation nicht markieren
  2970.                   { var reg1 oint* dies_ = (oint*)TheRecord(dies);
  2971.                     if (marked(dies_)) goto up; # markiert -> hoch
  2972.                     mark(dies_); # markieren
  2973.                   }
  2974.                   { var reg1 uintL len = TheRecord(dies)->reclength;
  2975.                     # LΣnge stets >0
  2976.                     var reg1 object dies_ = objectplus(dies,
  2977.                                               ((soint)offsetofa(record_,recdata) << (oint_addr_shift-addr_shift))
  2978.                                             + (len * (soint)sizeof(object) << (oint_addr_shift-addr_shift))
  2979.                                             - ((soint)sizeof(object) << (oint_addr_shift-addr_shift)) );
  2980.                                             # mit dem letzten Pointer anfangen
  2981.                     var reg1 object nachf = *(object*)TheRecord(dies_); # Nachfolger
  2982.                     *(object*)TheRecord(dies_) = vorg; # VorgΣnger eintragen
  2983.                     mark(&TheRecord(dies)->recdata[0]); # ersten Pointer markieren
  2984.                     vorg = dies_; # aktuelles Objekt wird neuer VorgΣnger
  2985.                     dies = nachf; # Nachfolger wird aktuelles Objekt
  2986.                     goto down; # und absteigen
  2987.                   }
  2988.                 case_machine: # Maschinenadresse
  2989.                 case_char: # Character
  2990.                 case_system: # Frame-Pointer, Read-Label, System
  2991.                 case_fixnum: # Fixnum
  2992.                 case_sfloat: # Short-Float
  2993.                 #ifdef WIDE
  2994.                 case_ffloat: # Single-Float
  2995.                 #endif
  2996.                   # Das sind direkte Objekte, keine Pointer.
  2997.                   goto up;
  2998.                 case_subr: # SUBR
  2999.                   { var reg1 oint* dies_ = (oint*)pointerplus(TheSubr(dies),subr_const_offset);
  3000.                     if (marked(dies_)) goto up; # markiert -> hoch
  3001.                     # markieren spΣter
  3002.                   }
  3003.                   { var reg1 object dies_ = objectplus(dies,
  3004.                                               (soint)(subr_const_offset+(subr_const_anz-1)*sizeof(object))<<(oint_addr_shift-addr_shift));
  3005.                                               # mit dem letzten Pointer anfangen
  3006.                     var reg1 object nachf = *(object*)TheSubr(dies_); # Nachfolger
  3007.                     *(object*)TheSubr(dies_) = vorg; # VorgΣnger eintragen
  3008.                     # ersten Pointer (und damit das SUBR selbst) markieren:
  3009.                     mark(pointerplus(TheSubr(dies),subr_const_offset));
  3010.                     vorg = dies_; # aktuelles Objekt wird neuer VorgΣnger
  3011.                     dies = nachf; # Nachfolger wird aktuelles Objekt
  3012.                     goto down; # und absteigen
  3013.                   }
  3014.                 default:
  3015.                   # Das sind keine Objekte.
  3016.                   /*NOTREACHED*/ abort();
  3017.               }
  3018.       up:   # Einsprung zum Aufstieg.
  3019.             # dies = gerade markiertes Objekt, vorg = sein VorgΣnger
  3020.             if (eq(vorg,nullobj)) # Endekennzeichen erreicht?
  3021.               return; # ja -> fertig
  3022.             if (!marked(ThePointer(vorg))) # schon durch?
  3023.               # nein ->
  3024.               # nΣchstes Element weiter links (Komme von up, gehe nach down)
  3025.               # dies = gerade markiertes Objekt, in *vorg einzutragen
  3026.               { var reg3 object vorvorg = *(object*)ThePointer(vorg); # alter VorgΣnger
  3027.                 *(object*)ThePointer(vorg) = dies; # Komponente zurⁿckschreiben
  3028.                 vorg = objectplus(vorg,-(soint)(sizeof(object))<<(oint_addr_shift-addr_shift)); # zur nΣchsten Komponente
  3029.                 if (marked(ThePointer(vorg))) # dort schon markiert?
  3030.                   { dies = # nΣchste Komponente, ohne Markierung
  3031.                            without_mark_bit(*(object*)ThePointer(vorg));
  3032.                     *(object*)ThePointer(vorg) = # alten VorgΣnger weiterschieben, dabei Markierung erneuern
  3033.                            with_mark_bit(vorvorg);
  3034.                   }
  3035.                   else
  3036.                   { dies = *(object*)ThePointer(vorg); # nΣchste Komponente, ohne Markierung
  3037.                     *(object*)ThePointer(vorg) = vorvorg; # alten VorgΣnger weiterschieben
  3038.                   }
  3039.                 goto down;
  3040.               }
  3041.             # schon durch -> wieder aufsteigen
  3042.             { var reg3 object vorvorg = # alten VorgΣnger holen, ohne Markierungsbit
  3043.                                         without_mark_bit(*(object*)ThePointer(vorg));
  3044.               *(object*)ThePointer(vorg) = dies; # erste Komponente zurⁿckschreiben
  3045.               switch (typecode(vorg))
  3046.                 { case_cons:
  3047.                   case_ratio:
  3048.                   case_complex:
  3049.                     # Objekt mit genau 2 Pointern (Cons u.Σ.)
  3050.                     { mark(ThePointer(vorg)); # wieder markieren
  3051.                       dies = vorg; # Cons wird aktuelles Objekt
  3052.                       vorg = vorvorg; goto up; # weiter aufsteigen
  3053.                     }
  3054.                   case_symbol:
  3055.                     # Symbol
  3056.                     { dies = objectplus(vorg,-(soint)symbol_objects_offset<<(oint_addr_shift-addr_shift)); # Symbol wird aktuelles Objekt
  3057.                       vorg = vorvorg; goto up; # weiter aufsteigen
  3058.                     }
  3059.                   case_svector:
  3060.                     # simple-vector mit mindestens 1 Komponente
  3061.                     { dies = objectplus(vorg,-(soint)offsetofa(svector_,data)<<(oint_addr_shift-addr_shift)); # Svector wird aktuelles Objekt
  3062.                       vorg = vorvorg; goto up; # weiter aufsteigen
  3063.                     }
  3064.                   case_array1: case_obvector: case_ostring: case_ovector:
  3065.                     # Nicht-simple Arrays:
  3066.                     { dies = objectplus(vorg,-(soint)array_data_offset<<(oint_addr_shift-addr_shift)); # Array wird aktuelles Objekt
  3067.                       vorg = vorvorg; goto up; # weiter aufsteigen
  3068.                     }
  3069.                   case_record:
  3070.                     # Record:
  3071.                     { dies = objectplus(vorg,-(soint)offsetofa(record_,recdata)<<(oint_addr_shift-addr_shift)); # Record wird aktuelles Objekt
  3072.                       vorg = vorvorg; goto up; # weiter aufsteigen
  3073.                     }
  3074.                   case_subr: # SUBR
  3075.                     { mark(TheSubr(vorg)); # wieder markieren
  3076.                       dies = objectplus(vorg,-(soint)subr_const_offset<<(oint_addr_shift-addr_shift)); # SUBR wird aktuelles Objekt
  3077.                       vorg = vorvorg; goto up; # weiter aufsteigen
  3078.                     }
  3079.                   case_machine: # Maschinenadresse
  3080.                   case_char: # Character
  3081.                   case_system: # Frame-Pointer, Read-Label, System
  3082.                   case_fixnum: # Fixnum
  3083.                   case_sfloat: # Short-Float
  3084.                   #ifdef WIDE
  3085.                   case_ffloat: # Single-Float
  3086.                   #endif
  3087.                     # Das sind direkte Objekte, keine Pointer.
  3088.                   case_sbvector: # simple-bit-vector
  3089.                   case_sstring: # simple-string
  3090.                   case_bignum: # Bignum
  3091.                   #ifndef WIDE
  3092.                   case_ffloat: # Single-Float
  3093.                   #endif
  3094.                   case_dfloat: # Double-Float
  3095.                   case_lfloat: # Long-Float
  3096.                     # Objekte variabler LΣnge, die keine Pointer enthalten.
  3097.                   default:
  3098.                     # Das sind keine Objekte.
  3099.                     /*NOTREACHED*/ abort();
  3100.     }       }   }
  3101.  
  3102. #ifdef GENERATIONAL_GC
  3103.  
  3104. # Nummer der Generation, die bereinigt wird.
  3105. # 0 : alles (Generation 0 + Generation 1)
  3106. # 1 : nur Generation 1
  3107. local uintC generation;
  3108.  
  3109. # Sparsames Durchlaufen durch alle Pointer einer physikalischen Seite:
  3110. # walk_physpage(heapnr,physpage,pageend,heapend,walkfun);
  3111. # Hierfⁿr ist wesentlich, da▀ Varobject_alignment ein Vielfaches
  3112. # von sizeof(object) ist.
  3113.   #define walk_physpage(heapnr,physpage,pageend,heapend,walkfun)  \
  3114.     { { var reg2 uintC count = physpage->continued_count;             \
  3115.         if (count > 0)                                                \
  3116.           { var reg1 object* ptr = physpage->continued_addr;          \
  3117.             dotimespC(count,count, { walkfun(*ptr); ptr++; } );       \
  3118.       }   }                                                           \
  3119.       { var reg4 aint physpage_end =                                  \
  3120.           (pageend < heapend ? pageend : heapend);                    \
  3121.         walk_area(heapnr,physpage->firstobject,physpage_end,walkfun); \
  3122.     } }
  3123.   #ifdef SPVW_PURE
  3124.     #define walk_area(heapnr,physpage_start,physpage_end,walkfun)  \
  3125.       { var reg3 aint objptr = physpage_start;                          \
  3126.         switch (heapnr)                                                 \
  3127.           { case_cons:                                                  \
  3128.             case_ratio:                                                 \
  3129.             case_complex:                                               \
  3130.               # Objekt mit genau 2 Pointern (Cons u.Σ.)                 \
  3131.               { var reg1 object* ptr = (object*)objptr;                 \
  3132.                 while ((aint)ptr < physpage_end)                        \
  3133.                   { walkfun(*ptr); ptr++; }                             \
  3134.               }                                                         \
  3135.               break;                                                    \
  3136.             case_symbol: # Symbol                                       \
  3137.               while (objptr < physpage_end)                             \
  3138.                 { var reg1 object* ptr = (object*)(objptr+symbol_objects_offset); \
  3139.                   var reg2 uintC count;                                 \
  3140.                   dotimespC(count,(sizeof(symbol_)-symbol_objects_offset)/sizeof(object), \
  3141.                     { if ((aint)ptr < physpage_end)                     \
  3142.                         { walkfun(*ptr); ptr++; }                       \
  3143.                         else break;                                     \
  3144.                     });                                                 \
  3145.                   objptr += size_symbol();                              \
  3146.                 }                                                       \
  3147.               break;                                                    \
  3148.             case_array1: case_obvector: case_ostring: case_ovector:     \
  3149.               # Arrays, die nicht simple sind:                          \
  3150.               while (objptr < physpage_end)                             \
  3151.                 { var reg1 object* ptr = &((Array)objptr)->data;        \
  3152.                   if ((aint)ptr < physpage_end)                         \
  3153.                     { walkfun(*ptr); }                                  \
  3154.                   objptr += speicher_laenge_array((Array)objptr);       \
  3155.                 }                                                       \
  3156.               break;                                                    \
  3157.             case_svector: # simple-vector                               \
  3158.               while (objptr < physpage_end)                             \
  3159.                 { var reg2 uintL count = ((Svector)objptr)->length;     \
  3160.                   var reg1 object* ptr = &((Svector)objptr)->data[0];   \
  3161.                   objptr += size_svector(count);                        \
  3162.                   dotimesL(count,count,                                 \
  3163.                     { if ((aint)ptr < physpage_end)                     \
  3164.                         { walkfun(*ptr); ptr++; }                       \
  3165.                         else break;                                     \
  3166.                     });                                                 \
  3167.                 }                                                       \
  3168.               break;                                                    \
  3169.             case_record: # Record                                       \
  3170.               while (objptr < physpage_end)                             \
  3171.                 { var reg2 uintC count = ((Record)objptr)->reclength;   \
  3172.                   var reg1 object* ptr = &((Record)objptr)->recdata[0]; \
  3173.                   objptr += size_record(count);                         \
  3174.                   dotimespC(count,count,                                \
  3175.                     { if ((aint)ptr < physpage_end)                     \
  3176.                         { walkfun(*ptr); ptr++; }                       \
  3177.                         else break;                                     \
  3178.                     });                                                 \
  3179.                 }                                                       \
  3180.               break;                                                    \
  3181.             default:                                                    \
  3182.               # Solche Objekte kommen nicht vor.                        \
  3183.               /*NOTREACHED*/ abort();                                   \
  3184.       }   }
  3185.   #endif
  3186.   #ifdef SPVW_MIXED
  3187.     #define walk_area(heapnr,physpage_start,physpage_end,walkfun)  \
  3188.       { var reg3 aint objptr = physpage_start;                                   \
  3189.         switch (heapnr)                                                          \
  3190.           { case 0: # Objekte variabler LΣnge                                    \
  3191.               while (objptr < physpage_end)                                      \
  3192.                 { switch (typecode_at(objptr)) # Typ des nΣchsten Objekts        \
  3193.                     { case_symbolwithflags: # Symbol                             \
  3194.                         { var reg1 object* ptr = (object*)(objptr+symbol_objects_offset); \
  3195.                           var reg2 uintC count;                                  \
  3196.                           dotimespC(count,(sizeof(symbol_)-symbol_objects_offset)/sizeof(object), \
  3197.                             { if ((aint)ptr < physpage_end)                      \
  3198.                                 { walkfun(*ptr); ptr++; }                        \
  3199.                                 else break;                                      \
  3200.                             });                                                  \
  3201.                           objptr += size_symbol();                               \
  3202.                         }                                                        \
  3203.                         break;                                                   \
  3204.                       case_array1: case_obvector: case_ostring: case_ovector:    \
  3205.                         # Arrays, die nicht simple sind:                         \
  3206.                         { var reg1 object* ptr = &((Array)objptr)->data;         \
  3207.                           if ((aint)ptr < physpage_end)                          \
  3208.                             { walkfun(*ptr); }                                   \
  3209.                           objptr += speicher_laenge((Array)objptr);              \
  3210.                         }                                                        \
  3211.                         break;                                                   \
  3212.                       case_svector: # simple-vector                              \
  3213.                         { var reg2 uintL count = ((Svector)objptr)->length;      \
  3214.                           var reg1 object* ptr = &((Svector)objptr)->data[0];    \
  3215.                           objptr += size_svector(count);                         \
  3216.                           dotimesL(count,count,                                  \
  3217.                             { if ((aint)ptr < physpage_end)                      \
  3218.                                 { walkfun(*ptr); ptr++; }                        \
  3219.                                 else break;                                      \
  3220.                             });                                                  \
  3221.                         }                                                        \
  3222.                         break;                                                   \
  3223.                       case_record: # Record                                      \
  3224.                         { var reg2 uintC count = ((Record)objptr)->reclength;    \
  3225.                           var reg1 object* ptr = &((Record)objptr)->recdata[0];  \
  3226.                           objptr += size_record(count);                          \
  3227.                           dotimespC(count,count,                                 \
  3228.                             { if ((aint)ptr < physpage_end)                      \
  3229.                                 { walkfun(*ptr); ptr++; }                        \
  3230.                                 else break;                                      \
  3231.                             });                                                  \
  3232.                         }                                                        \
  3233.                         break;                                                   \
  3234.                       default: # simple-bit-vector, simple-string, bignum, float \
  3235.                         objptr += speicher_laenge((Varobject)objptr);            \
  3236.                         break;                                                   \
  3237.                 }   }                                                            \
  3238.               break;                                                             \
  3239.             case 1: # 2-Pointer-Objekte                                          \
  3240.               { var reg1 object* ptr = (object*)objptr;                          \
  3241.                 while ((aint)ptr < physpage_end)                                 \
  3242.                   { walkfun(*ptr); ptr++; }                                      \
  3243.               }                                                                  \
  3244.               break;                                                             \
  3245.             default: /*NOTREACHED*/ abort();                                     \
  3246.       }   }
  3247.   #endif
  3248. # Dasselbe als Funktion:
  3249. # walk_physpage_(heapnr,physpage,pageend,heapend,walkstep);
  3250. # bzw. walk_area_(heapnr,physpage_start,physpage_end,walkstep);
  3251.   typedef void (*walkstep_fun)(object* ptr);
  3252.   local void walk_physpage_ (uintL heapnr, physpage_state* physpage, aint pageend, aint heapend, walkstep_fun walkstep);
  3253.   local void walk_physpage_(heapnr,physpage,pageend,heapend,walkstep)
  3254.     var reg8 uintL heapnr;
  3255.     var reg6 physpage_state* physpage;
  3256.     var reg7 aint pageend;
  3257.     var reg7 aint heapend;
  3258.     var reg5 walkstep_fun walkstep;
  3259.     {
  3260.       #define walkstep1(obj)  walkstep(&(obj))
  3261.       walk_physpage(heapnr,physpage,pageend,heapend,walkstep1);
  3262.       #undef walkstep1
  3263.     }
  3264.   local void walk_area_ (uintL heapnr, aint physpage_start, aint physpage_end, walkstep_fun walkstep);
  3265.   local void walk_area_(heapnr,physpage_start,physpage_end,walkstep)
  3266.     var reg6 uintL heapnr;
  3267.     var reg7 aint physpage_start;
  3268.     var reg4 aint physpage_end;
  3269.     var reg5 walkstep_fun walkstep;
  3270.     {
  3271.       #define walkstep1(obj)  walkstep(&(obj))
  3272.       walk_area(heapnr,physpage_start,physpage_end,walkstep1);
  3273.       #undef walkstep1
  3274.     }
  3275.  
  3276.   local void gc_mark_at (object* ptr);
  3277.   local void gc_mark_at(ptr)
  3278.     var reg1 object* ptr;
  3279.     { gc_mark(*ptr); }
  3280.  
  3281. #endif
  3282.  
  3283. # Markierungsphase:
  3284.   # Es werden alle "aktiven" Strukturen markiert.
  3285.   # Aktiv ist alles, was erreichbar ist
  3286.   # - vom LISP-Stack aus  oder
  3287.   # - bei Generational-GC: von der alten Generation aus  oder
  3288.   # - als Programmkonstanten (dazu geh÷rt auch die Liste aller Packages).
  3289.   local void gc_markphase (void);
  3290.   local void gc_markphase()
  3291.     { { var reg1 object* objptr = &STACK_0; # Pointer, der durch den STACK lΣuft
  3292.         until (eq(*objptr,nullobj)) # bis STACK zu Ende ist:
  3293.           { if ( *((oint*)objptr) & wbit(frame_bit_o) ) # Beginnt hier ein Frame?
  3294.              { if (( *((oint*)objptr) & wbit(skip2_bit_o) ) == 0) # Ohne skip2-Bit?
  3295.                 objptr skipSTACKop 2; # ja -> um 2 weiterrⁿcken
  3296.                 else
  3297.                 objptr skipSTACKop 1; # nein -> um 1 weiterrⁿcken
  3298.              }
  3299.              else
  3300.              { # normales Objekt, markieren:
  3301.                var reg2 object obj = *objptr;
  3302.                switch (typecode(obj)) # evtl. Symbol-Flags entfernen
  3303.                  { case_symbolflagged:
  3304.                      #ifndef NO_symbolflags
  3305.                      obj = symbol_without_flags(obj);
  3306.                      #endif
  3307.                    default: break;
  3308.                  }
  3309.                gc_mark(obj);
  3310.                objptr skipSTACKop 1; # weiterrⁿcken
  3311.       }   }  }
  3312.       #ifdef GENERATIONAL_GC
  3313.       # Alte Generation markieren, wobei man sie sehr sparsam durchlΣuft:
  3314.       if (generation > 0)
  3315.         { var reg7 uintL heapnr;
  3316.           for (heapnr=0; heapnr<heapcount; heapnr++)
  3317.             if (is_heap_containing_objects(heapnr)) # Objekte, die keine Pointer enthalten,
  3318.                                                     # braucht man nicht zu durchlaufen.
  3319.               { var reg6 Heap* heap = &mem.heaps[heapnr];
  3320.                 var reg4 aint gen0_start = heap->heap_gen0_start;
  3321.                 var reg5 aint gen0_end = heap->heap_gen0_end;
  3322.                 if (gen0_start < gen0_end)
  3323.                   if (heap->physpages==NULL)
  3324.                     { walk_area_(heapnr,gen0_start,gen0_end,gc_mark_at); } # fallback
  3325.                     else
  3326.                     { var reg3 physpage_state* physpage = heap->physpages;
  3327.                       do { gen0_start += physpagesize;
  3328.                            if ((physpage->protection == PROT_NONE)
  3329.                                || (physpage->protection == PROT_READ)
  3330.                               )
  3331.                              # Cache ausnutzen, gecachte Pointer markieren:
  3332.                              { var reg2 uintL count = physpage->cache_size;
  3333.                                if (count > 0)
  3334.                                  { var reg1 old_new_pointer* ptr = physpage->cache;
  3335.                                    dotimespL(count,count, { gc_mark(ptr->o); ptr++; } );
  3336.                              }   }
  3337.                              else
  3338.                              # ganzen Page-Inhalt markieren:
  3339.                              { walk_physpage_(heapnr,physpage,gen0_start,gen0_end,gc_mark_at); }
  3340.                            physpage++;
  3341.                          }
  3342.                          while (gen0_start < gen0_end);
  3343.         }     }     }
  3344.       #endif
  3345.       # Alle Programmkonstanten markieren:
  3346.       for_all_subrs( gc_mark(subr_tab_ptr_as_object(ptr)); ); # subr_tab durchgehen
  3347.       #if !defined(GENERATIONAL_GC)
  3348.       for_all_constsyms( gc_mark(symbol_tab_ptr_as_object(ptr)); ); # symbol_tab durchgehen
  3349.       #else
  3350.       # gc_mark() betrachtet wegen des Macros in_old_generation() alle konstanten
  3351.       # Symbole als zur alten Generation zugeh÷rig und durchlΣuft sie nicht.
  3352.       for_all_constsyms( # symbol_tab durchgehen
  3353.         { gc_mark(ptr->symvalue);
  3354.           gc_mark(ptr->symfunction);
  3355.           gc_mark(ptr->proplist);
  3356.           gc_mark(ptr->pname);
  3357.           gc_mark(ptr->homepackage);
  3358.         });
  3359.       #endif
  3360.       for_all_constobjs( gc_mark(*objptr); ); # object_tab durchgehen
  3361.     }
  3362.  
  3363. # SUBRs und feste Symbole demarkieren:
  3364.   local void unmark_fixed_varobjects (void);
  3365.   local void unmark_fixed_varobjects()
  3366.     { for_all_subrs( unmark((aint)ptr+subr_const_offset); ); # jedes Subr demarkieren
  3367.       #if !defined(GENERATIONAL_GC)
  3368.       for_all_constsyms( unmark(&((Symbol)ptr)->GCself); ); # jedes Symbol in symbol_tab demarkieren
  3369.       #else
  3370.       # Da wir die konstanten Symbole nicht markiert haben, sondern nur ihren
  3371.       # Inhalt, brauchen wir sie auch nicht zu demarkieren.
  3372.       #endif
  3373.     }
  3374.  
  3375. #if !defined(MORRIS_GC)
  3376.  
  3377.  #ifdef SPVW_MIXED_BLOCKS_OPPOSITE
  3378.  
  3379.   # CONS-Zellen zwischen page->page_start und page->page_end oben
  3380.   # konzentrieren:
  3381.   local void gc_compact_cons_page (Page* page);
  3382.   local void gc_compact_cons_page(page)
  3383.     var reg3 Page* page;
  3384.     # Dabei wandert der Pointer p1 von unten und der Pointer p2 von
  3385.     # oben durch den Speicherbereich, bis sie kollidieren. Es
  3386.     # werden dabei markierte Strukturen ⁿber unmarkierte geschoben.
  3387.     { var reg1 aint p1 = page->page_start; # untere Grenze
  3388.       var reg2 aint p2 = page->page_end; # obere Grenze
  3389.       sweeploop:
  3390.         # Suche nΣchstobere unmarkierte Zelle <p2 und demarkiere dabei alle:
  3391.         sweeploop1:
  3392.           if (p1==p2) goto sweepok2; # Grenzen gleich geworden -> fertig
  3393.           p2 -= sizeof(cons_); # nΣchste Zelle von oben erfassen
  3394.           if (marked(p2)) # markiert?
  3395.             { unmark(p2); # demarkieren
  3396.               goto sweeploop1;
  3397.             }
  3398.         # p1 <= p2, p2 zeigt auf eine unmarkierte Zelle.
  3399.         # Suche nΣchstuntere markierte Zelle >=p1:
  3400.         sweeploop2:
  3401.           if (p1==p2) goto sweepok1; # Grenzen gleich geworden -> fertig
  3402.           if (!marked(p1)) # unmarkiert?
  3403.             { p1 += sizeof(cons_); # bei der nΣchstunteren Zelle
  3404.               goto sweeploop2; # weitersuchen
  3405.             }
  3406.         # p1 < p2, p1 zeigt auf eine markierte Zelle.
  3407.         unmark(p1); # demarkieren
  3408.         # Zelleninhalt in die unmarkierte Zelle kopieren:
  3409.         ((object*)p2)[0] = ((object*)p1)[0];
  3410.         ((object*)p2)[1] = ((object*)p1)[1];
  3411.         *(object*)p1 = type_pointer_object(0,p2); # neue Adresse hinterlassen
  3412.         mark(p1); # und markieren (als Erkennung fⁿrs Aktualisieren)
  3413.         p1 += sizeof(cons_); # Diese Zelle ist fertig.
  3414.         goto sweeploop; # weiter
  3415.       sweepok1: p1 += sizeof(cons_); # letztes unmarkiertes Cons ⁿbergehen
  3416.       sweepok2:
  3417.       # p1 = neue untere Grenze des Cons-Bereiches
  3418.       page->page_start = p1;
  3419.     }
  3420.  
  3421.  #else
  3422.  
  3423.   # CONS-Zellen zwischen page->page_start und page->page_end unten
  3424.   # konzentrieren:
  3425.   local void gc_compact_cons_page (Page* page);
  3426.   local void gc_compact_cons_page(page)
  3427.     var reg3 Page* page;
  3428.     # Dabei wandert der Pointer p1 von unten und der Pointer p2 von
  3429.     # oben durch den Speicherbereich, bis sie kollidieren. Es
  3430.     # werden dabei markierte Strukturen ⁿber unmarkierte geschoben.
  3431.     { var reg1 aint p1 = page->page_start; # untere Grenze
  3432.       var reg2 aint p2 = page->page_end; # obere Grenze
  3433.       sweeploop:
  3434.         # Suche nΣchstobere markierte Zelle <p2:
  3435.         sweeploop1:
  3436.           if (p1==p2) goto sweepok2; # Grenzen gleich geworden -> fertig
  3437.           p2 -= sizeof(cons_); # nΣchste Zelle von oben erfassen
  3438.           if (!marked(p2)) goto sweeploop1; # unmarkiert?
  3439.         # p1 <= p2, p2 zeigt auf eine markierte Zelle.
  3440.         unmark(p2); # demarkieren
  3441.         # Suche nΣchstuntere unmarkierte Zelle >=p1 und demarkiere dabei alle:
  3442.         sweeploop2:
  3443.           if (p1==p2) goto sweepok1; # Grenzen gleich geworden -> fertig
  3444.           if (marked(p1)) # markiert?
  3445.             { unmark(p1); # demarkieren
  3446.               p1 += sizeof(cons_); # bei der nΣchstoberen Zelle
  3447.               goto sweeploop2; # weitersuchen
  3448.             }
  3449.         # p1 < p2, p1 zeigt auf eine unmarkierte Zelle.
  3450.         # Zelleninhalt von der markierten in die unmarkierte Zelle kopieren:
  3451.         ((object*)p1)[0] = ((object*)p2)[0];
  3452.         ((object*)p1)[1] = ((object*)p2)[1];
  3453.         *(object*)p2 = type_pointer_object(0,p1); # neue Adresse hinterlassen
  3454.         mark(p2); # und markieren (als Erkennung fⁿrs Aktualisieren)
  3455.         p1 += sizeof(cons_); # Diese Zelle ist fertig.
  3456.         goto sweeploop; # weiter
  3457.       sweepok1: p1 += sizeof(cons_); # letztes markiertes Cons ⁿbergehen
  3458.       sweepok2:
  3459.       # p1 = neue obere Grenze des Cons-Bereiches
  3460.       page->page_end = p1;
  3461.     }
  3462.  
  3463.  #endif
  3464.  
  3465. #else # defined(MORRIS_GC)
  3466.  
  3467. # Algorithmus siehe:
  3468. # [F. Lockwood Morris: A time- and space-efficient garbage collection algorithm.
  3469. #  CACM 21,8 (August 1978), 662-665.]
  3470.  
  3471.   # Alle unmarkierten CONS-Zellen l÷schen und die markierten CONS-Zellen demarkieren,
  3472.   # damit das Markierungsbit fⁿr die RⁿckwΣrtspointer zur Verfⁿgung steht.
  3473.   local void gc_morris1 (Page* page);
  3474.   local void gc_morris1(page)
  3475.     var reg4 Page* page;
  3476.     { var reg1 aint p1 = page->page_start; # untere Grenze
  3477.       var reg2 aint p2 = page->page_end; # obere Grenze
  3478.       var reg3 aint d = 0; # freien Speicher mitzΣhlen
  3479.       until (p1==p2)
  3480.         { if (!marked(p1))
  3481.             { ((object*)p1)[0] = nullobj;
  3482.               ((object*)p1)[1] = nullobj;
  3483.               d += sizeof(cons_);
  3484.             }
  3485.             else
  3486.             { unmark(p1);
  3487.               #ifdef DEBUG_SPVW
  3488.               if (eq(((object*)p1)[0],nullobj) || eq(((object*)p1)[1],nullobj))
  3489.                 abort();
  3490.               #endif
  3491.             }
  3492.           p1 += sizeof(cons_); # Diese Zelle ist fertig.
  3493.         }
  3494.       page->page_gcpriv.d = d; # freien Speicher abspeichern
  3495.     }
  3496.  
  3497.  #ifdef SPVW_MIXED_BLOCKS_OPPOSITE
  3498.  
  3499.   # Es gibt nur eine einzige Page mit Zwei-Pointer-Objekten.
  3500.  
  3501.   local void gc_morris2 (Page* page);
  3502.   local void gc_morris2(page)
  3503.     var reg7 Page* page;
  3504.     { # Jede Zelle innerhalb eines Cons enthΣlt nun eine Liste aller
  3505.       # Adressen von Pointern auf diese Zelle, die aus einer Wurzel heraus
  3506.       # oder aus einem Varobject heraus auf diese Zelle zeigen.
  3507.       #
  3508.       # Die nicht gel÷schten Conses von links nach rechts durchlaufen:
  3509.       # (Zwischendurch enthΣlt jede Zelle eine Liste aller Adressen
  3510.       # von Pointern auf diese Zelle, die aus einer Wurzel heraus,
  3511.       # aus einem Varobject heraus oder aus einem weiter links liegenden
  3512.       # Cons auf diese Zelle zeigen.)
  3513.       var reg4 aint p1 = page->page_start; # untere Grenze
  3514.       var reg5 aint p2 = p1 + page->gcpriv.d; # spΣtere untere Grenze
  3515.       var reg6 aint p1limit = page->page_end; # obere Grenze
  3516.       until (p1==p1limit) # stets p1 <= p2 <= p1limit
  3517.         { # Beide Zellen eines Cons werden genau gleich behandelt.
  3518.           var reg1 object obj = *(object*)p1;
  3519.           if (!eq(obj,nullobj))
  3520.             { # p1 wird nach p2 verschoben.
  3521.               # Die bisher registrierten Pointer auf diese Zelle werden aktualisiert:
  3522.               until ((as_oint(obj) & wbit(garcol_bit_o)) == 0) # Liste abarbeiten
  3523.                 { obj = without_mark_bit(obj);
  3524.                  {var reg2 aint p = upointer(obj);
  3525.                   var reg3 object next_obj = *(object*)p;
  3526.                   *(object*)p = type_pointer_object(typecode(obj),p2);
  3527.                   obj = next_obj;
  3528.                 }}
  3529.               # Falls die Zelle einen Pointer "nach rechts" enthΣlt, wird er umgedreht.
  3530.               { var reg3 tint type = typecode(obj);
  3531.                 switch (type)
  3532.                   { case_cons: case_ratio: case_complex:
  3533.                       { var reg2 aint p = upointer(obj);
  3534.                         if (p > p1)
  3535.                           { # Fⁿr spΣtere Aktualisierung
  3536.                             # p1 in die Liste der Pointer auf p einhΣngen:
  3537.                             *(object*)p1 = *(object*)p;
  3538.                             *(object*)p = with_mark_bit(type_pointer_object(type,p1));
  3539.                             break;
  3540.                       }   }
  3541.                     default:
  3542.                       *(object*)p1 = obj;
  3543.               }   }
  3544.               p2 += sizeof(object);
  3545.             }
  3546.           p1 += sizeof(object);
  3547.         }
  3548.       if (!(p2==p1limit)) abort();
  3549.     }
  3550.   local void gc_morris3 (Page* page);
  3551.   local void gc_morris3(page)
  3552.     var reg7 Page* page;
  3553.     { # Jede Zelle innerhalb eines Cons enthΣlt nun wieder den ursprⁿnglichen
  3554.       # Inhalt.
  3555.       #
  3556.       # Die nicht gel÷schten Conses von rechts nach links durchlaufen
  3557.       # und dabei rechts kompaktieren:
  3558.       # (Zwischendurch enthΣlt jede Zelle eine Liste aller Adressen
  3559.       # von Pointern auf diese Zelle, die aus einem weiter rechts liegenden
  3560.       # Cons auf diese Zelle zeigen.)
  3561.       var reg6 aint p1limit = page->page_start; # untere Grenze
  3562.       var reg4 aint p1 = page->page_end; # obere Grenze
  3563.       var reg5 aint p2 = p1; # obere Grenze
  3564.       until (p1==p1limit) # stets p1limit <= p1 <= p2
  3565.         { # Beide Zellen eines Cons werden genau gleich behandelt.
  3566.           p1 -= sizeof(object);
  3567.          {var reg1 object obj = *(object*)p1;
  3568.           if (!eq(obj,nullobj))
  3569.             { p2 -= sizeof(object);
  3570.               # p1 wird nach p2 verschoben.
  3571.               # Die neu registrierten Pointer auf diese Zelle werden aktualisiert:
  3572.               until ((as_oint(obj) & wbit(garcol_bit_o)) == 0) # Liste abarbeiten
  3573.                 { obj = without_mark_bit(obj);
  3574.                  {var reg2 aint p = upointer(obj);
  3575.                   var reg3 object next_obj = *(object*)p;
  3576.                   *(object*)p = type_pointer_object(typecode(obj),p2);
  3577.                   obj = next_obj;
  3578.                 }}
  3579.               *(object*)p2 = obj;
  3580.               { var reg5 tint type = typecode(obj);
  3581.                 if (!immediate_type_p(type)) # unverschieblich -> nichts tun
  3582.                   switch (type)
  3583.                     { case_cons: case_ratio: case_complex: # Zwei-Pointer-Objekt
  3584.                         { var reg4 aint p = upointer(obj);
  3585.                           if (p < p1) # Pointer nach links?
  3586.                             { # Fⁿr spΣtere Aktualisierung
  3587.                               # p2 in die Liste der Pointer auf p einhΣngen:
  3588.                               *(object*)p2 = *(object*)p;
  3589.                               *(object*)p = with_mark_bit(type_pointer_object(type,p2));
  3590.                             }
  3591.                           elif (p == p1) # Pointer auf sich selbst?
  3592.                             { *(object*)p2 = type_pointer_object(type,p2); }
  3593.                         }
  3594.                         break;
  3595.                       default: # Objekt variabler LΣnge
  3596.                         if (marked(ThePointer(obj))) # markiert?
  3597.                           *(object*)p2 = type_untype_object(type,untype(*(object*)ThePointer(obj)));
  3598.                         break;
  3599.               }     }
  3600.             }}
  3601.         }
  3602.       # p2 = neue untere Grenze des Cons-Bereiches
  3603.       if (!(p2 == page->page_start + page->page_gcpriv.d)) abort();
  3604.       page->page_start = p2;
  3605.     }
  3606.  
  3607.  #elif defined(SPVW_MIXED_BLOCKS) # TRIVIALMAP_MEMORY
  3608.  
  3609.   local void gc_morris2 (Page* page);
  3610.   local void gc_morris2(page)
  3611.     var reg7 Page* page;
  3612.     { # Jede Zelle innerhalb eines Cons enthΣlt nun eine Liste aller
  3613.       # Adressen von Pointern auf diese Zelle, die aus einer Wurzel heraus
  3614.       # oder aus einem Varobject heraus auf diese Zelle zeigen.
  3615.       #
  3616.       # Die nicht gel÷schten Conses von rechts nach links durchlaufen:
  3617.       # (Zwischendurch enthΣlt jede Zelle eine Liste aller Adressen
  3618.       # von Pointern auf diese Zelle, die aus einer Wurzel heraus,
  3619.       # aus einem Varobject heraus oder aus einem weiter rechts liegenden
  3620.       # Cons auf diese Zelle zeigen.)
  3621.       var reg5 aint p1 = page->page_end; # obere Grenze
  3622.       var reg4 aint p2 = p1 - page->gcpriv.d; # spΣtere obere Grenze
  3623.       var reg6 aint p1limit = page->page_start; # untere Grenze
  3624.       #ifdef DEBUG_SPVW
  3625.       until (p1==p1limit)
  3626.         { p1 -= 2*sizeof(object);
  3627.           if (eq(*(object*)p1,nullobj)+eq(*(object*)(p1^sizeof(object)),nullobj)==1)
  3628.             abort();
  3629.         }
  3630.       p1 = page->page_end;
  3631.       #endif
  3632.       until (p1==p1limit) # stets p1limit <= p2 <= p1
  3633.         { # Beide Zellen eines Cons werden genau gleich behandelt.
  3634.           p1 -= sizeof(object);
  3635.           #ifdef DEBUG_SPVW
  3636.           if (eq(*(object*)p1,nullobj)+eq(*(object*)(p1^sizeof(object)),nullobj)==1)
  3637.             abort();
  3638.           #endif
  3639.          {var reg1 object obj = *(object*)p1;
  3640.           if (!eq(obj,nullobj))
  3641.             { p2 -= sizeof(object);
  3642.               # p1 wird nach p2 verschoben.
  3643.               # Die bisher registrierten Pointer auf diese Zelle werden aktualisiert:
  3644.               until ((as_oint(obj) & wbit(garcol_bit_o)) == 0) # Liste abarbeiten
  3645.                 { obj = without_mark_bit(obj);
  3646.                  {var reg2 aint p = upointer(obj);
  3647.                   var reg3 object next_obj = *(object*)p;
  3648.                   *(object*)p = type_pointer_object(typecode(obj),p2);
  3649.                   obj = next_obj;
  3650.                 }}
  3651.               # obj = ursprⁿnglicher Inhalt der Zelle p1.
  3652.               #ifdef DEBUG_SPVW
  3653.               if (eq(obj,nullobj)) abort();
  3654.               #endif
  3655.               # Falls die Zelle einen Pointer "nach links" enthΣlt, wird er umgedreht.
  3656.               { var reg3 tint type = typecode(obj);
  3657.                 switch (type)
  3658.                   { case_cons: case_ratio: case_complex:
  3659.                       { var reg2 aint p = upointer(obj);
  3660.                         if (!in_old_generation(obj,type,1) && (p < p1))
  3661.                           { # Fⁿr spΣtere Aktualisierung
  3662.                             # p1 in die Liste der Pointer auf p einhΣngen:
  3663.                             *(object*)p1 = *(object*)p;
  3664.                             *(object*)p = with_mark_bit(type_pointer_object(type,p1));
  3665.                             break;
  3666.                       }   }
  3667.                     default:
  3668.                       *(object*)p1 = obj;
  3669.             } }   }
  3670.         }}
  3671.       if (!(p2==p1limit)) abort();
  3672.     }
  3673.   local void gc_morris3 (Page* page);
  3674.   local void gc_morris3(page)
  3675.     var reg7 Page* page;
  3676.     { # Jede Zelle innerhalb eines Cons enthΣlt nun wieder den ursprⁿnglichen
  3677.       # Inhalt.
  3678.       #
  3679.       # Die nicht gel÷schten Conses von links nach rechts durchlaufen
  3680.       # und dabei links kompaktieren:
  3681.       # (Zwischendurch enthΣlt jede Zelle eine Liste aller Adressen
  3682.       # von Pointern auf diese Zelle, die aus einem weiter links liegenden
  3683.       # Cons auf diese Zelle zeigen.)
  3684.       var reg6 aint p1limit = page->page_end; # obere Grenze
  3685.       var reg4 aint p1 = page->page_start; # untere Grenze
  3686.       var reg5 aint p2 = p1; # untere Grenze
  3687.       until (p1==p1limit) # stets p1limit <= p1 <= p2
  3688.         { # Beide Zellen eines Cons werden genau gleich behandelt.
  3689.           var reg1 object obj = *(object*)p1;
  3690.           if (!eq(obj,nullobj))
  3691.             { # p1 wird nach p2 verschoben.
  3692.               # Die neu registrierten Pointer auf diese Zelle werden aktualisiert:
  3693.               until ((as_oint(obj) & wbit(garcol_bit_o)) == 0) # Liste abarbeiten
  3694.                 { obj = without_mark_bit(obj);
  3695.                  {var reg2 aint p = upointer(obj);
  3696.                   var reg3 object next_obj = *(object*)p;
  3697.                   *(object*)p = type_pointer_object(typecode(obj),p2);
  3698.                   obj = next_obj;
  3699.                 }}
  3700.               # obj = richtiger Inhalt der Zelle p1.
  3701.               { var reg5 tint type = typecode(obj);
  3702.                 if (!immediate_type_p(type)) # unverschieblich -> nichts tun
  3703.                   switch (type)
  3704.                     { case_cons: case_ratio: case_complex: # Zwei-Pointer-Objekt
  3705.                         { var reg4 aint p = upointer(obj);
  3706.                           if (p > p1) # Pointer nach rechts?
  3707.                             { # Fⁿr spΣtere Aktualisierung
  3708.                               # p2 in die Liste der Pointer auf p einhΣngen:
  3709.                               *(object*)p2 = *(object*)p;
  3710.                               *(object*)p = with_mark_bit(type_pointer_object(type,p2));
  3711.                             }
  3712.                           elif (p == p1) # Pointer auf sich selbst?
  3713.                             { *(object*)p2 = type_pointer_object(type,p2); }
  3714.                           else
  3715.                             { *(object*)p2 = obj; }
  3716.                         }
  3717.                         break;
  3718.                       default: # Objekt variabler LΣnge
  3719.                         if (marked(ThePointer(obj))) # markiert?
  3720.                           *(object*)p2 = type_untype_object(type,untype(*(object*)ThePointer(obj)));
  3721.                           else
  3722.                           *(object*)p2 = obj;
  3723.                         break;
  3724.                     }
  3725.                   else # unverschieblich oder Pointer in die alte Generation -> nichts tun
  3726.                   { *(object*)p2 = obj; }
  3727.               }
  3728.               p2 += sizeof(object);
  3729.             }
  3730.           p1 += sizeof(object);
  3731.         }
  3732.       # p2 = neue obere Grenze des Cons-Bereiches
  3733.       if (!(p2 == page->page_end - page->page_gcpriv.d)) abort();
  3734.       page->page_end = p2;
  3735.     }
  3736.  
  3737.  #else # SPVW_PURE_BLOCKS <==> SINGLEMAP_MEMORY
  3738.  
  3739.   # gc_morris2 und gc_morris3 mⁿssen je einmal fⁿr jede Page aufgerufen werden,
  3740.   # und zwar gc_morris2 von rechts nach links, dann gc_morris3 von links nach rechts
  3741.   # (im Sinne der Anordnung der Adressen)!
  3742.  
  3743.   local void gc_morris2 (Page* page);
  3744.   local void gc_morris2(page)
  3745.     var reg7 Page* page;
  3746.     { # Jede Zelle innerhalb eines Cons enthΣlt nun eine Liste aller
  3747.       # Adressen von Pointern auf diese Zelle, die aus einer Wurzel heraus
  3748.       # oder aus einem Varobject heraus auf diese Zelle zeigen.
  3749.       #
  3750.       # Die nicht gel÷schten Conses von rechts nach links durchlaufen:
  3751.       # (Zwischendurch enthΣlt jede Zelle eine Liste aller Adressen
  3752.       # von Pointern auf diese Zelle, die aus einer Wurzel heraus,
  3753.       # aus einem Varobject heraus oder aus einem weiter rechts liegenden
  3754.       # Cons auf diese Zelle zeigen.)
  3755.       var reg4 aint p1 = page->page_end; # obere Grenze
  3756.       var reg3 aint p2 = p1 - page->gcpriv.d; # spΣtere obere Grenze
  3757.       var reg5 aint p1limit = page->page_start; # untere Grenze
  3758.       until (p1==p1limit) # stets p1limit <= p2 <= p1
  3759.         { # Beide Zellen eines Cons werden genau gleich behandelt.
  3760.           p1 -= sizeof(object);
  3761.          {var reg1 object obj = *(object*)p1;
  3762.           if (!eq(obj,nullobj))
  3763.             { p2 -= sizeof(object);
  3764.               # p1 wird nach p2 verschoben.
  3765.               # Die bisher registrierten Pointer auf diese Zelle werden aktualisiert:
  3766.               until ((as_oint(obj) & wbit(garcol_bit_o)) == 0) # Liste abarbeiten
  3767.                 { obj = without_mark_bit(obj);
  3768.                  {var reg2 object next_obj = *(object*)obj;
  3769.                   *(object*)obj = (object)p2;
  3770.                   obj = next_obj;
  3771.                 }}
  3772.               # obj = ursprⁿnglicher Inhalt der Zelle p1.
  3773.               # Falls die Zelle einen Pointer "nach links" enthΣlt, wird er umgedreht.
  3774.               if (is_cons_heap(typecode(obj))
  3775.                   && !in_old_generation(obj,typecode(obj),1)
  3776.                   && ((aint)obj < p1)
  3777.                  )
  3778.                 { # Fⁿr spΣtere Aktualisierung
  3779.                   # p1 in die Liste der Pointer auf obj einhΣngen:
  3780.                   *(object*)p1 = *(object*)obj;
  3781.                   *(object*)obj = with_mark_bit((object)p1);
  3782.                 }
  3783.                 else
  3784.                 { *(object*)p1 = obj; }
  3785.             }
  3786.         }}
  3787.       if (!(p2==p1limit)) abort();
  3788.     }
  3789.   local void gc_morris3 (Page* page);
  3790.   local void gc_morris3(page)
  3791.     var reg7 Page* page;
  3792.     { # Jede Zelle innerhalb eines Cons enthΣlt nun wieder den ursprⁿnglichen
  3793.       # Inhalt.
  3794.       #
  3795.       # Die nicht gel÷schten Conses von links nach rechts durchlaufen
  3796.       # und dabei links kompaktieren:
  3797.       # (Zwischendurch enthΣlt jede Zelle eine Liste aller Adressen
  3798.       # von Pointern auf diese Zelle, die aus einem weiter links liegenden
  3799.       # Cons auf diese Zelle zeigen.)
  3800.       var reg6 aint p1limit = page->page_end; # obere Grenze
  3801.       var reg4 aint p1 = page->page_start; # untere Grenze
  3802.       var reg3 aint p2 = p1; # untere Grenze
  3803.       until (p1==p1limit) # stets p1limit <= p1 <= p2
  3804.         { # Beide Zellen eines Cons werden genau gleich behandelt.
  3805.           var reg1 object obj = *(object*)p1;
  3806.           if (!eq(obj,nullobj))
  3807.             { # p1 wird nach p2 verschoben.
  3808.               # Die neu registrierten Pointer auf diese Zelle werden aktualisiert:
  3809.               until ((as_oint(obj) & wbit(garcol_bit_o)) == 0) # Liste abarbeiten
  3810.                 { obj = without_mark_bit(obj);
  3811.                  {var reg2 object next_obj = *(object*)obj;
  3812.                   *(object*)obj = (object)p2;
  3813.                   obj = next_obj;
  3814.                 }}
  3815.               # obj = richtiger Inhalt der Zelle p1.
  3816.               { var reg5 tint type = typecode(obj);
  3817.                 if (!is_unused_heap(type) && !in_old_generation(obj,type,?))
  3818.                   if (is_cons_heap(type))
  3819.                     # Zwei-Pointer-Objekt
  3820.                     { if ((aint)obj > p1) # Pointer nach rechts?
  3821.                         { # Fⁿr spΣtere Aktualisierung
  3822.                           # p2 in die Liste der Pointer auf obj einhΣngen:
  3823.                           *(object*)p2 = *(object*)obj;
  3824.                           *(object*)obj = with_mark_bit((object)p2);
  3825.                         }
  3826.                       elif ((aint)obj == p1) # Pointer auf sich selbst?
  3827.                         { *(object*)p2 = (object)p2; }
  3828.                       else
  3829.                         { *(object*)p2 = obj; }
  3830.                     }
  3831.                     else
  3832.                     # Objekt variabler LΣnge
  3833.                     { if (marked(ThePointer(obj))) # markiert?
  3834.                         *(object*)p2 = type_untype_object(type,untype(*(object*)ThePointer(obj)));
  3835.                         else
  3836.                         *(object*)p2 = obj;
  3837.                     }
  3838.                   else # unverschieblich oder Pointer in die alte Generation -> nichts tun
  3839.                   { *(object*)p2 = obj; }
  3840.               }
  3841.               p2 += sizeof(object);
  3842.             }
  3843.           p1 += sizeof(object);
  3844.         }
  3845.       # p2 = neue obere Grenze des Cons-Bereiches
  3846.       if (!(p2 == page->page_end - page->page_gcpriv.d)) abort();
  3847.       page->page_end = p2;
  3848.     }
  3849.  
  3850.  #endif
  3851.  
  3852. #endif
  3853.  
  3854. # Den Selbstpointer eines Objekts variabler LΣnge modifizieren:
  3855. # set_GCself(p,type,addr);
  3856. # setzt p->GCself auf type_pointer_object(type,addr).
  3857.   #if !(exact_uint_size_p(oint_type_len) && ((oint_type_shift%hfintsize)==0) && (tint_type_mask == bit(oint_type_len)-1))
  3858.     #ifdef MAP_MEMORY
  3859.       # addr enthΣlt Typinfo
  3860.       #define set_GCself(p,type,addr)  \
  3861.         ((Varobject)(p))->GCself = type_pointer_object((type)&(tint_type_mask),(addr)&(oint_addr_mask))
  3862.     #else
  3863.       # addr enthΣlt keine Typinfo
  3864.       #define set_GCself(p,type,addr)  \
  3865.         ((Varobject)(p))->GCself = type_pointer_object((type)&(tint_type_mask),addr)
  3866.     #endif
  3867.   #else # besser: zwar zwei Speicherzugriffe, jedoch weniger Arithmetik
  3868.     #define set_GCself(p,type,addr)  \
  3869.       ((Varobject)(p))->GCself = type_pointer_object(0,addr), \
  3870.       ((Varobject)(p))->header_flags = (type)
  3871.   #endif
  3872.  
  3873. # Objekte variabler LΣnge zwischen page->page_start und page->page_end zur
  3874. # Zusammenschiebung nach unten vorbereiten. Dabei wird in jedes markierte
  3875. # Objekt vorne der Pointer auf die Stelle eingetragen, wo das
  3876. # Objekt spΣter stehen wird (samt Typinfo). Ist das darauffolgende
  3877. # Objekt unmarkiert, so wird in dessen erstem Pointer die Adresse
  3878. # des nΣchsten markierten Objekts eingetragen.
  3879.   #ifdef SPVW_PURE
  3880.   local aint gc_sweep1_varobject_page (uintL heapnr, aint start, aint end, object* firstmarked, aint dest);
  3881.   local aint gc_sweep1_varobject_page PARM5(heapnr,start,end,firstmarked,dest,
  3882.     var reg6 uintL heapnr,
  3883.     var aint start,
  3884.     var aint end,
  3885.     var object* firstmarked,
  3886.     var aint dest)
  3887.   #elif defined(GENERATIONAL_GC)
  3888.   local aint gc_sweep1_varobject_page (aint start, aint end, object* firstmarked, aint dest);
  3889.   local aint gc_sweep1_varobject_page PARM4(start,end,firstmarked,dest,
  3890.     var aint start,
  3891.     var aint end,
  3892.     var object* firstmarked,
  3893.     var aint dest)
  3894.   #else
  3895.   local void gc_sweep1_varobject_page (Page* page);
  3896.   local void gc_sweep1_varobject_page PARM1(page,
  3897.     var reg6 Page* page)
  3898.   #endif
  3899.     {
  3900.       #if defined(SPVW_PURE) || defined(GENERATIONAL_GC)
  3901.       var reg4 object* last_open_ptr = firstmarked;
  3902.       var reg2 aint p2 = start; # Source-Pointer
  3903.       var reg5 aint p2end = end; # obere Grenze des Source-Bereiches
  3904.       var reg3 aint p1 = dest; # Ziel-Pointer
  3905.       #else
  3906.       var reg4 object* last_open_ptr = &page->page_gcpriv.firstmarked;
  3907.         # In *last_open_ptr ist stets die Adresse des nΣchsten markierten
  3908.         # Objekts (als oint) einzutragen.
  3909.         # Durch verkettete-Liste-Mechanismus: Am Schlu▀ enthΣlt
  3910.         # page->gcpriv.firstmarked die Adresse des 1. markierten Objekts
  3911.       var reg2 aint p2 = page->page_start; # Source-Pointer
  3912.       var reg5 aint p2end = page->page_end; # obere Grenze des Source-Bereiches
  3913.       var reg3 aint p1 = p2; # Ziel-Pointer
  3914.       #endif
  3915.       # start <= p1 <= p2 <= end, p1 und p2 wachsen, p2 schneller als p1.
  3916.       var_speicher_laenge_;
  3917.       sweeploop1:
  3918.         # NΣchstes markiertes Objekt suchen.
  3919.         # Adresse des nΣchsten markierten Objekts in *last_open_ptr eintragen.
  3920.         if (p2==p2end) goto sweepok1; # obere Grenze erreicht -> fertig
  3921.         { var reg2 tint flags = mtypecode(((Varobject)p2)->GCself);
  3922.           # Typinfo (und Flags bei Symbolen) retten
  3923.           var reg1 uintL laenge = calc_speicher_laenge(p2); # Byte-LΣnge bestimmen
  3924.           if (!marked(p2)) # Objekt unmarkiert?
  3925.             { p2 += laenge; goto sweeploop1; } # ja -> zum nΣchsten Objekt
  3926.           # Objekt markiert
  3927.           *last_open_ptr = type_pointer_object(0,p2); # Adresse ablegen
  3928.           set_GCself(p2, flags,p1); # neue Adresse eintragen, mit alter
  3929.                          # Typinfo (darin ist auch das Markierungsbit enthalten)
  3930.           p2 += laenge; # Sourceadresse fⁿr nΣchstes Objekt
  3931.           p1 += laenge; # Zieladresse fⁿr nΣchstes Objekt
  3932.         }
  3933.       sweeploop2:
  3934.         # NΣchstes unmarkiertes Objekt suchen.
  3935.         if (p2==p2end) goto sweepok2; # obere Grenze erreicht -> fertig
  3936.         { var reg2 tint flags = mtypecode(((Varobject)p2)->GCself);
  3937.           # Typinfo (und Flags bei Symbolen) retten
  3938.           var reg1 uintL laenge = calc_speicher_laenge(p2); # Byte-LΣnge bestimmen
  3939.           if (!marked(p2)) # Objekt unmarkiert?
  3940.             { last_open_ptr = (object*)p2; # ja -> Hier den nΣchsten Pointer ablegen
  3941.               p2 += laenge; goto sweeploop1; # und zum nΣchsten Objekt
  3942.             }
  3943.           # Objekt markiert
  3944.           set_GCself(p2, flags,p1); # neue Adresse eintragen, mit alter
  3945.                          # Typinfo (darin ist auch das Markierungsbit enthalten)
  3946.           p2 += laenge; # Sourceadresse fⁿr nΣchstes Objekt
  3947.           p1 += laenge; # Zieladresse fⁿr nΣchstes Objekt
  3948.           goto sweeploop2;
  3949.         }
  3950.       sweepok1: *last_open_ptr = type_pointer_object(0,p2);
  3951.       sweepok2: ;
  3952.       #if defined(SPVW_PURE) || defined(GENERATIONAL_GC)
  3953.       return p1;
  3954.       #endif
  3955.     }
  3956.  
  3957. # Aktualisierungsphase:
  3958.   # Der gesamte LISP-Speicher wird durchgegangen und dabei alte durch
  3959.   # neue Adressen ersetzt.
  3960.   # Aktualisierung eines Objekts *objptr :
  3961.     #if !defined(MORRIS_GC)
  3962.       #define aktualisiere(objptr)  \
  3963.         { var reg2 tint type = mtypecode(*(object*)objptr);                     \
  3964.           if (!immediate_type_p(type)) # unverschieblich -> nichts tun          \
  3965.             { var reg1 object obj = *(object*)objptr; # fragliches Objekt       \
  3966.               if (!in_old_generation(obj,type,?))                               \
  3967.                 # Σltere Generation -> nichts zu tun (Objekt blieb stehen)      \
  3968.                 if (marked(ThePointer(obj))) # markiert?                        \
  3969.                   # nein -> nichts zu tun (Objekt blieb stehen)                 \
  3970.                   # ja -> neue Adresse eintragen und Typinfobyte (incl.         \
  3971.                   #       evtl. Symbol-Bindungsflags) zurⁿckschreiben           \
  3972.                   *(object*)objptr =                                            \
  3973.                     type_untype_object(type,untype(*(object*)ThePointer(obj))); \
  3974.         }   }
  3975.     #else # defined(MORRIS_GC)
  3976.       #if defined(SPVW_MIXED_BLOCKS) # && !defined(MAP_MEMORY)
  3977.         #define aktualisiere(objptr)  \
  3978.           { var reg2 tint type = mtypecode(*(object*)objptr);                     \
  3979.             if (!immediate_type_p(type)) # unverschieblich -> nichts tun          \
  3980.               switch (type)                                                       \
  3981.                 { default: # Objekt variabler LΣnge                               \
  3982.                     { var reg1 object obj = *(object*)objptr; # fragliches Objekt \
  3983.                       if (!in_old_generation(obj,type,0))                         \
  3984.                         if (marked(ThePointer(obj))) # markiert?                  \
  3985.                           *(object*)objptr = type_untype_object(type,untype(*(object*)ThePointer(obj))); \
  3986.                     }                                                             \
  3987.                     break;                                                        \
  3988.                   case_cons: case_ratio: case_complex: # Zwei-Pointer-Objekt      \
  3989.                     { var reg1 object obj = *(object*)objptr; # fragliches Objekt \
  3990.                       if (!in_old_generation(obj,type,1))                         \
  3991.                         { # Fⁿr spΣtere Aktualisierung in dessen Liste einhΣngen: \
  3992.                           *(object*)objptr = *(object*)ThePointer(obj);           \
  3993.                           *(object*)ThePointer(obj) = with_mark_bit(type_pointer_object(type,objptr)); \
  3994.                     }   }                                                         \
  3995.                     break;                                                        \
  3996.           }     }
  3997.       #else # defined(SPVW_PURE_BLOCKS) # && defined(SINGLEMAP_MEMORY)
  3998.         #define aktualisiere(objptr)  \
  3999.           { var reg2 tint type = mtypecode(*(object*)objptr);                 \
  4000.             if (!is_unused_heap(type)) # unverschieblich -> nichts tun        \
  4001.               { var reg1 object obj = *(object*)objptr; # fragliches Objekt   \
  4002.                 if (!in_old_generation(obj,type,?))                           \
  4003.                   # Σltere Generation -> nichts zu tun (Objekt blieb stehen)  \
  4004.                   if (is_varobject_heap(type))                                \
  4005.                     # Objekt variabler LΣnge                                  \
  4006.                     { if (marked(ThePointer(obj))) # markiert?                \
  4007.                         *(object*)objptr = type_untype_object(type,untype(*(object*)ThePointer(obj))); \
  4008.                     }                                                         \
  4009.                     else                                                      \
  4010.                     # Zwei-Pointer-Objekt                                     \
  4011.                     { # Fⁿr spΣtere Aktualisierung in dessen Liste einhΣngen: \
  4012.                       *(object*)objptr = *(object*)ThePointer(obj);           \
  4013.                       *(object*)ThePointer(obj) = with_mark_bit(type_pointer_object(0,objptr)); \
  4014.                     }                                                         \
  4015.           }   }
  4016.       #endif
  4017.     #endif
  4018.   # Durchlaufen durch alle LISP-Objekte und aktualisieren:
  4019.     # Pointer im LISP-Stack aktualisieren:
  4020.       local void aktualisiere_STACK (void);
  4021.       local void aktualisiere_STACK()
  4022.         { var reg3 object* objptr = &STACK_0; # Pointer, der durch den STACK lΣuft
  4023.           until (eq(*objptr,nullobj)) # bis STACK zu Ende ist:
  4024.             { if ( *((oint*)objptr) & wbit(frame_bit_o) ) # Beginnt hier ein Frame?
  4025.                { if (( *((oint*)objptr) & wbit(skip2_bit_o) ) == 0) # Ohne skip2-Bit?
  4026.                   objptr skipSTACKop 2; # ja -> um 2 weiterrⁿcken
  4027.                   else
  4028.                   objptr skipSTACKop 1; # nein -> um 1 weiterrⁿcken
  4029.                }
  4030.                else
  4031.                { # normales Objekt, aktualisieren:
  4032.                  switch (mtypecode(*objptr))
  4033.                    { case_symbolflagged: # Symbol mit evtl. Flags
  4034.                        #ifndef NO_symbolflags
  4035.                        { var reg6 object obj1 = *objptr;
  4036.                          var reg4 object obj2 = symbol_without_flags(obj1);
  4037.                          var reg5 oint flags = as_oint(obj1) ^ as_oint(obj2);
  4038.                          *objptr = obj2; # vorerst Flags l÷schen
  4039.                          aktualisiere(objptr); # dann aktualisieren
  4040.                          *(oint*)objptr |= flags; # dann Flags wieder rein
  4041.                          break;
  4042.                        }
  4043.                        #endif
  4044.                      default: aktualisiere(objptr); break;
  4045.                    }
  4046.                  objptr skipSTACKop 1; # weiterrⁿcken
  4047.         }   }  }
  4048.     # Die folgenden Macros rufen den Macro aktualisiere() auf.
  4049.     # Programmkonstanten aktualisieren:
  4050.       #define aktualisiere_subr_tab()  \
  4051.         for_all_subrs(                                                   \
  4052.           { var reg3 object* p = (object*)((aint)ptr+subr_const_offset); \
  4053.             var reg4 uintC c;                                            \
  4054.             dotimespC(c,subr_const_anz, { aktualisiere(p); p++; } );     \
  4055.           }                                                              \
  4056.           );
  4057.       #define aktualisiere_symbol_tab()  \
  4058.         for_all_constsyms( # symbol_tab durchgehen  \
  4059.           { var reg3 object* p;                     \
  4060.             p = &ptr->symvalue; aktualisiere(p);    \
  4061.             p = &ptr->symfunction; aktualisiere(p); \
  4062.             p = &ptr->proplist; aktualisiere(p);    \
  4063.             p = &ptr->pname; aktualisiere(p);       \
  4064.             p = &ptr->homepackage; aktualisiere(p); \
  4065.           }                                         \
  4066.           );
  4067.       #define aktualisiere_object_tab()  \
  4068.         for_all_constobjs( aktualisiere(objptr); ); # object_tab durchgehen
  4069.       #define aktualisiere_tab()  \
  4070.         { aktualisiere_subr_tab();   \
  4071.           aktualisiere_symbol_tab(); \
  4072.           aktualisiere_object_tab(); \
  4073.         }
  4074.     # Pointer in den Cons-Zellen aktualisieren:
  4075.       #define aktualisiere_conses()  \
  4076.         for_each_cons_page(page,                      \
  4077.           { var reg3 aint objptr = page->page_start;  \
  4078.             var reg4 aint objptrend = page->page_end; \
  4079.             # alle Pointer im (neuen) CONS-Bereich start <= Adresse < end aktualisieren: \
  4080.             until (objptr==objptrend)                 \
  4081.               { aktualisiere((object*)objptr);        \
  4082.                 objptr += sizeof(object);             \
  4083.                 aktualisiere((object*)objptr);        \
  4084.                 objptr += sizeof(object);             \
  4085.           }   }                                       \
  4086.           );
  4087.     # Pointer in den Objekten variabler LΣnge aktualisieren:
  4088.     #   #define aktualisiere_page ...
  4089.     #   aktualisiere_varobjects();
  4090.     #   #undef aktualisiere_page
  4091.       #define aktualisiere_page_normal(page,aktualisierer)  \
  4092.         { var reg2 aint ptr = page->page_start;                        \
  4093.           var reg6 aint ptrend = page->page_end;                       \
  4094.           # alle Objekte mit Adresse >=ptr, <ptrend durchgehen:        \
  4095.           until (ptr==ptrend) # solange bis ptr am Ende angekommen ist \
  4096.             { # nΣchstes Objekt mit Adresse ptr (< ptrend) durchgehen: \
  4097.               aktualisierer(typecode_at(ptr)); # und weiterrⁿcken      \
  4098.         }   }
  4099.       # aktualisiert das Objekt bei 'ptr', dessen Typcode durch 'type_expr'
  4100.       # gegeben wird, und rⁿckt ptr weiter:
  4101.       #ifdef SPVW_MIXED
  4102.       #define aktualisiere_varobject(type_expr)  \
  4103.         { var reg5 tint type = (type_expr); # Typinfo                                         \
  4104.           var reg7 uintL laenge = calc_speicher_laenge(ptr); # LΣnge bestimmen                \
  4105.           var reg8 aint newptr = ptr+laenge; # Zeiger auf nΣchstes Objekt                     \
  4106.           # Fallunterscheidung nach:                                                          \
  4107.             # Symbol; Simple-Vector; Nicht-simpler Array;                                     \
  4108.             # Record (insbes. Hash-Table); Rest.                                              \
  4109.           switch (type)                                                                       \
  4110.             { case_symbolwithflags:                                                           \
  4111.                 # Symbol: alle Pointer innerhalb eines Symbols aktualisieren                  \
  4112.                 { var reg3 object* p = (object*)pointerplus(ptr,symbol_objects_offset);       \
  4113.                   var reg4 uintC count;                                                       \
  4114.                   dotimespC(count,((sizeof(symbol_)-symbol_objects_offset)/sizeof(object)),   \
  4115.                     { aktualisiere(p); p++; } );                                              \
  4116.                 }                                                                             \
  4117.                 break;                                                                        \
  4118.               case_svector:                                                                   \
  4119.                 # Simple-vector: alle Pointer innerhalb eines Simple-vector aktualisieren     \
  4120.                 { var reg3 uintL count = ((Svector)ptr)->length;                              \
  4121.                   if (!(count==0))                                                            \
  4122.                     {var reg4 object* p = &((Svector)ptr)->data[0];                           \
  4123.                      dotimespL(count,count, { aktualisiere(p); p++; } );                      \
  4124.                 }   }                                                                         \
  4125.                 break;                                                                        \
  4126.               case_array1: case_obvector: case_ostring: case_ovector:                         \
  4127.                 # nicht-simpler Array: Datenvektor aktualisieren                              \
  4128.                 { var reg3 object* p = &((Array)ptr)->data;                                   \
  4129.                   aktualisiere(p);                                                            \
  4130.                 }                                                                             \
  4131.                 break;                                                                        \
  4132.               case_record:                                                                    \
  4133.                 # Record: alle Pointer innerhalb eines Record aktualisieren                   \
  4134.                 { # Beim Aktualisieren von Pointern verliert der Aufbau von                   \
  4135.                   # Hash-Tables seine Gⁿltigkeit (denn die Hashfunktion eines                 \
  4136.                   # Objekts hΣngt von seiner Adresse ab, die sich ja jetzt                    \
  4137.                   # verΣndert).                                                               \
  4138.                   if ((sintB)(((Record)ptr)->rectype) < 0) # eine Hash-Table ?                \
  4139.                     { mark_ht_invalid((Hashtable)ptr); } # ja -> fⁿr Reorganisation vormerken \
  4140.                  {var reg3 uintC count;                                                       \
  4141.                   var reg4 object* p = &((Record)ptr)->recdata[0];                            \
  4142.                   dotimespC(count,((Record)ptr)->reclength, { aktualisiere(p); p++; } );      \
  4143.                 }}                                                                            \
  4144.                 break;                                                                        \
  4145.               default:                                                                        \
  4146.                 break; # alle anderen enthalten keine zu aktualisierenden Pointer             \
  4147.                        # -> nichts tun                                                        \
  4148.             }                                                                                 \
  4149.           # zum nΣchsten Objekt weiterrⁿcken                                                  \
  4150.           ptr=newptr;                                                                         \
  4151.         }
  4152.       #define aktualisiere_varobjects()  \
  4153.         for_each_varobject_page(page,                    \
  4154.           aktualisiere_page(page,aktualisiere_varobject) \
  4155.           );
  4156.       #endif
  4157.       #ifdef SPVW_PURE
  4158.       #define aktualisiere_symbol(type_expr)  # ignoriert type_expr \
  4159.         { var reg7 uintL laenge = speicher_laenge_symbol((void*)ptr); # LΣnge bestimmen \
  4160.           var reg8 aint newptr = ptr+laenge; # Zeiger auf nΣchstes Objekt               \
  4161.           # Symbol: alle Pointer innerhalb eines Symbols aktualisieren                  \
  4162.           { var reg3 object* p = (object*)pointerplus(ptr,symbol_objects_offset);       \
  4163.             var reg4 uintC count;                                                       \
  4164.             dotimespC(count,((sizeof(symbol_)-symbol_objects_offset)/sizeof(object)),   \
  4165.               { aktualisiere(p); p++; } );                                              \
  4166.           }                                                                             \
  4167.           ptr=newptr; # zum nΣchsten Objekt weiterrⁿcken                                \
  4168.         }
  4169.       #define aktualisiere_svector(type_expr)  # ignoriert type_expr \
  4170.         { var reg7 uintL laenge = speicher_laenge_svector((void*)ptr); # LΣnge bestimmen \
  4171.           var reg8 aint newptr = ptr+laenge; # Zeiger auf nΣchstes Objekt                \
  4172.           # Simple-vector: alle Pointer innerhalb eines Simple-vector aktualisieren      \
  4173.           { var reg3 uintL count = ((Svector)ptr)->length;                               \
  4174.             if (!(count==0))                                                             \
  4175.               {var reg4 object* p = &((Svector)ptr)->data[0];                            \
  4176.                dotimespL(count,count, { aktualisiere(p); p++; } );                       \
  4177.           }   }                                                                          \
  4178.           ptr=newptr; # zum nΣchsten Objekt weiterrⁿcken                                 \
  4179.         }
  4180.       #define aktualisiere_array(type_expr)  # ignoriert type_expr \
  4181.         { var reg7 uintL laenge = speicher_laenge_array((void*)ptr); # LΣnge bestimmen \
  4182.           var reg8 aint newptr = ptr+laenge; # Zeiger auf nΣchstes Objekt              \
  4183.           # nicht-simpler Array: Datenvektor aktualisieren                             \
  4184.           { var reg3 object* p = &((Array)ptr)->data;                                  \
  4185.             aktualisiere(p);                                                           \
  4186.           }                                                                            \
  4187.           ptr=newptr; # zum nΣchsten Objekt weiterrⁿcken                               \
  4188.         }
  4189.       #define aktualisiere_record(type_expr)  # ignoriert type_expr \
  4190.         { var reg7 uintL laenge = speicher_laenge_record((void*)ptr); # LΣnge bestimmen \
  4191.           var reg8 aint newptr = ptr+laenge; # Zeiger auf nΣchstes Objekt               \
  4192.           # Record: alle Pointer innerhalb eines Record aktualisieren                   \
  4193.           { # Beim Aktualisieren von Pointern verliert der Aufbau von                   \
  4194.             # Hash-Tables seine Gⁿltigkeit (denn die Hashfunktion eines                 \
  4195.             # Objekts hΣngt von seiner Adresse ab, die sich ja jetzt                    \
  4196.             # verΣndert).                                                               \
  4197.             if ((sintB)(((Record)ptr)->rectype) < 0) # eine Hash-Table ?                \
  4198.               { mark_ht_invalid((Hashtable)ptr); } # ja -> fⁿr Reorganisation vormerken \
  4199.            {var reg3 uintC count;                                                       \
  4200.             var reg4 object* p = &((Record)ptr)->recdata[0];                            \
  4201.             dotimespC(count,((Record)ptr)->reclength, { aktualisiere(p); p++; } );      \
  4202.           }}                                                                            \
  4203.           ptr=newptr; # zum nΣchsten Objekt weiterrⁿcken                                \
  4204.         }
  4205.       #define aktualisiere_varobjects()  \
  4206.         for_each_varobject_page(page,                                               \
  4207.           { # Fallunterscheidung nach:                                              \
  4208.               # Symbol; Simple-Vector; Nicht-simpler Array;                         \
  4209.               # Record (insbes. Hash-Table); Rest.                                  \
  4210.             switch (heapnr)                                                         \
  4211.               { case_symbol:                                                        \
  4212.                   aktualisiere_page(page,aktualisiere_symbol); break;               \
  4213.                 case_svector:                                                       \
  4214.                   aktualisiere_page(page,aktualisiere_svector); break;              \
  4215.                 case_array1: case_obvector: case_ostring: case_ovector:             \
  4216.                   aktualisiere_page(page,aktualisiere_array); break;                \
  4217.                 case_record:                                                        \
  4218.                   aktualisiere_page(page,aktualisiere_record); break;               \
  4219.                 default:                                                            \
  4220.                   break; # alle anderen enthalten keine zu aktualisierenden Pointer \
  4221.                          # -> nichts tun                                            \
  4222.           }   }                                                                     \
  4223.           );
  4224.       #endif
  4225.     #ifdef GENERATIONAL_GC
  4226.     # Pointer in den Objekten der alten Generation aktualisieren:
  4227.       local void aktualisiere_old_generation (void);
  4228.       local void aktualisiere_at (object* ptr);
  4229.       local void aktualisiere_at(ptr)
  4230.         var reg3 object* ptr;
  4231.         { aktualisiere(ptr); }
  4232.       local void aktualisiere_old_generation()
  4233.         { var reg7 uintL heapnr;
  4234.           for (heapnr=0; heapnr<heapcount; heapnr++)
  4235.             if (is_heap_containing_objects(heapnr)) # Objekte, die keine Pointer enthalten,
  4236.                                                     # braucht man nicht zu durchlaufen.
  4237.               { var reg6 Heap* heap = &mem.heaps[heapnr];
  4238.                 var reg4 aint gen0_start = heap->heap_gen0_start;
  4239.                 var reg5 aint gen0_end = heap->heap_gen0_end;
  4240.                 if (gen0_start < gen0_end)
  4241.                   if (heap->physpages==NULL)
  4242.                     { walk_area_(heapnr,gen0_start,gen0_end,aktualisiere_at); } # fallback
  4243.                     else
  4244.                     { var reg3 physpage_state* physpage = heap->physpages;
  4245.                       do { if ((physpage->protection == PROT_NONE)
  4246.                                || (physpage->protection == PROT_READ)
  4247.                               )
  4248.                              # Cache ausnutzen, gecachte Pointer aktualisieren:
  4249.                              { var reg2 uintL count = physpage->cache_size;
  4250.                                if (count > 0)
  4251.                                  { var reg1 old_new_pointer* ptr = physpage->cache;
  4252.                                    dotimespL(count,count, { aktualisiere(&ptr->o); ptr++; } );
  4253.                                    if (!(physpage->protection == PROT_NONE))
  4254.                                      { xmprotect(gen0_start,physpagesize,PROT_NONE);
  4255.                                        physpage->protection = PROT_NONE;
  4256.                              }   }   }
  4257.                              else
  4258.                              # ganzen Page-Inhalt aktualisieren:
  4259.                              { walk_physpage_(heapnr,physpage,gen0_start+physpagesize,gen0_end,aktualisiere_at); }
  4260.                            gen0_start += physpagesize;
  4261.                            physpage++;
  4262.                          }
  4263.                          while (gen0_start < gen0_end);
  4264.         }     }     }
  4265.       #undef aktualisiere_at
  4266.     #endif
  4267.  
  4268. # Zweite SWEEP-Phase:
  4269.   # Verschiebung eines Objekts variabler LΣnge, p1 und p2 weiterrⁿcken:
  4270.   # move_aligned_p1_p2(count);
  4271.   #if (Varobject_alignment==1)
  4272.     #define uintV  uintB
  4273.   #elif (Varobject_alignment==2)
  4274.     #define uintV  uintW
  4275.   #elif (Varobject_alignment==4)
  4276.     #define uintV  uintL
  4277.   #elif (Varobject_alignment==8)
  4278.     #define uintV  uintL2
  4279.   #else
  4280.     #error "Unbekannter Wert von 'Varobject_alignment'!"
  4281.   #endif
  4282.   #ifdef GNU # so lΣ▀t sich's besser optimieren
  4283.     #ifdef fast_dotimesL
  4284.       #define move_aligned_p1_p2(count)  \
  4285.         dotimespL(count,count/Varobject_alignment, *((uintV*)p2)++ = *((uintV*)p1)++; )
  4286.     #else
  4287.       #define move_aligned_p1_p2(count)  \
  4288.         do { *((uintV*)p2)++ = *((uintV*)p1)++; count -= Varobject_alignment; } until (count==0)
  4289.     #endif
  4290.   #else # andere Compiler akzeptieren ((type*)p)++ nicht.
  4291.     # Wie effizient ist das hier ??
  4292.     #define move_aligned_p1_p2(count)  \
  4293.       do { *(uintV*)p2 = *(uintV*)p1;                            \
  4294.            p1 += Varobject_alignment; p2 += Varobject_alignment; \
  4295.            count -= Varobject_alignment;                         \
  4296.          }                                                                              \
  4297.          until (count==0)
  4298.   #endif
  4299.   # Die Objekte variabler LΣnge werden an die vorher berechneten
  4300.   # neuen PlΣtze geschoben.
  4301.   #ifdef SPVW_PURE
  4302.   local void gc_sweep2_varobject_page (Page* page, uintL heapnr);
  4303.   local void gc_sweep2_varobject_page PARM2(page,heapnr,
  4304.     var reg5 Page* page,
  4305.     var reg6 uintL heapnr)
  4306.   #else
  4307.   local void gc_sweep2_varobject_page (Page* page);
  4308.   local void gc_sweep2_varobject_page PARM1(page,
  4309.     var reg5 Page* page)
  4310.   #endif
  4311.     # Von unten nach oben durchgehen und dabei runterschieben:
  4312.     { var reg1 aint p1 = (aint)type_pointable(0,page->page_gcpriv.firstmarked); # Source-Pointer, erstes markiertes Objekt
  4313.       var reg4 aint p1end = page->page_end;
  4314.       var reg2 aint p2 = page->page_start; # Ziel-Pointer
  4315.       var_speicher_laenge_;
  4316.       until (p1==p1end) # obere Grenze erreicht -> fertig
  4317.         { # nΣchstes Objekt hat Adresse p1
  4318.           if (marked(p1)) # markiert?
  4319.             { unmark(p1); # Markierung l÷schen
  4320.               # Objekt behalten und verschieben:
  4321.              {var reg3 uintL count = calc_speicher_laenge(p1); # LΣnge (durch Varobject_alignment teilbar, >0)
  4322.               if (!(p1==p2)) # falls Verschiebung n÷tig
  4323.                 { move_aligned_p1_p2(count); } # verschieben und weiterrⁿcken
  4324.                 else # sonst nur weiterrⁿcken:
  4325.                 { p1 += count; p2 += count; }
  4326.             }}
  4327.             else
  4328.             { p1 = (aint)type_pointable(0,*(object*)p1); } # mit Pointer (Typinfo=0) zum nΣchsten markierten Objekt
  4329.         }
  4330.       page->page_end = p2; # obere Grenze der Objekte variabler LΣnge neu setzen
  4331.     }
  4332.  
  4333. #ifdef GENERATIONAL_GC
  4334.  
  4335.   # Baut einen Cache aller Pointer in der alten Generation.
  4336.   # Die neue Generation ist leer; Pointer in die neue Generation gibt es daher keine!
  4337.   local void build_old_generation_cache (uintL heapnr);
  4338.   local void build_old_generation_cache(heapnr)
  4339.     var reg10 uintL heapnr;
  4340.     { if (is_heap_containing_objects(heapnr)) # Objekte, die keine Pointer enthalten, brauchen keinen Cache.
  4341.         { var reg8 Heap* heap = &mem.heaps[heapnr];
  4342.           var reg6 aint gen0_start = heap->heap_gen0_start; # page-aligned
  4343.           var reg7 aint gen0_end = heap->heap_gen0_end;
  4344.           var reg10 aint gen1_start = heap->heap_gen1_start; # page-aligned
  4345.          {var reg9 uintL physpage_count = (gen1_start - gen0_start) >> physpageshift;
  4346.           if (physpage_count==0)
  4347.             { xfree(heap->physpages); heap->physpages = NULL; }
  4348.             else
  4349.             { heap->physpages = xrealloc(heap->physpages,physpage_count*sizeof(physpage_state));
  4350.               if (!(heap->physpages==NULL))
  4351.                 { # Wenn wir fertig sind, wird sowohl Cache als auch Speicherinhalt
  4352.                   # gⁿltig sein:
  4353.                   xmprotect(gen0_start, gen1_start-gen0_start, PROT_READ);
  4354.                   # heap->physpages[0..physpage_count-1] fⁿllen:
  4355.                   { var reg1 physpage_state* physpage = heap->physpages;
  4356.                     var reg2 uintL count;
  4357.                     dotimespL(count,physpage_count,
  4358.                       { physpage->protection = PROT_READ;
  4359.                         physpage->cache_size = 0; physpage->cache = NULL;
  4360.                         physpage++;
  4361.                       });
  4362.                   }
  4363.                   if (is_cons_heap(heapnr))
  4364.                     # Conses u.Σ.
  4365.                     { # Von gen0_start bis gen0_end sind alles Pointer.
  4366.                       # Alle Seiten bis auf die letzte voll, die letzte teilweise voll.
  4367.                       var reg1 physpage_state* physpage = heap->physpages;
  4368.                       var reg2 uintL count;
  4369.                       dotimesL(count,physpage_count-1,
  4370.                         { # fⁿr i=0,1,...:
  4371.                           #   gen0_start = heap->heap_gen0_start + i*physpagesize
  4372.                           #   physpage = &heap->physpages[i]
  4373.                           physpage->continued_addr = (object*)gen0_start;
  4374.                           physpage->continued_count = physpagesize/sizeof(object);
  4375.                           gen0_start += physpagesize;
  4376.                           physpage->firstobject = gen0_start;
  4377.                           physpage++;
  4378.                         });
  4379.                       physpage->continued_addr = (object*)gen0_start;
  4380.                       physpage->continued_count = (gen0_end-gen0_start)/sizeof(object);
  4381.                       physpage->firstobject = gen0_end;
  4382.                     }
  4383.                     else
  4384.                     # is_varobject_heap(heapnr), Objekte variabler LΣnge
  4385.                     { var reg1 physpage_state* physpage = heap->physpages;
  4386.                       var reg5 aint objptr = gen0_start;
  4387.                       # Fⁿr i=0,1,... ist
  4388.                       #   gen0_start = heap->heap_gen0_start + i*physpagesize
  4389.                       #   physpage = &heap->physpages[i]
  4390.                       # Mit wachsendem i geht man von einer Seite zur nΣchsten.
  4391.                       # Gleichzeitig geht man von einem Objekt zum nΣchsten und markiert
  4392.                       # alle Pointer zwischen objptr (Pointer auf das aktuelle Objekt)
  4393.                       # und nextptr (Pointer auf das nΣchste Objekt). Glⁿcklicherweise
  4394.                       # kommen in allen unseren Objekten die Pointer am Stⁿck:
  4395.                       # ab ptr kommen count Pointer.
  4396.                       # Das Intervall ptr...ptr+count*sizeof(object) wird nun zerlegt.
  4397.                       #ifdef SPVW_PURE
  4398.                       switch (heapnr)
  4399.                         { case_symbol: # Symbol
  4400.                             physpage->continued_addr = (object*)gen0_start; # irrelevant
  4401.                             physpage->continued_count = 0;
  4402.                             physpage->firstobject = gen0_start;
  4403.                             gen0_start += physpagesize; physpage++;
  4404.                             while (objptr < gen0_end)
  4405.                               { var reg4 aint nextptr = objptr + size_symbol();
  4406.                                 # Hier ist gen0_start-physpagesize <= objptr < gen0_start.
  4407.                                 if (nextptr >= gen0_start)
  4408.                                   { var reg2 aint ptr = objptr+symbol_objects_offset;
  4409.                                     var reg3 uintC count = (sizeof(symbol_)-symbol_objects_offset)/sizeof(object);
  4410.                                     if (ptr < gen0_start)
  4411.                                       { physpage->continued_addr = (object*)gen0_start;
  4412.                                         physpage->continued_count = count - (gen0_start-ptr)/sizeof(object);
  4413.                                       }
  4414.                                       else
  4415.                                       { physpage->continued_addr = (object*)ptr;
  4416.                                         physpage->continued_count = count;
  4417.                                       }
  4418.                                     physpage->firstobject = nextptr;
  4419.                                     # Man ⁿberquert h÷chstens eine Seitengrenze auf einmal.
  4420.                                     gen0_start += physpagesize; physpage++;
  4421.                                   }
  4422.                                 objptr = nextptr;
  4423.                               }
  4424.                             if (!(objptr == gen0_end)) abort();
  4425.                             break;
  4426.                           case_array1: case_obvector: case_ostring: case_ovector: # nicht-simple Arrays:
  4427.                             physpage->continued_addr = (object*)gen0_start; # irrelevant
  4428.                             physpage->continued_count = 0;
  4429.                             physpage->firstobject = gen0_start;
  4430.                             gen0_start += physpagesize; physpage++;
  4431.                             while (objptr < gen0_end)
  4432.                               { var reg3 aint nextptr = objptr + speicher_laenge_array((Array)objptr);
  4433.                                 # Hier ist gen0_start-physpagesize <= objptr < gen0_start.
  4434.                                 if (nextptr >= gen0_start)
  4435.                                   { var reg2 aint ptr = (aint)&((Array)objptr)->data;
  4436.                                     # count = 1;
  4437.                                     if (ptr < gen0_start)
  4438.                                       { physpage->continued_addr = (object*)gen0_start; # irrelevant
  4439.                                         physpage->continued_count = 0;
  4440.                                       }
  4441.                                       else
  4442.                                       { physpage->continued_addr = (object*)ptr;
  4443.                                         physpage->continued_count = 1;
  4444.                                       }
  4445.                                     # Man ⁿberquerte h÷chstens eine Seitengrenze.
  4446.                                     # Danach kommen (bis nextptr) keine Pointer mehr.
  4447.                                     loop
  4448.                                       { physpage->firstobject = nextptr;
  4449.                                         gen0_start += physpagesize; physpage++;
  4450.                                         if (nextptr < gen0_start) break;
  4451.                                         physpage->continued_addr = (object*)gen0_start; # irrelevant
  4452.                                         physpage->continued_count = 0;
  4453.                                       }
  4454.                                   }
  4455.                                 objptr = nextptr;
  4456.                               }
  4457.                             if (!(objptr == gen0_end)) abort();
  4458.                             break;
  4459.                           case_svector: # simple-vector
  4460.                             physpage->continued_addr = (object*)gen0_start; # irrelevant
  4461.                             physpage->continued_count = 0;
  4462.                             physpage->firstobject = gen0_start;
  4463.                             gen0_start += physpagesize; physpage++;
  4464.                             while (objptr < gen0_end)
  4465.                               { var reg3 uintL count = ((Svector)objptr)->length;
  4466.                                 var reg4 aint nextptr = objptr + size_svector(count);
  4467.                                 # Hier ist gen0_start-physpagesize <= objptr < gen0_start.
  4468.                                 if (nextptr >= gen0_start)
  4469.                                   { var reg2 aint ptr = (aint)&((Svector)objptr)->data[0];
  4470.                                     if (ptr < gen0_start)
  4471.                                       { var reg3 uintL count_thispage = (gen0_start-ptr)/sizeof(object);
  4472.                                         if ((Varobject_alignment == sizeof(object)) # das erzwingt count >= count_thispage
  4473.                                             || (count >= count_thispage)
  4474.                                            )
  4475.                                           { count -= count_thispage; }
  4476.                                           else
  4477.                                           { count = 0; }
  4478.                                         ptr = gen0_start;
  4479.                                       }
  4480.                                     do { physpage->continued_addr = (object*)ptr;
  4481.                                          gen0_start += physpagesize;
  4482.                                         {var reg3 uintL count_thispage = (gen0_start-ptr)/sizeof(object);
  4483.                                          if (count >= count_thispage)
  4484.                                            { physpage->continued_count = count_thispage;
  4485.                                              count -= count_thispage;
  4486.                                            }
  4487.                                            else
  4488.                                            { physpage->continued_count = count; count = 0; }
  4489.                                          physpage->firstobject = nextptr;
  4490.                                          physpage++;
  4491.                                          ptr = gen0_start;
  4492.                                        }}
  4493.                                        until (nextptr < gen0_start);
  4494.                                   }
  4495.                                 objptr = nextptr;
  4496.                               }
  4497.                             if (!(objptr == gen0_end)) abort();
  4498.                             break;
  4499.                           case_record: # Record
  4500.                             physpage->continued_addr = (object*)gen0_start; # irrelevant
  4501.                             physpage->continued_count = 0;
  4502.                             physpage->firstobject = gen0_start;
  4503.                             gen0_start += physpagesize; physpage++;
  4504.                             while (objptr < gen0_end)
  4505.                               { var reg3 uintC count = ((Record)objptr)->reclength;
  4506.                                 var reg4 aint nextptr = objptr + size_record(count);
  4507.                                 if (nextptr >= gen0_start)
  4508.                                   { var reg2 aint ptr = (aint)&((Record)objptr)->recdata[0];
  4509.                                     if (ptr < gen0_start)
  4510.                                       { var reg3 uintL count_thispage = (gen0_start-ptr)/sizeof(object);
  4511.                                         if ((Varobject_alignment == sizeof(object)) # das erzwingt count >= count_thispage
  4512.                                             || (count >= count_thispage)
  4513.                                            )
  4514.                                           { count -= count_thispage; }
  4515.                                           else
  4516.                                           { count = 0; }
  4517.                                         ptr = gen0_start;
  4518.                                       }
  4519.                                     do { physpage->continued_addr = (object*)ptr;
  4520.                                          gen0_start += physpagesize;
  4521.                                         {var reg3 uintL count_thispage = (gen0_start-ptr)/sizeof(object);
  4522.                                          if (count >= count_thispage)
  4523.                                            { physpage->continued_count = count_thispage;
  4524.                                              count -= count_thispage;
  4525.                                            }
  4526.                                            else
  4527.                                            { physpage->continued_count = count; count = 0; }
  4528.                                          physpage->firstobject = nextptr;
  4529.                                          physpage++;
  4530.                                          ptr = gen0_start;
  4531.                                        }}
  4532.                                        until (nextptr < gen0_start);
  4533.                                   }
  4534.                                 objptr = nextptr;
  4535.                               }
  4536.                             if (!(objptr == gen0_end)) abort();
  4537.                             break;
  4538.                           default:
  4539.                             # Solche Objekte kommen nicht vor.
  4540.                             abort();
  4541.                         }
  4542.                       #else # SPVW_MIXED
  4543.                       physpage->continued_addr = (object*)gen0_start; # irrelevant
  4544.                       physpage->continued_count = 0;
  4545.                       physpage->firstobject = gen0_start;
  4546.                       gen0_start += physpagesize; physpage++;
  4547.                       while (objptr < gen0_end)
  4548.                         { switch (typecode_at(objptr)) # Typ des nΣchsten Objekts
  4549.                             { case_symbolwithflags: # Symbol
  4550.                                 { var reg4 aint nextptr = objptr + size_symbol();
  4551.                                   # Hier ist gen0_start-physpagesize <= objptr < gen0_start.
  4552.                                   if (nextptr >= gen0_start)
  4553.                                     { var reg2 aint ptr = objptr+symbol_objects_offset;
  4554.                                       var reg3 uintC count = (sizeof(symbol_)-symbol_objects_offset)/sizeof(object);
  4555.                                       if (ptr < gen0_start)
  4556.                                         { physpage->continued_addr = (object*)gen0_start;
  4557.                                           physpage->continued_count = count - (gen0_start-ptr)/sizeof(object);
  4558.                                         }
  4559.                                         else
  4560.                                         { physpage->continued_addr = (object*)ptr;
  4561.                                           physpage->continued_count = count;
  4562.                                         }
  4563.                                       physpage->firstobject = nextptr;
  4564.                                       # Man ⁿberquert h÷chstens eine Seitengrenze auf einmal.
  4565.                                       gen0_start += physpagesize; physpage++;
  4566.                                     }
  4567.                                   objptr = nextptr;
  4568.                                 }
  4569.                                 break;
  4570.                               case_array1: case_obvector: case_ostring: case_ovector: # nicht-simple Arrays:
  4571.                                 { var reg3 aint nextptr = objptr + speicher_laenge((Array)objptr);
  4572.                                   # Hier ist gen0_start-physpagesize <= objptr < gen0_start.
  4573.                                   if (nextptr >= gen0_start)
  4574.                                     { var reg2 aint ptr = (aint)&((Array)objptr)->data;
  4575.                                       # count = 1;
  4576.                                       if (ptr < gen0_start)
  4577.                                         { physpage->continued_addr = (object*)gen0_start; # irrelevant
  4578.                                           physpage->continued_count = 0;
  4579.                                         }
  4580.                                         else
  4581.                                         { physpage->continued_addr = (object*)ptr;
  4582.                                           physpage->continued_count = 1;
  4583.                                         }
  4584.                                       # Man ⁿberquerte h÷chstens eine Seitengrenze.
  4585.                                       # Danach kommen (bis nextptr) keine Pointer mehr.
  4586.                                       loop
  4587.                                         { physpage->firstobject = nextptr;
  4588.                                           gen0_start += physpagesize; physpage++;
  4589.                                           if (nextptr < gen0_start) break;
  4590.                                           physpage->continued_addr = (object*)gen0_start; # irrelevant
  4591.                                           physpage->continued_count = 0;
  4592.                                         }
  4593.                                     }
  4594.                                   objptr = nextptr;
  4595.                                 }
  4596.                                 break;
  4597.                               case_svector: # simple-vector
  4598.                                 { var reg3 uintL count = ((Svector)objptr)->length;
  4599.                                   var reg4 aint nextptr = objptr + size_svector(count);
  4600.                                   # Hier ist gen0_start-physpagesize <= objptr < gen0_start.
  4601.                                   if (nextptr >= gen0_start)
  4602.                                     { var reg2 aint ptr = (aint)&((Svector)objptr)->data[0];
  4603.                                       if (ptr < gen0_start)
  4604.                                         { var reg3 uintL count_thispage = (gen0_start-ptr)/sizeof(object);
  4605.                                           if ((Varobject_alignment == sizeof(object)) # das erzwingt count >= count_thispage
  4606.                                               || (count >= count_thispage)
  4607.                                              )
  4608.                                             { count -= count_thispage; }
  4609.                                             else
  4610.                                             { count = 0; }
  4611.                                           ptr = gen0_start;
  4612.                                         }
  4613.                                       do { physpage->continued_addr = (object*)ptr;
  4614.                                            gen0_start += physpagesize;
  4615.                                           {var reg3 uintL count_thispage = (gen0_start-ptr)/sizeof(object);
  4616.                                            if (count >= count_thispage)
  4617.                                              { physpage->continued_count = count_thispage;
  4618.                                                count -= count_thispage;
  4619.                                              }
  4620.                                              else
  4621.                                              { physpage->continued_count = count; count = 0; }
  4622.                                            physpage->firstobject = nextptr;
  4623.                                            physpage++;
  4624.                                            ptr = gen0_start;
  4625.                                          }}
  4626.                                          until (nextptr < gen0_start);
  4627.                                     }
  4628.                                   objptr = nextptr;
  4629.                                 }
  4630.                                 break;
  4631.                               case_record: # Record
  4632.                                 { var reg3 uintC count = ((Record)objptr)->reclength;
  4633.                                   var reg4 aint nextptr = objptr + size_record(count);
  4634.                                   if (nextptr >= gen0_start)
  4635.                                     { var reg2 aint ptr = (aint)&((Record)objptr)->recdata[0];
  4636.                                       if (ptr < gen0_start)
  4637.                                         { var reg3 uintL count_thispage = (gen0_start-ptr)/sizeof(object);
  4638.                                           if ((Varobject_alignment == sizeof(object)) # das erzwingt count >= count_thispage
  4639.                                               || (count >= count_thispage)
  4640.                                              )
  4641.                                             { count -= count_thispage; }
  4642.                                             else
  4643.                                             { count = 0; }
  4644.                                           ptr = gen0_start;
  4645.                                         }
  4646.                                       do { physpage->continued_addr = (object*)ptr;
  4647.                                            gen0_start += physpagesize;
  4648.                                           {var reg3 uintL count_thispage = (gen0_start-ptr)/sizeof(object);
  4649.                                            if (count >= count_thispage)
  4650.                                              { physpage->continued_count = count_thispage;
  4651.                                                count -= count_thispage;
  4652.                                              }
  4653.                                              else
  4654.                                              { physpage->continued_count = count; count = 0; }
  4655.                                            physpage->firstobject = nextptr;
  4656.                                            physpage++;
  4657.                                            ptr = gen0_start;
  4658.                                          }}
  4659.                                          until (nextptr < gen0_start);
  4660.                                     }
  4661.                                   objptr = nextptr;
  4662.                                 }
  4663.                                 break;
  4664.                               default: # simple-bit-vector, simple-string, bignum, float
  4665.                                 # Keine Pointer.
  4666.                                 objptr += speicher_laenge((Varobject)objptr);
  4667.                                 while (objptr >= gen0_start)
  4668.                                   { physpage->continued_addr = (object*)gen0_start; # irrelevant
  4669.                                     physpage->continued_count = 0;
  4670.                                     physpage->firstobject = objptr;
  4671.                                     gen0_start += physpagesize; physpage++;
  4672.                                   }
  4673.                                 break;
  4674.                         }   }
  4675.                       if (!(objptr == gen0_end)) abort();
  4676.                       #endif
  4677.                     }
  4678.                 }
  4679.     }   }}  }
  4680.  
  4681.   # Baut einen Cache aller Pointer von der alten in die neue Generation.
  4682.   local void rebuild_old_generation_cache (uintL heapnr);
  4683.   local void rebuild_old_generation_cache(heapnr)
  4684.     var reg10 uintL heapnr;
  4685.     { if (is_heap_containing_objects(heapnr)) # Objekte, die keine Pointer enthalten, brauchen keinen Cache.
  4686.         { var reg9 Heap* heap = &mem.heaps[heapnr];
  4687.           var reg6 aint gen0_start = heap->heap_gen0_start;
  4688.           var reg7 aint gen0_end = heap->heap_gen0_end;
  4689.           if ((gen0_start < gen0_end) && !(heap->physpages==NULL))
  4690.             { var reg5 physpage_state* physpage = heap->physpages;
  4691.               do { if (physpage->protection == PROT_READ_WRITE)
  4692.                      { var DYNAMIC_ARRAY(reg8,cache_buffer,old_new_pointer,physpagesize/sizeof(object));
  4693.                        var reg4 old_new_pointer* cache_ptr = &cache_buffer[0];
  4694.                        #define cache_at(obj)  \
  4695.                          { var reg1 tint type = mtypecode(obj);                              \
  4696.                            if (!immediate_type_p(type)) # unverschieblich?                   \
  4697.                              if ((aint)ThePointer(obj) >= mem.heaps[type].heap_gen1_start)   \
  4698.                                # obj ist ein Pointer in die neue Generation -> merken        \
  4699.                                { cache_ptr->p = &(obj); cache_ptr->o = (obj); cache_ptr++; } \
  4700.                          }
  4701.                        walk_physpage(heapnr,physpage,gen0_start+physpagesize,gen0_end,cache_at);
  4702.                        #undef cache_at
  4703.                       {var reg3 uintL cache_size = cache_ptr - &cache_buffer[0];
  4704.                        if (cache_size <= (physpagesize/sizeof(object))/4)
  4705.                          # Wir cachen eine Seite nur, falls maximal 25% mit Pointern auf
  4706.                          # die neue Generation belegt ist. Sonst ist das Anlegen eines Cache
  4707.                          # Platzverschwendung.
  4708.                          { physpage->cache_size = cache_size;
  4709.                            if (cache_size == 0)
  4710.                              { xfree(physpage->cache); physpage->cache = NULL; }
  4711.                              else
  4712.                              { physpage->cache = (old_new_pointer*) xrealloc(physpage->cache,cache_size*sizeof(old_new_pointer));
  4713.                                if (physpage->cache == NULL)
  4714.                                  goto no_cache;
  4715.                                { var reg2 old_new_pointer* ptr1 = &cache_buffer[0];
  4716.                                  var reg1 old_new_pointer* ptr2 = physpage->cache;
  4717.                                  dotimespL(cache_size,cache_size, { *ptr2++ = *ptr1++; } );
  4718.                              } }
  4719.                            xmprotect(gen0_start,physpagesize,PROT_READ);
  4720.                            physpage->protection = PROT_READ;
  4721.                          }
  4722.                          else
  4723.                          { xfree(physpage->cache); physpage->cache = NULL;
  4724.                            no_cache: ;
  4725.                          }
  4726.                        FREE_DYNAMIC_ARRAY(cache_buffer);
  4727.                      }}
  4728.                    gen0_start += physpagesize;
  4729.                    physpage++;
  4730.                  }
  4731.                  while (gen0_start < gen0_end);
  4732.     }   }   }
  4733.  
  4734. #endif
  4735.  
  4736. #if defined(DEBUG_SPVW) && defined(GENERATIONAL_GC)
  4737.   # Kontrolle des Cache der old_new_pointer:
  4738.   #define CHECK_GC_CACHE()  gc_cache_check()
  4739.   local void gc_cache_check (void);
  4740.   local void gc_cache_check()
  4741.     { var reg9 uintL heapnr;
  4742.       for (heapnr=0; heapnr<heapcount; heapnr++)
  4743.         if (is_heap_containing_objects(heapnr))
  4744.           { var reg7 Heap* heap = &mem.heaps[heapnr];
  4745.             var reg3 aint gen0_start = heap->heap_gen0_start;
  4746.             var reg5 aint gen0_end = heap->heap_gen0_end;
  4747.             var reg8 aint gen1_start = heap->heap_gen1_start;
  4748.             var reg6 uintL physpage_count = (gen1_start - gen0_start) >> physpageshift;
  4749.             if (physpage_count > 0)
  4750.               { var reg1 physpage_state* physpage = heap->physpages;
  4751.                 if (!(physpage==NULL))
  4752.                   { var reg4 uintL count;
  4753.                     dotimespL(count,physpage_count,
  4754.                       { var reg2 aint end = gen0_start + physpagesize;
  4755.                         if (gen0_end < end) { end = gen0_end; }
  4756.                         if (physpage->firstobject < end) { end = physpage->firstobject; }
  4757.                         if (!(gen0_start <= (aint)physpage->continued_addr)) abort();
  4758.                         if (!((aint)physpage->continued_addr + physpage->continued_count*sizeof(object) <= end)) abort();
  4759.                         gen0_start += physpagesize;
  4760.                         physpage++;
  4761.                       });
  4762.     }     }   }   }
  4763.   # Kontrolle, ob alle Pointer im Cache aufgefⁿhrt sind und nicht in den Wald zeigen.
  4764.   #define CHECK_GC_GENERATIONAL()  gc_overall_check()
  4765.   local void gc_overall_check (void);
  4766.     # Kontrolle eines einzelnen Pointers:
  4767.     local boolean gc_check_at (object* objptr);
  4768.     local boolean gc_check_at(objptr)
  4769.       var reg5 object* objptr;
  4770.       { var reg4 object obj = *objptr;
  4771.         var reg3 tint type = typecode(obj);
  4772.         #ifdef SPVW_PURE
  4773.         if (is_unused_heap(type))
  4774.           return FALSE;
  4775.         #else
  4776.         if (immediate_type_p(type))
  4777.           return FALSE;
  4778.         #endif
  4779.        {var reg2 aint addr = (aint)ThePointer(obj);
  4780.         var reg1 Heap* heap;
  4781.         #ifdef SPVW_PURE
  4782.         heap = &mem.heaps[type];
  4783.         #else # SPVW_MIXED
  4784.         switch (type)
  4785.           { case_cons: case_ratio: case_complex: heap = &mem.heaps[1]; break;
  4786.             default: heap = &mem.heaps[0]; break;
  4787.           }
  4788.         #endif
  4789.         if ((addr >= heap->heap_gen0_start) && (addr < heap->heap_gen0_end))
  4790.           return FALSE;
  4791.         if ((addr >= heap->heap_gen1_start) && (addr < heap->heap_end))
  4792.           return TRUE; # Pointer in die neue Generation
  4793.         if ((type == symbol_type) && (addr - (aint)&symbol_tab < sizeof(symbol_tab)))
  4794.           return FALSE;
  4795.         abort();
  4796.       }}
  4797.   local void gc_overall_check()
  4798.     { var reg8 uintL heapnr;
  4799.       for (heapnr=0; heapnr<heapcount; heapnr++)
  4800.         if (is_heap_containing_objects(heapnr))
  4801.           { var reg6 Heap* heap = &mem.heaps[heapnr];
  4802.             var reg5 aint gen0_start = heap->heap_gen0_start;
  4803.             var reg7 aint gen0_end = heap->heap_gen0_end;
  4804.             if (gen0_start < gen0_end)
  4805.               if (heap->physpages==NULL)
  4806.                 { walk_area_(heapnr,gen0_start,gen0_end,gc_check_at); } # fallback
  4807.                 else
  4808.                 { var reg4 physpage_state* physpage = heap->physpages;
  4809.                   do { if (physpage->protection == PROT_READ)
  4810.                          # Stimmen die Pointer im Cache und in der Seite ⁿberein?
  4811.                          { var reg3 uintL count = physpage->cache_size;
  4812.                            if (count > 0)
  4813.                              { var reg1 old_new_pointer* ptr = physpage->cache;
  4814.                                var reg2 aint last_p = gen0_start-1;
  4815.                                dotimespL(count,count,
  4816.                                  { if (!eq(*(ptr->p),ptr->o))
  4817.                                      abort();
  4818.                                    if (!(last_p < (aint)ptr->p))
  4819.                                      abort();
  4820.                                    last_p = (aint)ptr->p;
  4821.                                    ptr++;
  4822.                                  });
  4823.                          }   }
  4824.                        gen0_start += physpagesize;
  4825.                        if (physpage->protection == PROT_NONE)
  4826.                          # Cache ausnutzen, gecachte Pointer durchlaufen:
  4827.                          { var reg2 uintL count = physpage->cache_size;
  4828.                            if (count > 0)
  4829.                              { var reg1 old_new_pointer* ptr = physpage->cache;
  4830.                                dotimespL(count,count, { gc_check_at(ptr->p); ptr++; } );
  4831.                          }   }
  4832.                          else
  4833.                          # ganzen Page-Inhalt durchlaufen:
  4834.                          { walk_physpage_(heapnr,physpage,gen0_start,gen0_end,gc_check_at); }
  4835.                        physpage++;
  4836.                      }
  4837.                      while (gen0_start < gen0_end);
  4838.     }     }     }
  4839.   # Zur Fehlersuche: Verwaltungsdaten vor und nach der GC retten.
  4840.   #define SAVE_GC_DATA()  save_gc_data()
  4841.   local void save_gc_data (void);
  4842.   typedef struct gc_data { struct gc_data * next; Heap heaps[heapcount]; } *
  4843.           gc_data_list;
  4844.   local var gc_data_list gc_history;
  4845.   local void save_gc_data()
  4846.     { # Kopiere die aktuellen GC-Daten an den Kopf der Liste gc_history :
  4847.       var reg10 gc_data_list new_data = (struct gc_data *) malloc(sizeof(struct gc_data));
  4848.       if (!(new_data==NULL))
  4849.         { var reg9 uintL heapnr;
  4850.           for (heapnr=0; heapnr<heapcount; heapnr++)
  4851.             { var reg8 Heap* heap = &new_data->heaps[heapnr];
  4852.               *heap = mem.heaps[heapnr];
  4853.               if (!(heap->physpages==NULL))
  4854.                 { var reg7 uintL physpagecount = (heap->heap_gen1_start - heap->heap_gen0_start) >> physpageshift;
  4855.                   var reg6 physpage_state* physpages = NULL;
  4856.                   if (physpagecount > 0)
  4857.                     physpages = (physpage_state*) malloc(physpagecount*sizeof(physpage_state));
  4858.                   if (!(physpages==NULL))
  4859.                     { var reg5 uintL i;
  4860.                       for (i=0; i<physpagecount; i++)
  4861.                         { physpages[i] = heap->physpages[i];
  4862.                           if (!(physpages[i].cache==NULL))
  4863.                             { var reg4 uintC cache_size = physpages[i].cache_size;
  4864.                               if (cache_size > 0)
  4865.                                 { var reg2 old_new_pointer* cache = (old_new_pointer*) malloc(cache_size*sizeof(old_new_pointer));
  4866.                                   if (!(cache==NULL))
  4867.                                     { var reg3 old_new_pointer* old_cache = physpages[i].cache;
  4868.                                       var reg1 uintC j;
  4869.                                       for (j=0; j<cache_size; j++)
  4870.                                         { cache[j] = old_cache[j]; }
  4871.                                     }
  4872.                                   physpages[i].cache = cache;
  4873.                     }   }   }   }
  4874.                   heap->physpages = physpages;
  4875.             }   }
  4876.           new_data->next = gc_history;
  4877.           gc_history = new_data;
  4878.     }   }
  4879. #else
  4880.   #define CHECK_GC_CACHE()
  4881.   #define CHECK_GC_GENERATIONAL()
  4882.   #define SAVE_GC_DATA()
  4883. #endif
  4884.  
  4885. #if defined(DEBUG_SPVW) && !defined(GENERATIONAL_GC)
  4886.   # Kontrolle, ob auch alles unmarkiert ist:
  4887.   #define CHECK_GC_UNMARKED()  gc_unmarkcheck()
  4888.   local void gc_unmarkcheck (void);
  4889.   local void gc_unmarkcheck()
  4890.     { for_each_varobject_page(page,
  4891.         # Von unten nach oben durchgehen:
  4892.         { var reg1 aint p1 = page->page_start;
  4893.           var reg4 aint p1end = page->page_end;
  4894.           var_speicher_laenge_;
  4895.           until (p1==p1end) # obere Grenze erreicht -> fertig
  4896.             { # nΣchstes Objekt hat Adresse p1
  4897.               if (marked(p1)) # markiert?
  4898.                 { asciz_out("\nObjekt 0x"); hex_out(p1); asciz_out(" markiert!!\n");
  4899.                   abort();
  4900.                 }
  4901.               p1 += calc_speicher_laenge(p1);
  4902.         }   }
  4903.         );
  4904.       for_each_cons_page(page,
  4905.         # Von unten nach oben durchgehen:
  4906.         { var reg1 aint p1 = page->page_start;
  4907.           var reg4 aint p1end = page->page_end;
  4908.           until (p1==p1end) # obere Grenze erreicht -> fertig
  4909.             { # nΣchstes Objekt hat Adresse p1
  4910.               if (marked(p1)) # markiert?
  4911.                 { asciz_out("\nObjekt 0x"); hex_out(p1); asciz_out(" markiert!!\n");
  4912.                   abort();
  4913.                 }
  4914.               p1 += sizeof(cons_);
  4915.         }   }
  4916.         );
  4917.     }
  4918. #else
  4919.   #define CHECK_GC_UNMARKED()
  4920. #endif
  4921.  
  4922. #ifdef DEBUG_SPVW
  4923.   # Kontrolle gegen Nullpointer:
  4924.   #define CHECK_NULLOBJ()  nullobjcheck(FALSE)
  4925.   local void nullobjcheck (boolean in_gc);
  4926.   local void nullobjcheck_range (aint p1, aint p1end, boolean in_gc);
  4927.   local void nullobjcheck_range(p1,p1end,in_gc)
  4928.     var reg1 aint p1;
  4929.     var reg2 aint p1end;
  4930.     var reg3 boolean in_gc;
  4931.     { until (p1==p1end) # obere Grenze erreicht -> fertig
  4932.         { # nΣchstes Objekt hat Adresse p1
  4933.           if (eq(((Cons)p1)->cdr,nullobj) || eq(((Cons)p1)->car,nullobj))
  4934.             if (!(in_gc && eq(((Cons)p1)->cdr,nullobj) && eq(((Cons)p1)->car,nullobj)))
  4935.               abort();
  4936.           p1 += sizeof(cons_);
  4937.     }   }
  4938.   local void nullobjcheck(in_gc)
  4939.     var reg4 boolean in_gc;
  4940.     { # Von unten nach oben durchgehen:
  4941.       #ifdef GENERATIONAL_GC
  4942.       for_each_cons_heap(heap,
  4943.         { nullobjcheck_range(heap->heap_gen0_start,heap->heap_gen0_end,in_gc);
  4944.           nullobjcheck_range(heap->heap_gen1_start,heap->heap_end,in_gc);
  4945.         });
  4946.       #else
  4947.       for_each_cons_page(page,
  4948.         { nullobjcheck_range(page->page_start,page->page_end,in_gc); });
  4949.       #endif
  4950.     }
  4951. #else
  4952.   #define CHECK_NULLOBJ()
  4953. #endif
  4954.  
  4955. #ifdef SPVW_PAGES
  4956.   # ▄berflⁿssige Pages freigeben:
  4957.   # Falls nach einer GC der Platz, der uns in mem.free_pages zur Verfⁿgung
  4958.   # steht, mehr als 25% dessen ausmacht, was wir momentan brauchen, wird der
  4959.   # Rest ans Betriebssystem zurⁿckgegeben.
  4960.   local void free_some_unused_pages (void);
  4961.   local void free_some_unused_pages()
  4962.     { var reg5 uintL needed_space = floor(mem.last_gcend_space,4); # 25%
  4963.       var reg4 uintL accu_space = 0;
  4964.       var reg2 Pages* pageptr = &mem.free_pages;
  4965.       var reg1 Pages page = *pageptr;
  4966.       until (page==NULL)
  4967.         { var reg3 Pages nextpage = page->page_gcpriv.next;
  4968.           if (accu_space < needed_space)
  4969.             # page behalten
  4970.             { accu_space += page->page_room;
  4971.               pageptr = (Pages*)&page->page_gcpriv.next; page = nextpage;
  4972.             }
  4973.             else
  4974.             # page freigeben
  4975.             { free_page(page); page = *pageptr = nextpage; }
  4976.     }   }
  4977. #endif
  4978.  
  4979. # GC-Timer ein- und ausschalten: gc_timer_on(); ... gc_timer_off();
  4980. # Die dazwischen verstrichene Zeit wird auf gc_time addiert.
  4981.   #ifndef HAVE_RUN_TIME
  4982.     #define gc_timer_on()  \
  4983.       { var internal_time gcstart_time = get_time(); # aktuelle Zeit abgreifen und retten
  4984.     #define gc_timer_off()  \
  4985.         gc_time += get_time()-gcstart_time; \
  4986.       }
  4987.   #endif
  4988.   #if defined(TIME_UNIX) || defined(TIME_UNIX_TIMES)
  4989.     #define gc_timer_on()  \
  4990.       { var internal_time gcstart_time; \
  4991.         get_run_time(&gcstart_time); # aktuelle verbrauchte Zeit abfragen und retten
  4992.     #define gc_timer_off()  \
  4993.        {var internal_time gcend_time;                           \
  4994.         get_run_time(&gcend_time);                              \
  4995.         # Differenz von gcend_time und gcstart_time bilden:     \
  4996.         sub_internal_time(gcend_time,gcstart_time, gcend_time); \
  4997.         # diese Differenz zu gc_time addieren:                  \
  4998.         add_internal_time(gc_time,gcend_time, gc_time);         \
  4999.       }}
  5000.   #endif
  5001.  
  5002. # GC-bedingt Signale disablen: gc_signalblock_on(); ... gc_signalblock_off();
  5003.   #if defined(HAVE_SIGNALS) && defined(SIGWINCH) && !defined(NO_ASYNC_INTERRUPTS)
  5004.     # Signal SIGWINCH blockieren, denn eine VerΣnderung des Wertes von
  5005.     # SYS::*PRIN-LINELENGTH* k÷nnen wir wΣhrend der GC nicht brauchen.
  5006.     # Dann Signal SIGWINCH wieder freigeben.
  5007.     #define gc_signalblock_on()  signalblock_on(SIGWINCH)
  5008.     #define gc_signalblock_off()  signalblock_off(SIGWINCH)
  5009.   #else
  5010.     #define gc_signalblock_on()
  5011.     #define gc_signalblock_off()
  5012.   #endif
  5013.  
  5014. # GC-bedingt ImmutabilitΣt von Objekten aufheben:
  5015.   #ifndef MULTIMAP_MEMORY
  5016.     #define immutable_off()
  5017.     #define immutable_on()
  5018.   #endif
  5019.  
  5020. # Normale Garbage Collection durchfⁿhren:
  5021.   local void gar_col_normal(void);
  5022.   local void gar_col_normal()
  5023.     { var uintL gcstart_space; # belegter Speicher bei GC-Start
  5024.       var uintL gcend_space; # belegter Speicher bei GC-Ende
  5025.       #ifdef GC_CLOSES_FILES
  5026.       var object files_to_close; # Liste der zu schlie▀enden Files
  5027.       #endif
  5028.       set_break_sem_1(); # BREAK wΣhrend Garbage Collection sperren
  5029.       immutable_off(); # immutable Objekte werden jetzt modifizierbar
  5030.       gc_signalblock_on(); # Signale wΣhrend Garbage Collection sperren
  5031.       gc_timer_on();
  5032.       gcstart_space = used_space(); # belegten Speicherplatz ermitteln
  5033.       #ifdef ATARI
  5034.       BIOS_Bell(); # Ton ausgeben
  5035.       #endif
  5036.       #ifdef WINDOWS
  5037.       windows_note_gc_start();
  5038.       #endif
  5039.       #ifdef HAVE_VADVISE
  5040.         begin_system_call();
  5041.         vadvise(VA_ANOM); # Paging-Verhalten wird jetzt etwas ungew÷hnlich
  5042.         end_system_call();
  5043.       #endif
  5044.       CHECK_GC_UNMARKED(); CHECK_NULLOBJ(); CHECK_GC_CACHE(); CHECK_GC_GENERATIONAL(); SAVE_GC_DATA();
  5045.       #ifdef SPVW_PAGES
  5046.         { var reg4 uintL heapnr;
  5047.           for (heapnr=0; heapnr<heapcount; heapnr++)
  5048.             { AVL_map(mem.heaps[heapnr].inuse,page,
  5049.                       page->page_room += page->page_end;
  5050.                      );
  5051.               # In page_room steht jetzt jeweils das Ende des benutzbaren Speichers.
  5052.         }   }
  5053.       #endif
  5054.       #ifdef GENERATIONAL_GC
  5055.       if (generation == 0)
  5056.         # Alte Generation mit Hilfe des Cache auf den aktuellen Stand bringen:
  5057.         { prepare_old_generation(); }
  5058.         else
  5059.         # Nur die neue Generation behandeln. Alte Generation verstecken:
  5060.         { var reg4 uintL heapnr;
  5061.           for (heapnr=0; heapnr<heapcount; heapnr++)
  5062.             mem.heaps[heapnr].heap_start = mem.heaps[heapnr].heap_gen1_start;
  5063.         }
  5064.       #endif
  5065.       CHECK_GC_GENERATIONAL();
  5066.       # Markierungsphase:
  5067.         #ifdef GC_CLOSES_FILES
  5068.         files_to_close = O(open_files); O(open_files) = NIL; # O(files_to_close) = NIL;
  5069.         #endif
  5070.         gc_markphase();
  5071.         #ifdef GC_CLOSES_FILES
  5072.         # (noch unmarkierte) Liste files_to_close aufspalten in zwei Listen:
  5073.         { var reg1 object Lu = files_to_close;
  5074.           var reg2 object* L1 = &O(open_files);
  5075.           var reg3 object* L2 = &O(files_to_close);
  5076.           while (consp(Lu))
  5077.             { if (in_old_generation(Car(Lu),stream_type,0)
  5078.                   || marked(TheStream(Car(Lu))) # (car Lu) markiert?
  5079.                  )
  5080.                 # ja -> in O(open_files) ⁿbernehmen:
  5081.                 { *L1 = Lu; L1 = &Cdr(Lu); Lu = *L1; }
  5082.                 else
  5083.                 # nein -> in O(files_to_close) ⁿbernehmen:
  5084.                 { *L2 = Lu; L2 = &Cdr(Lu); Lu = *L2; }
  5085.             }
  5086.           *L1 = NIL; *L2 = NIL;
  5087.         }
  5088.         gc_mark(O(open_files)); gc_mark(O(files_to_close)); # Beide Listen jetzt markieren
  5089.         #endif
  5090.       # Jetzt sind alle aktiven Objekte markiert:
  5091.       # Aktive Objekte variabler LΣnge wie auch aktive Zwei-Pointer-Objekte tragen
  5092.       # in ihrem ersten Byte ein gesetztes Markierungsbit, aktive SUBRs tragen
  5093.       # in ihrem ersten Konstantenpointer ein gesetztes Markierungsbit, sonst sind
  5094.       # alle Markierungsbits gel÷scht.
  5095.       # "Sweep"-Phase:
  5096.         # Die CONSes u.Σ. (Objekte mit 2 Pointern) werden kompaktiert.
  5097.         # Von den Objekten variabler LΣnge werden die ZielplΣtze fⁿr die
  5098.         # Phase 4 errechnet und abgespeichert.
  5099.         # SUBRs und feste Symbole (sie sind alle aktiv) werden als erstes demarkiert:
  5100.           unmark_fixed_varobjects();
  5101.         #ifndef MORRIS_GC
  5102.         # CONS-Zellen kompaktieren:
  5103.           for_each_cons_page(page, { gc_compact_cons_page(page); } );
  5104.         #endif
  5105.         # Objekte variabler LΣnge zur Zusammenschiebung nach unten vorbereiten:
  5106.           #ifdef SPVW_PURE
  5107.           #ifdef GENERATIONAL_GC
  5108.           if (generation == 0)
  5109.             { for_each_varobject_heap(heap,
  5110.                 { if (heap->heap_gen0_end < heap->heap_gen1_start)
  5111.                     # Lⁿcke durch einen Pointer ⁿberspringen
  5112.                     { var object secondmarked;
  5113.                       var reg1 aint tmp =
  5114.                         gc_sweep1_varobject_page(heapnr,
  5115.                                                  heap->heap_gen0_start,heap->heap_gen0_end,
  5116.                                                  &heap->pages.page_gcpriv.firstmarked,
  5117.                                                  heap->heap_gen0_start);
  5118.                       gc_sweep1_varobject_page(heapnr,
  5119.                                                heap->heap_gen1_start,heap->heap_end,
  5120.                                                (object*)(heap->heap_gen0_end),
  5121.                                                tmp);
  5122.                     }
  5123.                     else
  5124.                     # keine Lⁿcke
  5125.                     { gc_sweep1_varobject_page(heapnr,
  5126.                                                heap->heap_gen0_start,heap->heap_end,
  5127.                                                &heap->pages.page_gcpriv.firstmarked,
  5128.                                                heap->heap_gen0_start);
  5129.                     }
  5130.                 });
  5131.             }
  5132.             else
  5133.           #endif
  5134.           for_each_varobject_page(page,
  5135.             { gc_sweep1_varobject_page(heapnr,
  5136.                                        page->page_start,page->page_end,
  5137.                                        &page->page_gcpriv.firstmarked,
  5138.                                        page->page_start);
  5139.             });
  5140.           #else # SPVW_MIXED
  5141.           #ifdef GENERATIONAL_GC
  5142.           if (generation == 0)
  5143.             { for_each_varobject_heap(heap,
  5144.                 { if (heap->heap_gen0_end < heap->heap_gen1_start)
  5145.                     # Lⁿcke durch einen Pointer ⁿberspringen
  5146.                     { var object secondmarked;
  5147.                       var reg1 aint tmp =
  5148.                         gc_sweep1_varobject_page(heap->heap_gen0_start,heap->heap_gen0_end,
  5149.                                                  &heap->pages.page_gcpriv.firstmarked,
  5150.                                                  heap->heap_gen0_start);
  5151.                       gc_sweep1_varobject_page(heap->heap_gen1_start,heap->heap_end,
  5152.                                                (object*)(heap->heap_gen0_end),
  5153.                                                tmp);
  5154.                     }
  5155.                     else
  5156.                     # keine Lⁿcke
  5157.                     { gc_sweep1_varobject_page(heap->heap_gen0_start,heap->heap_end,
  5158.                                                &heap->pages.page_gcpriv.firstmarked,
  5159.                                                heap->heap_gen0_start);
  5160.                     }
  5161.                 });
  5162.             }
  5163.             else
  5164.             for_each_varobject_page(page,
  5165.               { gc_sweep1_varobject_page(page->page_start,page->page_end,
  5166.                                          &page->page_gcpriv.firstmarked,
  5167.                                          page->page_start);
  5168.               });
  5169.           #else
  5170.           for_each_varobject_page(page, { gc_sweep1_varobject_page(page); } );
  5171.           #endif
  5172.           #endif
  5173.       # Jetzt sind alle aktiven Objekte fⁿr die Aktualisierung vorbereitet:
  5174.       # Bei aktiven Objekten variabler LΣnge A2 ist (A2).L die Adresse, wo das
  5175.       # Objekt nach der GC stehen wird (incl. Typinfo und Markierungsbit und evtl.
  5176.       # Symbol-Flags). Bei aktiven Zwei-Pointer-Objekten A2 bleibt entweder A2
  5177.       # stehen (dann ist das Markierungsbit in (A2) gel÷scht), oder A2 wird
  5178.       # verschoben (dann ist (A2).L die neue Adresse, ohne Typinfo, aber incl.
  5179.       # Markierungsbit).
  5180.       # Aktualisierungsphase:
  5181.         # Der gesamte LISP-Speicher wird durchgegangen und dabei alte durch
  5182.         # neue Adressen ersetzt.
  5183.         #ifdef MORRIS_GC
  5184.         for_each_cons_page(page, { gc_morris1(page); } );
  5185.         #endif
  5186.         # Durchlaufen durch alle LISP-Objekte und aktualisieren:
  5187.           # Pointer im LISP-Stack aktualisieren:
  5188.             aktualisiere_STACK();
  5189.           # Programmkonstanten aktualisieren:
  5190.             aktualisiere_tab();
  5191.           #ifndef MORRIS_GC
  5192.           # Pointer in den Cons-Zellen aktualisieren:
  5193.             aktualisiere_conses();
  5194.           #endif
  5195.           # Pointer in den Objekten variabler LΣnge aktualisieren:
  5196.             #define aktualisiere_page(page,aktualisierer)  \
  5197.               { var reg2 aint ptr = (aint)type_pointable(0,page->page_gcpriv.firstmarked); \
  5198.                 var reg6 aint ptrend = page->page_end;                                     \
  5199.                 # alle Objekte mit Adresse >=ptr, <ptrend durchgehen:                      \
  5200.                 until (ptr==ptrend) # solange bis ptr am Ende angekommen ist               \
  5201.                   { # nΣchstes Objekt mit Adresse ptr (< ptrend) durchgehen:               \
  5202.                     if (marked(ptr)) # markiert?                                           \
  5203.                       # Typinfo ohne Markierungsbit nehmen!                                \
  5204.                       { aktualisierer(typecode_at(ptr) & ~bit(garcol_bit_t)); }            \
  5205.                       else                                                                 \
  5206.                       # mit Pointer (Typinfo=0) zum nΣchsten markierten Objekt             \
  5207.                       { ptr = (aint)type_pointable(0,*(object*)ptr); }                     \
  5208.               }   }
  5209.             aktualisiere_varobjects();
  5210.             #undef aktualisiere_page
  5211.           #ifdef GENERATIONAL_GC
  5212.           # Pointer in den Objekten der alten Generation aktualisieren:
  5213.             if (generation > 0)
  5214.               { aktualisiere_old_generation(); }
  5215.           #endif
  5216.         #ifdef MORRIS_GC
  5217.         # Zum Schlu▀ werden die Conses verschoben und gleichzeitig alle
  5218.         # Pointer auf sie (z.Zt. in Listen gefⁿhrt!) aktualisiert.
  5219.         for_each_cons_page_reversed(page, { gc_morris2(page); } );
  5220.         for_each_cons_page(page, { gc_morris3(page); } );
  5221.         #endif
  5222.       # Jetzt sind alle aktiven Objekte mit korrektem Inhalt versehen (alle darin
  5223.       # vorkommenden Pointer zeigen auf die nach der GC korrekten Adressen).
  5224.       # Die aktiven Zwei-Pointer-Objekte sind bereits am richtigen Ort und
  5225.       # unmarkiert; die Objekte variabler LΣnge sind noch am alten Ort und
  5226.       # markiert, falls aktiv.
  5227.       # Zweite SWEEP-Phase:
  5228.         # Die Objekte variabler LΣnge werden an die vorher berechneten
  5229.         # neuen PlΣtze geschoben.
  5230.         #if !defined(GENERATIONAL_GC)
  5231.         #ifdef SPVW_MIXED
  5232.         for_each_varobject_page(page, { gc_sweep2_varobject_page(page); } );
  5233.         #else # SPVW_PURE
  5234.         for_each_varobject_page(page, { gc_sweep2_varobject_page(page,heapnr); } );
  5235.         #endif
  5236.         #else # defined(GENERATIONAL_GC)
  5237.         { var reg4 uintL heapnr;
  5238.           for (heapnr=0; heapnr<heapcount; heapnr++)
  5239.             { var reg3 Heap* heap = &mem.heaps[heapnr];
  5240.               if (!is_unused_heap(heapnr))
  5241.                 { if (is_varobject_heap(heapnr))
  5242.                     {
  5243.                       #ifdef SPVW_MIXED
  5244.                       gc_sweep2_varobject_page(&heap->pages);
  5245.                       #else # SPVW_PURE
  5246.                       gc_sweep2_varobject_page(&heap->pages,heapnr);
  5247.                       #endif
  5248.                     }
  5249.                   if (generation == 0)
  5250.                     { # Alles ▄briggebliebene bildet die neue Generation 0.
  5251.                       { var reg1 aint end = heap->heap_end;
  5252.                         heap->heap_gen0_end = end;
  5253.                         end = (end + (physpagesize-1)) & -physpagesize;
  5254.                         heap->heap_gen1_start = heap->heap_end = end;
  5255.                       }
  5256.                       build_old_generation_cache(heapnr);
  5257.                     }
  5258.                     else
  5259.                     { rebuild_old_generation_cache(heapnr); }
  5260.                 }
  5261.               heap->heap_start = heap->heap_gen0_start;
  5262.         }   }
  5263.         #endif
  5264.       # Jetzt sind alle aktiven Objekte mit korrektem Inhalt versehen, am richtigen
  5265.       # Ort und wieder unmarkiert.
  5266.       #ifdef SPVW_PAGES
  5267.         { var reg5 uintL heapnr;
  5268.           for (heapnr=0; heapnr<heapcount; heapnr++)
  5269.             { var reg4 Pages* heapptr = &mem.heaps[heapnr].inuse;
  5270.               AVL_map(*heapptr,page,
  5271.                       page->page_room -= page->page_end;
  5272.                      );
  5273.               # In page_room steht jetzt jeweils wieder der verfⁿgbare Platz.
  5274.               # Pages wieder nach dem verfⁿgbaren Platz sortieren:
  5275.               *heapptr = AVL(AVLID,sort)(*heapptr);
  5276.         }   }
  5277.         for_each_cons_heap(heap, { heap->lastused = dummy_lastused; } );
  5278.         # .reserve behandeln??
  5279.       #endif
  5280.       CHECK_AVL_CONSISTENCY();
  5281.       CHECK_GC_CONSISTENCY();
  5282.       CHECK_GC_UNMARKED(); CHECK_NULLOBJ(); CHECK_GC_CACHE(); CHECK_GC_GENERATIONAL(); SAVE_GC_DATA();
  5283.       CHECK_PACK_CONSISTENCY();
  5284.       # Ende der Garbage Collection.
  5285.       #ifdef HAVE_VADVISE
  5286.         begin_system_call();
  5287.         vadvise(VA_NORM); # Paging-Verhalten wird ab jetzt wieder normal
  5288.         end_system_call();
  5289.       #endif
  5290.       #ifdef WINDOWS
  5291.       windows_note_gc_end();
  5292.       #endif
  5293.       #ifdef ATARI
  5294.       BIOS_Bell(); # Ton ausgeben
  5295.       #endif
  5296.       gc_count += 1; # GCs mitzΣhlen
  5297.       # belegten Speicherplatz ermitteln:
  5298.       #ifdef SPVW_PAGES
  5299.       recalc_space(FALSE);
  5300.       #endif
  5301.       gcend_space = used_space();
  5302.       #ifdef SPVW_PAGES
  5303.       mem.last_gcend_space = gcend_space;
  5304.       # Um bis zu 25% lassen wir den benutzten Platz anwachsen, dann erst
  5305.       # kommt die nΣchste GC:
  5306.       { var reg1 uintL total_room = floor(mem.last_gcend_space,4);
  5307.         if (total_room < 512*1024) { total_room = 512*1024; } # mindestens 512 KB
  5308.         mem.gctrigger_space = mem.last_gcend_space + total_room;
  5309.       }
  5310.       #endif
  5311.       #if (defined(SPVW_PURE_BLOCKS) || defined(TRIVIALMAP_MEMORY)) && !defined(GENERATIONAL_GC)
  5312.       # Um bis zu 50% lassen wir den benutzten Platz anwachsen, dann erst
  5313.       # kommt die nΣchste GC:
  5314.       #define set_total_room(space_used_now)  \
  5315.         { mem.total_room = floor(space_used_now,2); # 50% des jetzt benutzten Platzes       \
  5316.           if (mem.total_room < 512*1024) { mem.total_room = 512*1024; } # mindestens 512 KB \
  5317.         }
  5318.       set_total_room(gcend_space);
  5319.       #endif
  5320.       #if defined(GENERATIONAL_GC)
  5321.       # Um bis zu 25% lassen wir den benutzten Platz anwachsen, dann erst
  5322.       # kommt die nΣchste GC:
  5323.       #define set_total_room(space_used_now)  \
  5324.         { mem.total_room = floor(space_used_now,4); # 25% des jetzt benutzten Platzes       \
  5325.           if (mem.total_room < 512*1024) { mem.total_room = 512*1024; } # mindestens 512 KB \
  5326.         }
  5327.       { var reg4 uintL gen0_sum = 0; # momentane Gr÷▀e der alten Generation
  5328.         var reg4 uintL gen1_sum = 0; # momentane Gr÷▀e der neuen Generation
  5329.         for_each_heap(heap,
  5330.           { gen0_sum += heap->heap_gen0_end - heap->heap_gen0_start;
  5331.             gen1_sum += heap->heap_end - heap->heap_gen1_start;
  5332.           });
  5333.         # NB: gcend_space == gen0_sum + gen1_sum.
  5334.         set_total_room(gen0_sum);
  5335.         mem.last_gcend_space0 = gen0_sum;
  5336.         mem.last_gcend_space1 = gen1_sum;
  5337.       }
  5338.       #endif
  5339.       { var reg1 uintL freed = gcstart_space - gcend_space; # von dieser GC
  5340.                                        # wiederbeschaffter Speicherplatz
  5341.         # dies zum 64-Bit-Akku gc_space addieren:
  5342.         #ifdef intQsize
  5343.         gc_space += freed;
  5344.         #else
  5345.         gc_space.lo += freed;
  5346.         if (gc_space.lo < freed) # ▄bertrag?
  5347.           gc_space.hi += 1;
  5348.         #endif
  5349.       }
  5350.       #ifdef SPVW_PAGES
  5351.       free_some_unused_pages();
  5352.       #endif
  5353.       #if (defined(SPVW_PURE_BLOCKS) || defined(TRIVIALMAP_MEMORY)) && defined(VIRTUAL_MEMORY) && defined(HAVE_MUNMAP)
  5354.       # Ungebrauchte, leere Seiten freigeben, damit sie vom Betriebssystem
  5355.       # nicht irgendwann auf den Swapspace verbracht werden mⁿssen:
  5356.       for_each_heap(heap,
  5357.         { var reg1 aint needed_limit = round_up(heap->heap_end,map_pagesize);
  5358.           if (needed_limit > heap->heap_limit)
  5359.             abort();
  5360.           if (needed_limit < heap->heap_limit)
  5361.             { if (munmap((MMAP_ADDR_T)needed_limit,heap->heap_limit-needed_limit) < 0)
  5362.                 { asciz_out(DEUTSCH ? "munmap() klappt nicht." :
  5363.                             ENGLISH ? "munmap() fails." :
  5364.                             FRANCAIS ? "munmap() ne fonctionne pas." :
  5365.                             ""
  5366.                            );
  5367.                   errno_out(errno);
  5368.                   abort();
  5369.                 }
  5370.               heap->heap_limit = needed_limit;
  5371.         }   });
  5372.       #endif
  5373.       # von dieser GC ben÷tigte Zeit zur GC-Gesamtzeit addieren:
  5374.       gc_timer_off();
  5375.       #ifdef GC_CLOSES_FILES
  5376.       close_some_files(O(files_to_close)); # vorher unmarkierte Files schlie▀en
  5377.       O(files_to_close) = NIL;
  5378.       #endif
  5379.       #ifdef GENERATIONAL_GC
  5380.       O(gc_count) = fixnum_inc(O(gc_count),1); # GCs mitzΣhlen
  5381.       #endif
  5382.       gc_signalblock_off(); # Signale wieder freigeben
  5383.       immutable_on();
  5384.       clr_break_sem_1(); # BREAK wieder erm÷glichen
  5385.     }
  5386.  
  5387. #ifdef SPVW_PAGES
  5388.  
  5389. # Eine kleine Sortier-Routine:
  5390. #define SORTID  spvw
  5391. #define SORT_ELEMENT  Pages
  5392. #define SORT_KEY  uintL
  5393. #define SORT_KEYOF(page)  (page)->page_gcpriv.l
  5394. #define SORT_COMPARE(key1,key2)  (sintL)((key1)-(key2))
  5395. #define SORT_LESS(key1,key2)  ((key1) < (key2))
  5396. #include "sort.c"
  5397.  
  5398. # Kompaktierung einer Page durch Umfⁿllen in andere Pages derselben Art:
  5399.   #ifdef SPVW_PURE
  5400.   local void gc_compact_from_varobject_page (Heap* heapptr, Page* page, uintL heapnr);
  5401.   local void gc_compact_from_varobject_page(heapptr,page,heapnr)
  5402.     var reg9 Heap* heapptr;
  5403.     var reg8 Page* page;
  5404.     var reg10 uintL heapnr;
  5405.   #else
  5406.   local void gc_compact_from_varobject_page (Heap* heapptr, Page* page);
  5407.   local void gc_compact_from_varobject_page(heapptr,page)
  5408.     var reg9 Heap* heapptr;
  5409.     var reg8 Page* page;
  5410.   #endif
  5411.     { var reg1 aint p1 = page->page_start;
  5412.       var reg7 aint p1end = page->page_end;
  5413.       var_speicher_laenge_;
  5414.      {var reg4 Pages new_page = EMPTY; # Page, in die gefⁿllt wird
  5415.       var AVL(AVLID,stack) stack; # Weg von der Wurzel bis zu ihr
  5416.       var reg2 aint p2; # Cache von new_page->page_end
  5417.       var reg5 uintL l2; # Cache von new_page->page_room
  5418.       # Versuche alle Objekte zwischen p1 und p1end zu kopieren:
  5419.       loop
  5420.         { if (p1==p1end) break; # obere Grenze erreicht -> fertig
  5421.          {var reg3 uintL laenge = calc_speicher_laenge(p1); # Byte-LΣnge bestimmen
  5422.           # Suche eine Page, die noch mindestens laenge Bytes frei hat:
  5423.           if ((new_page == EMPTY) || (l2 < laenge))
  5424.             { if (!(new_page == EMPTY)) # Cache leeren?
  5425.                 { new_page->page_end = p2;
  5426.                   new_page->page_room = l2;
  5427.                   AVL(AVLID,move)(&stack);
  5428.                 }
  5429.               new_page = AVL(AVLID,least)(laenge,&heapptr->inuse,&stack);
  5430.               if (new_page==EMPTY) break;
  5431.               new_page->page_gcpriv.d = -1L; # new_page als "zu fⁿllend" kennzeichnen
  5432.               p2 = new_page->page_end;
  5433.               l2 = new_page->page_room;
  5434.             }
  5435.           {var reg6 aint old_p1 = p1;
  5436.            var reg6 aint old_p2 = p2;
  5437.            # Kopiere das Objekt:
  5438.            l2 -= laenge; move_aligned_p1_p2(laenge);
  5439.            # Hinterlasse einen Pointer auf die neue Position:
  5440.            *(object*)old_p1 = with_mark_bit(type_pointer_object(0,old_p2));
  5441.            # p1 = Sourceadresse fⁿr nΣchstes Objekt
  5442.         }}}
  5443.       if (!(new_page == EMPTY)) # Cache leeren?
  5444.         { new_page->page_end = p2;
  5445.           new_page->page_room = l2;
  5446.           AVL(AVLID,move)(&stack);
  5447.         }
  5448.      }
  5449.      # Die nicht kopierten Objekte erfahren eine konstante Verschiebung nach unten:
  5450.      {var reg4 aint p2 = page->page_start;
  5451.       page->page_gcpriv.d = p1 - p2; # Verschiebung
  5452.       page->page_start = p1; # jetziger Anfang der Page
  5453.       if (!(p1==p2)) # falls Verschiebung n÷tig
  5454.         until (p1==p1end) # obere Grenze erreicht -> fertig
  5455.           { var reg3 uintL laenge = calc_speicher_laenge(p1); # Byte-LΣnge bestimmen
  5456.             var reg2 tint flags = mtypecode(((Varobject)p1)->GCself); # Typinfo (und Flags bei Symbolen) retten
  5457.             set_GCself(p1, flags,p2); # neue Adresse eintragen, mit alter Typinfo
  5458.             mark(p1); # mit Markierungsbit
  5459.             p1 += laenge; p2 += laenge;
  5460.           }
  5461.     }}
  5462.   local void gc_compact_from_cons_page (Heap* heapptr, Page* page);
  5463.   local void gc_compact_from_cons_page(heapptr,page)
  5464.     var reg7 Heap* heapptr;
  5465.     var reg6 Page* page;
  5466.     { var reg1 aint p1 = page->page_end;
  5467.       var reg5 aint p1start = page->page_start;
  5468.      {var reg3 Pages new_page = EMPTY; # Page, in die gefⁿllt wird
  5469.       var AVL(AVLID,stack) stack; # Weg von der Wurzel bis zu ihr
  5470.       var reg2 aint p2; # Cache von new_page->page_end
  5471.       var reg4 uintL l2; # Cache von new_page->page_room
  5472.       # Versuche alle Objekte zwischen p1start und p1 zu kopieren:
  5473.       loop
  5474.         { if (p1==p1start) break; # untere Grenze erreicht -> fertig
  5475.           # Suche eine Page, die noch mindestens sizeof(cons_) Bytes frei hat:
  5476.           if ((new_page == EMPTY) || (l2 == 0)) # l2 < sizeof(cons_) bedeutet l2 = 0
  5477.             { if (!(new_page == EMPTY)) # Cache leeren?
  5478.                 { new_page->page_end = p2;
  5479.                   new_page->page_room = l2;
  5480.                   AVL(AVLID,move)(&stack);
  5481.                 }
  5482.               new_page = AVL(AVLID,least)(sizeof(cons_),&heapptr->inuse,&stack);
  5483.               if (new_page==EMPTY) break;
  5484.               new_page->page_gcpriv.d = -1L; # new_page als "zu fⁿllend" kennzeichnen
  5485.               p2 = new_page->page_end;
  5486.               l2 = new_page->page_room;
  5487.             }
  5488.           p1 -= sizeof(cons_); # p1 = Sourceadresse fⁿr nΣchstes Objekt
  5489.           # Kopiere das Objekt:
  5490.           ((object*)p2)[0] = ((object*)p1)[0];
  5491.           ((object*)p2)[1] = ((object*)p1)[1];
  5492.           # Hinterlasse einen Pointer auf die neue Position:
  5493.           *(object*)p1 = with_mark_bit(type_pointer_object(0,p2));
  5494.           p2 += sizeof(cons_); l2 -= sizeof(cons_);
  5495.         }
  5496.       if (!(new_page == EMPTY)) # Cache leeren?
  5497.         { new_page->page_end = p2;
  5498.           new_page->page_room = l2;
  5499.           AVL(AVLID,move)(&stack);
  5500.         }
  5501.      }
  5502.      # Die nicht kopierten Objekte bleiben an Ort und Stelle.
  5503.      page->page_gcpriv.d = page->page_end - p1; # Zugewinn
  5504.      page->page_end = p1; # jetziges Ende der Page
  5505.     }
  5506.  
  5507. # Kompaktierung aller Pages einer bestimmten Art:
  5508.   #ifdef SPVW_PURE
  5509.   local void gc_compact_heap (Heap* heapptr, sintB heaptype, uintL heapnr);
  5510.   local void gc_compact_heap(heapptr,heaptype,heapnr)
  5511.     var reg4 Heap* heapptr;
  5512.     var reg5 sintB heaptype;
  5513.     var reg5 uintL heapnr;
  5514.   #else
  5515.   local void gc_compact_heap (Heap* heapptr, sintB heaptype);
  5516.   local void gc_compact_heap(heapptr,heaptype)
  5517.     var reg4 Heap* heapptr;
  5518.     var reg5 sintB heaptype;
  5519.   #endif
  5520.     { # Erst eine Liste aller Pages erstellen, aufsteigend sortiert
  5521.       # nach der Anzahl der belegten Bytes:
  5522.       var reg10 uintL pagecount = 0;
  5523.       map_heap(*heapptr,page,
  5524.                { page->page_gcpriv.l = page->page_end - page->page_start; # Anzahl der belegten Bytes
  5525.                  pagecount++;
  5526.                }
  5527.               );
  5528.       # pagecount = Anzahl der Pages.
  5529.      {var DYNAMIC_ARRAY(reg6,pages_sorted,Pages,pagecount);
  5530.       {var reg4 uintL index = 0;
  5531.        map_heap(*heapptr,page, { pages_sorted[index++] = page; } );
  5532.       }
  5533.       # pages_sorted = Array der Pages.
  5534.       SORT(SORTID,sort)(pages_sorted,pagecount);
  5535.       # pages_sorted = Array der Pages, sortiert nach der Anzahl der belegten Bytes.
  5536.       # In jeder Page bedeutet page_gcpriv.d die Verschiebung nach unten,
  5537.       # die der Page in Phase 3 zuteil werden mu▀ (>=0).
  5538.       # page_gcpriv.d = -1L fⁿr die zu fⁿllenden Pages.
  5539.       # page_gcpriv.d = -2L fⁿr die noch unbehandelten Pages.
  5540.       map_heap(*heapptr,page, { page->page_gcpriv.d = -2L; } ); # alle Pages noch unbehandelt
  5541.       {var reg3 uintL index;
  5542.        for (index=0; index<pagecount; index++) # Durch alle Pages durchlaufen
  5543.          { var reg2 Pages page = pages_sorted[index]; # nΣchste Page
  5544.            if (page->page_gcpriv.d == -2L) # noch unbehandelt und
  5545.                                            # noch nicht als "zu fⁿllend" markiert?
  5546.              { # page wird geleert.
  5547.                heapptr->inuse = AVL(AVLID,delete1)(page,heapptr->inuse); # page herausnehmen
  5548.                # page leeren:
  5549.                if (heaptype==0)
  5550.                  { gc_compact_from_cons_page(heapptr,page); }
  5551.                  else
  5552.                  #ifdef SPVW_PURE
  5553.                  { gc_compact_from_varobject_page(heapptr,page,heapnr); }
  5554.                  #else
  5555.                  { gc_compact_from_varobject_page(heapptr,page); }
  5556.                  #endif
  5557.       }  }   }
  5558.       CHECK_AVL_CONSISTENCY();
  5559.       CHECK_GC_CONSISTENCY_2();
  5560.       {var reg2 uintL index;
  5561.        for (index=0; index<pagecount; index++) # Durch alle Pages durchlaufen
  5562.          { var reg1 Pages page = pages_sorted[index]; # nΣchste Page
  5563.            if (!(page->page_gcpriv.d == -1L)) # eine zu leerende Page
  5564.              { page->page_room += page->page_gcpriv.d; # So viel Platz haben wir nun gemacht
  5565.                if (page->page_start == page->page_end)
  5566.                  # Page ganz geleert
  5567.                  { # Page freigeben:
  5568.                    if (page->m_length > min_page_size_brutto)
  5569.                      # ▄bergro▀e Page
  5570.                      { free_page(page); } # ans Betriebssystem zurⁿckgeben
  5571.                      else
  5572.                      # Normalgro▀e Page
  5573.                      { # wieder initialisieren (page->page_room bleibt gleich!):
  5574.                        page->page_start = page->page_end = page_start0(page);
  5575.                        # in den Pool mem.free_pages einhΣngen:
  5576.                        page->page_gcpriv.next = mem.free_pages;
  5577.                        mem.free_pages = page;
  5578.                  }   }
  5579.                  else
  5580.                  # Page konnte nicht ganz geleert werden
  5581.                  { heapptr->inuse = AVL(AVLID,insert1)(page,heapptr->inuse); } # Page wieder rein
  5582.       }  }   }
  5583.       FREE_DYNAMIC_ARRAY(pages_sorted);
  5584.       CHECK_AVL_CONSISTENCY();
  5585.       CHECK_GC_CONSISTENCY_2();
  5586.     }}
  5587.  
  5588. # Kompaktierende Garbage Collection durchfⁿhren.
  5589. # Wird aufgerufen, nachdem gar_col_simple() nicht genⁿgend Platz am Stⁿck
  5590. # besorgen konnte.
  5591.   local void gar_col_compact (void);
  5592.   local void gar_col_compact()
  5593.     { # Es werden Lisp-Objekte von fast leeren Pages in andere Pages
  5594.       # umgefⁿllt, um die ganz leer machen und zurⁿckgeben zu k÷nnen.
  5595.       # 1. Fⁿr jede Page-Art:
  5596.       #    Pages unterteilen in zu leerende und zu fⁿllende Pages und dabei
  5597.       #    soviel Daten wie m÷glich von den zu leerenden in die zu fⁿllenden
  5598.       #    Pages umkopieren. Kann eine Page nicht ganz geleert werden, so
  5599.       #    wird sie so gelassen, wie sie ist, und in ihr werden dann nachher
  5600.       #    die ⁿbrigen Daten nur nach unten geschoben.
  5601.       #    Rⁿckgabe der ganz geleerten Pages.
  5602.       # 2. Aktualisierung der Pointer.
  5603.       # 3. Durchfⁿhrung der Verschiebungen in den nicht ganz geleerten Pages.
  5604.       set_break_sem_1(); # BREAK wΣhrend Garbage Collection sperren
  5605.       immutable_off(); # immutable Objekte werden jetzt modifizierbar
  5606.       gc_signalblock_on(); # Signale wΣhrend Garbage Collection sperren
  5607.       gc_timer_on();
  5608.       CHECK_GC_UNMARKED(); CHECK_NULLOBJ();
  5609.       { var reg1 uintL heapnr;
  5610.         for (heapnr=0; heapnr<heapcount; heapnr++)
  5611.           if (!is_unused_heap(heapnr))
  5612.             #ifdef SPVW_PURE
  5613.             { gc_compact_heap(&mem.heaps[heapnr],mem.heaptype[heapnr],heapnr); }
  5614.             #endif
  5615.             #ifdef SPVW_MIXED
  5616.             { gc_compact_heap(&mem.heaps[heapnr],1-heapnr); }
  5617.             #endif
  5618.       }
  5619.       # Aktualisierungsphase:
  5620.         # Der gesamte LISP-Speicher wird durchgegangen und dabei alte durch
  5621.         # neue Adressen ersetzt.
  5622.         # Durchlaufen durch alle LISP-Objekte und aktualisieren:
  5623.           # Pointer im LISP-Stack aktualisieren:
  5624.             aktualisiere_STACK();
  5625.           # Programmkonstanten aktualisieren:
  5626.             aktualisiere_tab();
  5627.           # Pointer in den Cons-Zellen aktualisieren:
  5628.             aktualisiere_conses();
  5629.           # Pointer in den Objekten variabler LΣnge aktualisieren:
  5630.             #define aktualisiere_page(page,aktualisierer)  \
  5631.               { var reg2 aint ptr = page->page_start;                        \
  5632.                 var reg6 aint ptrend = page->page_end;                       \
  5633.                 # alle Objekte mit Adresse >=ptr, <ptrend durchgehen:        \
  5634.                 until (ptr==ptrend) # solange bis ptr am Ende angekommen ist \
  5635.                   { # nΣchstes Objekt mit Adresse ptr (< ptrend) durchgehen: \
  5636.                     aktualisierer(typecode_at(ptr) & ~bit(garcol_bit_t)); # und weiterrⁿcken \
  5637.               }   }
  5638.             aktualisiere_varobjects();
  5639.             #undef aktualisiere_page
  5640.       # Durchfⁿhrung der Verschiebungen in den nicht ganz geleerten Pages:
  5641.         for_each_varobject_page(page,
  5642.           { if (!(page->page_gcpriv.d == -1L))
  5643.               { var reg2 aint p1 = page->page_start;
  5644.                 var reg4 aint p1end = page->page_end;
  5645.                 var reg1 aint p2 = p1 - page->page_gcpriv.d;
  5646.                 if (!(p1==p2)) # falls Verschiebung n÷tig
  5647.                   { var_speicher_laenge_;
  5648.                     page->page_start = p2;
  5649.                     until (p1==p1end) # obere Grenze erreicht -> fertig
  5650.                       { # nΣchstes Objekt hat Adresse p1, ist markiert
  5651.                         unmark(p1); # Markierung l÷schen
  5652.                         # Objekt behalten und verschieben:
  5653.                        {var reg3 uintL count = calc_speicher_laenge(p1); # LΣnge (durch Varobject_alignment teilbar, >0)
  5654.                         move_aligned_p1_p2(count); # verschieben und weiterrⁿcken
  5655.                       }}
  5656.                     page->page_end = p2;
  5657.           }   }   }
  5658.           );
  5659.       for_each_cons_heap(heap, { heap->lastused = dummy_lastused; } );
  5660.       recalc_space(TRUE);
  5661.       free_some_unused_pages();
  5662.       CHECK_AVL_CONSISTENCY();
  5663.       CHECK_GC_CONSISTENCY();
  5664.       CHECK_GC_UNMARKED(); CHECK_NULLOBJ();
  5665.       CHECK_PACK_CONSISTENCY();
  5666.       gc_timer_off();
  5667.       gc_signalblock_off(); # Signale wieder freigeben
  5668.       immutable_on();
  5669.       clr_break_sem_1(); # BREAK wieder erm÷glichen
  5670.     }
  5671.  
  5672. #endif
  5673.  
  5674. # Garbage Collection durchfⁿhren:
  5675.   local void gar_col_simple (void);
  5676.   local void gar_col_simple()
  5677.     {
  5678.       #if !defined(GENERATIONAL_GC)
  5679.       gar_col_normal();
  5680.       #ifdef SPVW_PAGES
  5681.       #if defined(UNIX) || defined(AMIGAOS) || defined(RISCOS)
  5682.       # Wenn der in Pages allozierte, aber unbelegte Speicherplatz
  5683.       # mehr als 25% dessen ausmacht, was belegt ist, lohnt sich wohl eine
  5684.       # Kompaktierung, denn fⁿrs Betriebssystem kostet eine halbleere Page
  5685.       # genausoviel wie eine volle Page:
  5686.       if (free_space() > floor(mem.last_gcend_space,4))
  5687.         { gar_col_compact(); mem.last_gc_compacted = TRUE; }
  5688.         else
  5689.       #endif
  5690.         { mem.last_gc_compacted = FALSE; }
  5691.       #endif
  5692.       #else # defined(GENERATIONAL_GC)
  5693.       # Wenn nach der letzten GC die Objekte in der neuen Generation
  5694.       # mehr als 25% der Objekte in der alten Generation ausmachten,
  5695.       # dann machen wir diesmal eine volle Garbage-Collection (beide
  5696.       # Generationen auf einmal.)
  5697.       if (mem.last_gcend_space1 > floor(mem.last_gcend_space0,4))
  5698.         { generation = 0; gar_col_normal(); mem.last_gc_full = TRUE; }
  5699.         else
  5700.         { generation = 1; gar_col_normal(); mem.last_gc_full = FALSE; }
  5701.       #endif
  5702.     }
  5703.  
  5704. # Volle Garbage Collection durchfⁿhren:
  5705.   global void gar_col (void);
  5706.   global void gar_col()
  5707.     {
  5708.       #if !defined(GENERATIONAL_GC)
  5709.       gar_col_normal();
  5710.       #ifdef SPVW_PAGES
  5711.       gar_col_compact(); mem.last_gc_compacted = TRUE;
  5712.       #endif
  5713.       #else # defined(GENERATIONAL_GC)
  5714.       generation = 0; gar_col_normal(); mem.last_gc_full = TRUE;
  5715.       #endif
  5716.     }
  5717.  
  5718. # Macro aktualisiere jetzt unn÷tig:
  5719.   #undef aktualisiere
  5720.  
  5721. #ifdef SPVW_MIXED_BLOCKS_OPPOSITE
  5722.  
  5723. # Zur Reorganisation des Objektspeichers nach GC oder vor und nach EXECUTE:
  5724.   # Unterprogramm zum Verschieben der Conses.
  5725.   # move_conses(delta);
  5726.   # Der Reservespeicher wird um delta Bytes (durch Varobject_alignment
  5727.   # teilbar) verkleinert, dabei die Conses um delta Bytes nach oben geschoben.
  5728.   local void move_conses (sintL delta);
  5729.   local void move_conses (delta)
  5730.     var reg4 sintL delta;
  5731.     { if (delta==0) return; # keine Verschiebung n÷tig?
  5732.       set_break_sem_1(); # BREAK wΣhrenddessen sperren
  5733.       gc_signalblock_on(); # Signale wΣhrenddessen sperren
  5734.       gc_timer_on();
  5735.       if (delta>0)
  5736.         # aufwΣrts schieben, von oben nach unten
  5737.         { var reg1 object* source = (object*) mem.conses.end;
  5738.           var reg3 object* source_end = (object*) mem.conses.start;
  5739.           #if !(defined(MIPS) && !defined(GNU))
  5740.           var reg2 object* dest = (object*) (mem.conses.end += delta);
  5741.           #else # IRIX 4 "cc -ansi" Compiler-Bug umgehen ??
  5742.           var reg2 object* dest = (mem.conses.end += delta, (object*)mem.conses.end);
  5743.           #endif
  5744.           mem.conses.start += delta;
  5745.           until (source==source_end)
  5746.             { *--dest = *--source; # ein ganzes Cons nach oben kopieren
  5747.               *--dest = *--source;
  5748.         }   }
  5749.         else # delta<0
  5750.         # abwΣrts schieben, von unten nach oben
  5751.         { var reg1 object* source = (object*) mem.conses.start;
  5752.           var reg3 object* source_end = (object*) mem.conses.end;
  5753.           #if !(defined(MIPS) && !defined(GNU))
  5754.           var reg2 object* dest = (object*) (mem.conses.start += delta);
  5755.           #else # IRIX 4 "cc -ansi" Compiler-Bug umgehen ??
  5756.           var reg2 object* dest = (mem.conses.start += delta, (object*)mem.conses.start);
  5757.           #endif
  5758.           mem.conses.end += delta;
  5759.           until (source==source_end)
  5760.             { *dest++ = *source++; # ein ganzes Cons nach oben kopieren
  5761.               *dest++ = *source++;
  5762.         }   }
  5763.       # Pointer auf Conses u.Σ. aktualisieren:
  5764.       { var reg4 soint odelta = (soint)delta<<(oint_addr_shift-addr_shift); # Offset im oint
  5765.         # Der gesamte LISP-Speicher wird durchgegangen und dabei alte durch
  5766.         # neue Adressen ersetzt.
  5767.         # Aktualisierung eines Objekts *objptr :
  5768.           #define aktualisiere(objptr)  \
  5769.             { switch (mtypecode(*(object*)(objptr)))                          \
  5770.                 { case_cons: case_ratio: case_complex: # Zwei-Pointer-Objekt? \
  5771.                     *(oint*)(objptr) += odelta; break;                        \
  5772.                   default: break;                                             \
  5773.             }   }
  5774.         # Durchlaufen durch alle LISP-Objekte und aktualisieren:
  5775.           # Pointer im LISP-Stack aktualisieren:
  5776.             { var reg2 object* objptr = &STACK_0; # Pointer, der durch den STACK lΣuft
  5777.               until (eq(*objptr,nullobj)) # bis STACK zu Ende ist:
  5778.                 { if ( *((oint*)objptr) & wbit(frame_bit_o) ) # Beginnt hier ein Frame?
  5779.                    { if (( *((oint*)objptr) & wbit(skip2_bit_o) ) == 0) # Ohne skip2-Bit?
  5780.                       objptr skipSTACKop 2; # ja -> um 2 weiterrⁿcken
  5781.                       else
  5782.                       objptr skipSTACKop 1; # nein -> um 1 weiterrⁿcken
  5783.                    }
  5784.                    else
  5785.                    { aktualisiere(objptr); # normales Objekt, aktualisieren
  5786.                      objptr skipSTACKop 1; # weiterrⁿcken
  5787.             }   }  }
  5788.           # Programmkonstanten aktualisieren:
  5789.             aktualisiere_tab();
  5790.           # Pointer in den Cons-Zellen aktualisieren:
  5791.             aktualisiere_conses();
  5792.           # Pointer in den Objekten variabler LΣnge aktualisieren:
  5793.             #define aktualisiere_page  aktualisiere_page_normal
  5794.             aktualisiere_varobjects();
  5795.             #undef aktualisiere_page
  5796.         # Macro aktualisiere jetzt unn÷tig:
  5797.           #undef aktualisiere
  5798.       }
  5799.       # Ende des Verschiebens und Aktualisierens.
  5800.       # ben÷tigte Zeit zur GC-Gesamtzeit addieren:
  5801.       gc_timer_off();
  5802.       gc_signalblock_off(); # Signale wieder freigeben
  5803.       clr_break_sem_1(); # BREAK wieder erm÷glichen
  5804.     }
  5805.  
  5806. #endif
  5807.  
  5808. # ------------------------------------------------------------------------------
  5809. #                 Speicherbereitstellungsfunktionen
  5810.  
  5811. # Fehlermeldung wegen vollen Speichers
  5812.   nonreturning_function(local, fehler_speicher_voll, (void));
  5813.   local void fehler_speicher_voll()
  5814.     { dynamic_bind(S(use_clcs),NIL); # SYS::*USE-CLCS* an NIL binden
  5815.       fehler(storage_condition,
  5816.              DEUTSCH ? "Speicherplatz fⁿr LISP-Objekte ist voll." :
  5817.              ENGLISH ? "No more room for LISP objects" :
  5818.              FRANCAIS ? "Il n'y a plus de place pour des objets LISP." :
  5819.              ""
  5820.             );
  5821.     }
  5822.  
  5823. # Stellt fest, ob eine Adresse im Intervall [0..2^oint_addr_len-1] liegt:
  5824.   #if (oint_addr_len==32) && !defined(WIDE_HARD) # d.h. defined(WIDE_SOFT)
  5825.     #define pointable_usable_test(a)  TRUE
  5826.   #else
  5827.     #define pointable_usable_test(a)  \
  5828.       ((void*)pointable(type_pointer_object(0,a)) == (void*)(a))
  5829.   #endif
  5830.  
  5831. # Holt Speicher vom Betriebssystem
  5832.   local void* mymalloc (uintL need);
  5833.   local void* mymalloc(need)
  5834.     var reg3 uintL need;
  5835.     {
  5836.       #ifdef ATARI
  5837.         var reg1 sintL erg = GEMDOS_Malloc(need);
  5838.         if (erg<0) return NULL;
  5839.         return (void*)erg;
  5840.       #else
  5841.         var reg1 void* addr;
  5842.         begin_system_call();
  5843.         addr = malloc(need);
  5844.         end_system_call();
  5845.         if (addr==NULL) return NULL;
  5846.         # Intervall [addr,addr+need-1] mu▀ in [0..2^oint_addr_len-1] liegen:
  5847.         { var reg2 aint a = (aint)addr; # a = untere Intervallgrenze
  5848.           if (pointable_usable_test(a))
  5849.             { a = round_down(a + need-1,bit(addr_shift)); # a = obere Intervallgrenze
  5850.               if (pointable_usable_test(a))
  5851.                 { return addr; }
  5852.         }   }
  5853.         # Mit diesem Stⁿck Speicher k÷nnen wir nichts anfangen, wieder zurⁿckgeben:
  5854.         begin_system_call();
  5855.         free(addr);
  5856.         end_system_call();
  5857.         #if defined(AMIGAOS) && !(defined(WIDE) || defined(MC68000))
  5858.         # Wir machen einen zweiten Versuch mit verΣnderten Flags.
  5859.         if (!(default_allocmemflag == retry_allocmemflag))
  5860.           { addr = allocmem(need,retry_allocmemflag);
  5861.             if (addr==NULL) return NULL;
  5862.             # Intervall [addr,addr+need-1] mu▀ in [0..2^oint_addr_len-1] liegen:
  5863.             { var reg2 aint a = (aint)addr; # a = untere Intervallgrenze
  5864.               if (pointable_usable_test(a))
  5865.                 { a = round_down(a + need-1,bit(addr_shift)); # a = obere Intervallgrenze
  5866.                   if (pointable_usable_test(a))
  5867.                     { return addr; }
  5868.             }   }
  5869.             # Auch mit diesem Stⁿck Speicher k÷nnen wir nichts anfangen, wieder zurⁿckgeben:
  5870.             freemem(addr);
  5871.           }
  5872.         #endif
  5873.         return NULL;
  5874.       #endif
  5875.     }
  5876.  
  5877. #ifdef SPVW_MIXED_BLOCKS_OPPOSITE
  5878.  
  5879. # Schafft Platz fⁿr ein neues Objekt.
  5880. # Falls keiner vorhanden -> Fehlermeldung.
  5881. # make_space(need);
  5882. # > uintL need: angeforderter Platz in Bytes (eine Variable oder Konstante)
  5883.   # Der Test, ob Platz vorhanden ist, als Macro, der Rest als Funktion:
  5884.   #define make_space(need)  \
  5885.     { if (mem.conses.start-mem.objects.end < (uintP)(need)) make_space_gc(need); }
  5886.   local void make_space_gc (uintL need);
  5887.   local void make_space_gc(need)
  5888.     var reg1 uintL need;
  5889.     { # (mem.conses.start-mem.objects.end < need)  ist schon abgeprⁿft, also
  5890.         # Nicht genⁿgend Platz
  5891.         not_enough_room:
  5892.         { gar_col_simple(); # Garbage Collector aufrufen
  5893.           # Teste auf Tastatur-Unterbrechung
  5894.           interruptp(
  5895.             { pushSTACK(S(gc)); tast_break();
  5896.               if (mem.conses.start-mem.objects.end < need) goto not_enough_room;
  5897.                 else
  5898.                 return;
  5899.             });
  5900.           if (mem.conses.start-mem.objects.end < need) # und wieder testen
  5901.             # Wirklich nicht genⁿgend Platz da.
  5902.             # [Unter UNIX mit 'realloc' arbeiten??]
  5903.             # Abhilfe: Reservespeicher wird halbiert.
  5904.             { var reg1 uintL reserve = mem.MEMTOP - mem.MEMRES; # noch freie Reserve
  5905.               if (reserve>=8) # Reservespeicher auch voll?
  5906.                 # nein -> Reservespeicher anzapfen und Fehlermeldung ausgeben
  5907.                 # halbe Reserve
  5908.                 { move_conses(round_down(floor(reserve,2),Varobject_alignment));
  5909.                   # halbierte Reserve, aligned: um soviel die Conses nach oben schieben
  5910.                   fehler_speicher_voll();
  5911.                 }
  5912.                 else
  5913.                 # ja -> harte Fehlermeldung
  5914.                 { asciz_out(DEUTSCH ? CRLFstring "*** - " "Speicherplatz fⁿr LISP-Objekte ist voll: RESET" :
  5915.                             ENGLISH ? CRLFstring "*** - " "No more room for LISP objects: RESET" :
  5916.                             FRANCAIS ? CRLFstring "*** - " "Il n'y a plus de place pour des objets LISP : RAZ" :
  5917.                             ""
  5918.                            );
  5919.                   reset(); # und zum letzten Driver-Frame zurⁿck
  5920.                 }
  5921.             }
  5922.             else
  5923.             # Jetzt ist genⁿgend Platz da. Vielleicht sogar genug, den
  5924.             # Reservespeicher auf normale Gr÷▀e zu bringen?
  5925.             { var reg2 uintL free = (mem.conses.start-mem.objects.end) - need;
  5926.                                 # soviel Bytes noch frei
  5927.               var reg2 uintL free_reserve = mem.MEMTOP-mem.MEMRES;
  5928.                                 # soviel Bytes noch in der Reserve frei, <=RESERVE
  5929.               var reg2 uintL free_total = free + free_reserve;
  5930.                                 # freier Objektspeicher + freie Reserve
  5931.               if (free_total >= RESERVE) # mindestens Normalwert RESERVE ?
  5932.                 # ja -> Reservespeicher auf normale Gr÷▀e bringen, indem
  5933.                 # die Conses um (RESERVE - free_reserve) nach unten geschoben
  5934.                 # werden:
  5935.                 move_conses(free_reserve-RESERVE);
  5936.                 # Dadurch bleibt genⁿgend fⁿr need frei.
  5937.             }
  5938.     }   }
  5939.  
  5940. #endif
  5941.  
  5942. #if defined(SPVW_PURE_BLOCKS) || defined(TRIVIALMAP_MEMORY) # <==> SINGLEMAP_MEMORY || TRIVIALMAP_MEMORY
  5943.  
  5944. # Schafft Platz fⁿr ein neues Objekt.
  5945. # Falls keiner vorhanden -> Fehlermeldung.
  5946. # make_space(need,heapptr);
  5947. # > uintL need: angeforderter Platz in Bytes (eine Variable oder Konstante)
  5948. # > Heap* heapptr: Pointer auf den Heap, dem der Platz entnommen werden soll
  5949.   # Der Test, ob Platz vorhanden ist, als Macro, der Rest als Funktion:
  5950.   #define make_space(need,heapptr)  \
  5951.     { if ((mem.total_room < (uintL)(need))                                 \
  5952.           || ((heapptr)->heap_limit - (heapptr)->heap_end < (uintP)(need)) \
  5953.          )                                                                 \
  5954.         make_space_gc(need,heapptr);                                       \
  5955.     }
  5956.   local void make_space_gc (uintL need, Heap* heapptr);
  5957.   local void make_space_gc(need,heapptr)
  5958.     var reg2 uintL need;
  5959.     var reg1 Heap* heapptr;
  5960.     { # (mem.total_room < need) || (heapptr->heap_limit - heapptr->heap_end < need)
  5961.       # ist schon abgeprⁿft, also nicht genⁿgend Platz.
  5962.       not_enough_room:
  5963.      {var reg4 boolean done_gc = FALSE;
  5964.       if (mem.total_room < need)
  5965.         do_gc:
  5966.         { gar_col_simple(); # Garbage Collector aufrufen
  5967.           doing_gc:
  5968.           # Teste auf Tastatur-Unterbrechung
  5969.           interruptp(
  5970.             { pushSTACK(S(gc)); tast_break();
  5971.               if ((mem.total_room < need) || (heapptr->heap_limit - heapptr->heap_end < need))
  5972.                 goto not_enough_room;
  5973.                 else
  5974.                 return;
  5975.             });
  5976.           done_gc = TRUE;
  5977.         }
  5978.       # Entweder ist jetzt (mem.total_room >= need), oder aber wir haben gerade
  5979.       # eine GC durchgefⁿhrt. In beiden FΣllen konzentrieren wir uns nun
  5980.       # darauf, heapptr->heap_limit zu vergr÷▀ern.
  5981.       { var reg3 aint needed_limit = heapptr->heap_end + need;
  5982.         if (needed_limit <= heapptr->heap_limit) # hat die GC ihre Arbeit getan?
  5983.           return; # ja -> fertig
  5984.         # Aufrunden bis zur nΣchsten Seitengrenze:
  5985.         #ifndef GENERATIONAL_GC
  5986.         needed_limit = round_up(needed_limit,map_pagesize); # sicher > heapptr->heap_limit
  5987.         #else # map_pagesize bekannterma▀en eine Zweierpotenz
  5988.         needed_limit = (needed_limit + map_pagesize-1) & -map_pagesize; # sicher > heapptr->heap_limit
  5989.         #endif
  5990.         # neuen Speicher allozieren:
  5991.         if (zeromap((void*)(heapptr->heap_limit),needed_limit - heapptr->heap_limit) <0)
  5992.           { if (!done_gc)
  5993.               goto do_gc;
  5994.             #ifdef GENERATIONAL_GC
  5995.             if (!mem.last_gc_full)
  5996.               { gar_col(); goto doing_gc; }
  5997.             #endif
  5998.             fehler_speicher_voll();
  5999.           }
  6000.         heapptr->heap_limit = needed_limit;
  6001.       }
  6002.       # Jetzt ist sicher (heapptr->heap_limit - heapptr->heap_end >= need).
  6003.       # Falls (mem.total_room < need), ignorieren wir das:
  6004.       if (mem.total_room < need) { mem.total_room = need; }
  6005.     }}
  6006.  
  6007. #endif
  6008.  
  6009. #ifdef SPVW_PAGES
  6010.  
  6011. # Schafft Platz fⁿr ein neues Objekt.
  6012. # Falls keiner vorhanden -> Fehlermeldung.
  6013. # make_space(need,heap_ptr,stack_ptr, page);
  6014. # > uintL need: angeforderter Platz in Bytes (eine Variable oder Konstante)
  6015. # > Heap* heap_ptr: Adresse des Heaps, aus dem der Platz genommen werden soll
  6016. # > AVL(AVLID,stack) * stack_ptr: Adressen eines lokalen Stacks,
  6017. #   fⁿr ein spΣteres AVL(AVLID,move)
  6018. # < Pages page: gefundene Page, wo der Platz ist
  6019.   # Der Test, ob Platz vorhanden ist, als Macro, der Rest als Funktion:
  6020.   #define make_space(need,heap_ptr,stack_ptr,pagevar)  \
  6021.     { pagevar = AVL(AVLID,least)(need,&(heap_ptr)->inuse,stack_ptr);    \
  6022.       if (pagevar==EMPTY)                                               \
  6023.         { pagevar = make_space_gc(need,&(heap_ptr)->inuse,stack_ptr); } \
  6024.     }
  6025.   local Pages make_space_gc (uintL need, Pages* pages_ptr, AVL(AVLID,stack) * stack_ptr);
  6026.   local Pages make_space_gc(need,pages_ptr,stack_ptr)
  6027.     var reg2 uintL need;
  6028.     var reg3 Pages* pages_ptr;
  6029.     var reg4 AVL(AVLID,stack) * stack_ptr;
  6030.     { # AVL(AVLID,least)(need,pages_ptr,stack_ptr) == EMPTY
  6031.       # ist schon abgeprⁿft, also
  6032.         # Nicht genⁿgend Platz
  6033.         not_enough_room:
  6034.         #define handle_interrupt_after_gc()  \
  6035.           { # Teste auf Tastatur-Unterbrechung                                    \
  6036.             interruptp(                                                           \
  6037.               { pushSTACK(S(gc)); tast_break();                                   \
  6038.                {var reg1 Pages page = AVL(AVLID,least)(need,pages_ptr,stack_ptr); \
  6039.                 if (page==EMPTY) goto not_enough_room;                            \
  6040.                   else                                                            \
  6041.                   return page;                                                    \
  6042.               }});                                                                \
  6043.           }
  6044.         #if !defined(AVL_SEPARATE)
  6045.         #define make_space_using_malloc()  \
  6046.           # versuche, beim Betriebssystem Platz zu bekommen:                        \
  6047.           { var reg5 uintL size1 = round_up(need,sizeof(cons_));                    \
  6048.             if (size1 < std_page_size) { size1 = std_page_size; }                   \
  6049.            {var reg7 uintL size2 = size1 + sizeof(NODE) + (Varobject_alignment-1);  \
  6050.             var reg6 aint addr = (aint)mymalloc(size2);                             \
  6051.             if (!((void*)addr == NULL))                                             \
  6052.               { # Page vom Betriebssystem bekommen.                                 \
  6053.                 var reg1 Pages page = (Pages)addr;                                  \
  6054.                 page->m_start = addr; page->m_length = size2;                       \
  6055.                 # Initialisieren:                                                   \
  6056.                 page->page_start = page->page_end = page_start0(page);              \
  6057.                 page->page_room = size1;                                            \
  6058.                 # Diesem Heap zuschlagen:                                           \
  6059.                 *pages_ptr = AVL(AVLID,insert1)(page,*pages_ptr);                   \
  6060.                 if (!(AVL(AVLID,least)(need,pages_ptr,stack_ptr) == page)) abort(); \
  6061.                 mem.total_space += size1;                                           \
  6062.                 return page;                                                        \
  6063.           }}  }
  6064.         #else # AVL_SEPARATE
  6065.         #define make_space_using_malloc()  \
  6066.           # versuche, beim Betriebssystem Platz zu bekommen:                            \
  6067.           { var reg5 uintL size1 = round_up(need,sizeof(cons_));                        \
  6068.             if (size1 < std_page_size) { size1 = std_page_size; }                       \
  6069.             begin_system_call();                                                        \
  6070.            {var reg1 Pages page = (NODE*)malloc(sizeof(NODE));                          \
  6071.             end_system_call();                                                          \
  6072.             if (!(page == NULL))                                                        \
  6073.               { var reg7 uintL size2 = size1 + (Varobject_alignment-1);                 \
  6074.                 var reg6 aint addr = (aint)mymalloc(size2);                             \
  6075.                 if (!((void*)addr == NULL))                                             \
  6076.                   { # Page vom Betriebssystem bekommen.                                 \
  6077.                     page->m_start = addr; page->m_length = size2;                       \
  6078.                     # Initialisieren:                                                   \
  6079.                     page->page_start = page->page_end = page_start0(page);              \
  6080.                     page->page_room = size1;                                            \
  6081.                     # Diesem Heap zuschlagen:                                           \
  6082.                     *pages_ptr = AVL(AVLID,insert1)(page,*pages_ptr);                   \
  6083.                     if (!(AVL(AVLID,least)(need,pages_ptr,stack_ptr) == page)) abort(); \
  6084.                     mem.total_space += size1;                                           \
  6085.                     return page;                                                        \
  6086.                   }                                                                     \
  6087.                   else                                                                  \
  6088.                   { begin_system_call(); free(page); end_system_call(); }               \
  6089.           }}  }
  6090.         #endif
  6091.         if ((need <= std_page_size) && !(mem.free_pages == NULL))
  6092.           { # Eine normalgro▀e Page aus dem allgemeinen Pool entnehmen:
  6093.             var reg1 Pages page = mem.free_pages;
  6094.             mem.free_pages = page->page_gcpriv.next;
  6095.             # page ist bereits korrekt initialisiert:
  6096.             # page->page_start = page->page_end = page_start0(page);
  6097.             # page->page_room =
  6098.             #   round_down(page->m_start + page->m_length,Varobject_alignment)
  6099.             # und diesem Heap zuschlagen:
  6100.             *pages_ptr = AVL(AVLID,insert1)(page,*pages_ptr);
  6101.             if (!(AVL(AVLID,least)(need,pages_ptr,stack_ptr) == page)) abort();
  6102.             mem.total_space += page->page_room;
  6103.             return page;
  6104.           }
  6105.         if (used_space()+need < mem.gctrigger_space)
  6106.           # Benutzter Platz ist seit der letzten GC noch nicht einmal um 25%
  6107.           # angewachsen -> versuche es erstmal beim Betriebssystem;
  6108.           # die GC machen wir, wenn die 25%-Grenze erreicht ist.
  6109.           { make_space_using_malloc(); }
  6110.         { gar_col_simple(); # Garbage Collector aufrufen
  6111.           handle_interrupt_after_gc();
  6112.           # und wieder testen:
  6113.          {var reg1 Pages page = AVL(AVLID,least)(need,pages_ptr,stack_ptr);
  6114.           if (page==EMPTY)
  6115.             { if (!mem.last_gc_compacted)
  6116.                 { gar_col_compact(); # kompaktierenden Garbage Collector aufrufen
  6117.                   handle_interrupt_after_gc();
  6118.                   page = AVL(AVLID,least)(need,pages_ptr,stack_ptr);
  6119.                 }
  6120.               if (page==EMPTY)
  6121.                 # versuche es nun doch beim Betriebssystem:
  6122.                 { make_space_using_malloc();
  6123.                   fehler_speicher_voll();
  6124.             }   }
  6125.           # .reserve behandeln??
  6126.           return page;
  6127.         }}
  6128.         #undef make_space_using_malloc
  6129.         #undef handle_interrupt_after_gc
  6130.     }
  6131.  
  6132. #endif
  6133.  
  6134. # Macro zur Speicher-Allozierung eines Lisp-Objekts:
  6135. # allocate(type,flag,size,ptrtype,ptr,statement)
  6136. # > type: Expression, die den Typcode liefert
  6137. # > flag: ob Objekt variabler LΣnge oder nicht
  6138. # > size: Expression (constant oder var), die die Gr÷▀e des ben÷tigten
  6139. #         Speicherstⁿcks angibt
  6140. # ptrtype: C-Typ von ptr
  6141. # ptr: C-Variable
  6142. # Ein Speicherstⁿck der LΣnge size, passend zu einem Lisp-Objekt vom Typ type,
  6143. # wird geholt und ptr auf seine Anfangsadresse gesetzt. Dann wird statement
  6144. # ausgefⁿhrt (Initialisierung des Speicherstⁿcks) und schlie▀lich ptr,
  6145. # mit der korrekten Typinfo versehen, als Ergebnis geliefert.
  6146.   #ifdef SPVW_BLOCKS
  6147.    #ifdef SPVW_MIXED_BLOCKS_OPPOSITE
  6148.     #define allocate(type_expr,flag,size_expr,ptrtype,ptrvar,statement)  \
  6149.       allocate_##flag (type_expr,size_expr,ptrtype,ptrvar,statement)
  6150.     # Objekt variabler LΣnge:
  6151.     #define allocate_TRUE(type_expr,size_expr,ptrtype,ptrvar,statement)  \
  6152.       { make_space(size_expr);                                                        \
  6153.         set_break_sem_1(); # Break sperren                                            \
  6154.        {var reg1 ptrtype ptrvar;                                                      \
  6155.         var reg4 object obj;                                                          \
  6156.         ptrvar = (ptrtype) mem.objects.end; # Pointer auf Speicherstⁿck               \
  6157.         mem.objects.end += (size_expr); # Speicheraufteilung berichtigen              \
  6158.         ptrvar->GCself = obj = type_pointer_object(type_expr,ptrvar); # Selbstpointer \
  6159.         statement; # Speicherstⁿck initialisieren                                     \
  6160.         clr_break_sem_1(); # Break erm÷glichen                                        \
  6161.         CHECK_GC_CONSISTENCY();                                                       \
  6162.         return obj;                                                                   \
  6163.       }}
  6164.     # Cons o.Σ.:
  6165.     #define allocate_FALSE(type_expr,size_expr,ptrtype,ptrvar,statement)  \
  6166.       { make_space(size_expr);                                                         \
  6167.         set_break_sem_1(); # Break sperren                                             \
  6168.        {var reg1 ptrtype ptrvar;                                                       \
  6169.         ptrvar = (ptrtype)(mem.conses.start -= size_expr); # Pointer auf Speicherstⁿck \
  6170.         statement; # Speicherstⁿck initialisieren                                      \
  6171.         clr_break_sem_1(); # Break erm÷glichen                                         \
  6172.         CHECK_GC_CONSISTENCY();                                                        \
  6173.         return type_pointer_object(type_expr,ptrvar);                                  \
  6174.       }}
  6175.    #endif
  6176.    #if defined(SPVW_MIXED_BLOCKS) && defined(TRIVIALMAP_MEMORY)
  6177.     #define allocate(type_expr,flag,size_expr,ptrtype,ptrvar,statement)  \
  6178.       allocate_##flag (type_expr,size_expr,ptrtype,ptrvar,statement)
  6179.     # Objekt variabler LΣnge:
  6180.     #define allocate_TRUE(type_expr,size_expr,ptrtype,ptrvar,statement)  \
  6181.       { make_space(size_expr,&mem.objects);                                           \
  6182.         set_break_sem_1(); # Break sperren                                            \
  6183.        {var reg1 ptrtype ptrvar;                                                      \
  6184.         var reg4 object obj;                                                          \
  6185.         ptrvar = (ptrtype) mem.objects.heap_end; # Pointer auf Speicherstⁿck          \
  6186.         mem.objects.heap_end += (size_expr); # Speicheraufteilung berichtigen         \
  6187.         mem.total_room -= (size_expr);                                                \
  6188.         ptrvar->GCself = obj = type_pointer_object(type_expr,ptrvar); # Selbstpointer \
  6189.         statement; # Speicherstⁿck initialisieren                                     \
  6190.         clr_break_sem_1(); # Break erm÷glichen                                        \
  6191.         CHECK_GC_CONSISTENCY();                                                       \
  6192.         return obj;                                                                   \
  6193.       }}
  6194.     # Cons o.Σ.:
  6195.     #define allocate_FALSE(type_expr,size_expr,ptrtype,ptrvar,statement)  \
  6196.       { make_space(size_expr,&mem.conses);                                                   \
  6197.         set_break_sem_1(); # Break sperren                                                   \
  6198.        {var reg1 ptrtype ptrvar = (ptrtype) mem.conses.heap_end; # Pointer auf Speicherstⁿck \
  6199.         mem.conses.heap_end += (size_expr); # Speicheraufteilung berichtigen                 \
  6200.         mem.total_room -= (size_expr);                                                       \
  6201.         statement; # Speicherstⁿck initialisieren                                            \
  6202.         clr_break_sem_1(); # Break erm÷glichen                                               \
  6203.         CHECK_GC_CONSISTENCY();                                                              \
  6204.         return type_pointer_object(type_expr,ptrvar);                                        \
  6205.       }}
  6206.    #endif
  6207.    #ifdef SPVW_PURE
  6208.     #define allocate(type_expr,flag,size_expr,ptrtype,ptrvar,statement)  \
  6209.       { var reg4 tint _type = (type_expr);                                 \
  6210.         var reg3 Heap* heapptr = &mem.heaps[_type];                        \
  6211.         make_space(size_expr,heapptr);                                     \
  6212.         set_break_sem_1(); # Break sperren                                 \
  6213.        {var reg1 ptrtype ptrvar = (ptrtype)(heapptr->heap_end); # Pointer auf Speicherstⁿck \
  6214.         heapptr->heap_end += (size_expr); # Speicheraufteilung berichtigen \
  6215.         mem.total_room -= (size_expr);                                     \
  6216.         allocate_##flag (ptrvar);                                          \
  6217.         statement; # Speicherstⁿck initialisieren                          \
  6218.         clr_break_sem_1(); # Break erm÷glichen                             \
  6219.         CHECK_GC_CONSISTENCY();                                            \
  6220.         return (object)ptrvar;                                             \
  6221.       }}
  6222.     # Objekt variabler LΣnge:
  6223.     #define allocate_TRUE(ptrvar)  \
  6224.       ptrvar->GCself = (object)ptrvar; # Selbstpointer eintragen
  6225.     # Cons o.Σ.:
  6226.     #define allocate_FALSE(ptrvar)
  6227.    #endif
  6228.   #endif
  6229.   #ifdef SPVW_PAGES
  6230.     #define allocate(type_expr,flag,size_expr,ptrtype,ptrvar,statement)  \
  6231.       allocate_##flag (type_expr,size_expr,ptrtype,ptrvar,statement)
  6232.    #ifdef SPVW_MIXED
  6233.     # Objekt variabler LΣnge:
  6234.     #define allocate_TRUE(type_expr,size_expr,ptrtype,ptrvar,statement)  \
  6235.       { # Suche nach der Page mit dem kleinsten page_room >= size_expr:               \
  6236.         var AVL(AVLID,stack) stack;                                                   \
  6237.         var reg2 Pages page;                                                          \
  6238.         make_space(size_expr,&mem.objects,&stack, page);                              \
  6239.         set_break_sem_1(); # Break sperren                                            \
  6240.        {var reg1 ptrtype ptrvar =                                                     \
  6241.           (ptrtype)(page->page_end); # Pointer auf Speicherstⁿck                      \
  6242.         var reg4 object obj;                                                          \
  6243.         ptrvar->GCself = obj = type_pointer_object(type_expr,ptrvar); # Selbstpointer \
  6244.         statement; # Speicherstⁿck initialisieren                                     \
  6245.         page->page_room -= (size_expr); # Speicheraufteilung berichtigen              \
  6246.         page->page_end += (size_expr);                                                \
  6247.         mem.used_space += (size_expr);                                                \
  6248.         AVL(AVLID,move)(&stack); # Page wieder an die richtige Position hΣngen        \
  6249.         clr_break_sem_1(); # Break erm÷glichen                                        \
  6250.         CHECK_AVL_CONSISTENCY();                                                      \
  6251.         CHECK_GC_CONSISTENCY();                                                       \
  6252.         return obj;                                                                   \
  6253.       }}
  6254.     # Cons o.Σ.:
  6255.     #define allocate_FALSE(type_expr,size_expr,ptrtype,ptrvar,statement)  \
  6256.       { # Suche nach der Page mit dem kleinsten page_room >= size_expr = 8: \
  6257.         var reg2 Pages page;                                                \
  6258.         # 1. Versuch: letzte benutzte Page                                  \
  6259.         page = mem.conses.lastused;                                         \
  6260.         if (page->page_room == 0) # Test auf page->page_room < size_expr = sizeof(cons_) \
  6261.           { var AVL(AVLID,stack) stack;                                     \
  6262.             # 2. Versuch:                                                   \
  6263.             make_space(size_expr,&mem.conses,&stack, page);                 \
  6264.             mem.conses.lastused = page;                                     \
  6265.           }                                                                 \
  6266.         set_break_sem_1(); # Break sperren                                  \
  6267.        {var reg1 ptrtype ptrvar =                                           \
  6268.           (ptrtype)(page->page_end); # Pointer auf Speicherstⁿck            \
  6269.         statement; # Speicherstⁿck initialisieren                           \
  6270.         page->page_room -= (size_expr); # Speicheraufteilung berichtigen    \
  6271.         page->page_end += (size_expr);                                      \
  6272.         mem.used_space += (size_expr);                                      \
  6273.         # Da page_room nun =0 geworden oder >=sizeof(cons_) geblieben ist,  \
  6274.         # ist die Sortierreihenfolge der Pages unverΣndert geblieben.       \
  6275.         clr_break_sem_1(); # Break erm÷glichen                              \
  6276.         CHECK_AVL_CONSISTENCY();                                            \
  6277.         CHECK_GC_CONSISTENCY();                                             \
  6278.         return type_pointer_object(type_expr,ptrvar);                       \
  6279.       }}
  6280.    #endif
  6281.    #ifdef SPVW_PURE
  6282.     # Objekt variabler LΣnge:
  6283.     #define allocate_TRUE(type_expr,size_expr,ptrtype,ptrvar,statement)  \
  6284.       { # Suche nach der Page mit dem kleinsten page_room >= size_expr:           \
  6285.         var AVL(AVLID,stack) stack;                                               \
  6286.         var reg2 Pages page;                                                      \
  6287.         var reg4 tint _type = (type_expr);                                        \
  6288.         make_space(size_expr,&mem.heaps[_type],&stack, page);                     \
  6289.         set_break_sem_1(); # Break sperren                                        \
  6290.        {var reg1 ptrtype ptrvar =                                                 \
  6291.           (ptrtype)(page->page_end); # Pointer auf Speicherstⁿck                  \
  6292.         var reg5 object obj;                                                      \
  6293.         ptrvar->GCself = obj = type_pointer_object(_type,ptrvar); # Selbstpointer \
  6294.         statement; # Speicherstⁿck initialisieren                                 \
  6295.         page->page_room -= (size_expr); # Speicheraufteilung berichtigen          \
  6296.         page->page_end += (size_expr);                                            \
  6297.         mem.used_space += (size_expr);                                            \
  6298.         AVL(AVLID,move)(&stack); # Page wieder an die richtige Position hΣngen    \
  6299.         clr_break_sem_1(); # Break erm÷glichen                                    \
  6300.         CHECK_AVL_CONSISTENCY();                                                  \
  6301.         CHECK_GC_CONSISTENCY();                                                   \
  6302.         return obj;                                                               \
  6303.       }}
  6304.     # Cons o.Σ.:
  6305.     #define allocate_FALSE(type_expr,size_expr,ptrtype,ptrvar,statement)  \
  6306.       { # Suche nach der Page mit dem kleinsten page_room >= size_expr = 8: \
  6307.         var reg2 Pages page;                                                \
  6308.         var reg4 tint _type = (type_expr);                                  \
  6309.         var reg3 Heap* heapptr = &mem.heaps[_type];                         \
  6310.         # 1. Versuch: letzte benutzte Page                                  \
  6311.         page = heapptr->lastused;                                           \
  6312.         if (page->page_room == 0) # Test auf page->page_room < size_expr = sizeof(cons_) \
  6313.           { var AVL(AVLID,stack) stack;                                     \
  6314.             # 2. Versuch:                                                   \
  6315.             make_space(size_expr,heapptr,&stack, page);                     \
  6316.             heapptr->lastused = page;                                       \
  6317.           }                                                                 \
  6318.         set_break_sem_1(); # Break sperren                                  \
  6319.        {var reg1 ptrtype ptrvar =                                           \
  6320.           (ptrtype)(page->page_end); # Pointer auf Speicherstⁿck            \
  6321.         statement; # Speicherstⁿck initialisieren                           \
  6322.         page->page_room -= (size_expr); # Speicheraufteilung berichtigen    \
  6323.         page->page_end += (size_expr);                                      \
  6324.         mem.used_space += (size_expr);                                      \
  6325.         # Da page_room nun =0 geworden oder >=sizeof(cons_) geblieben ist,  \
  6326.         # ist die Sortierreihenfolge der Pages unverΣndert geblieben.       \
  6327.         clr_break_sem_1(); # Break erm÷glichen                              \
  6328.         CHECK_AVL_CONSISTENCY();                                            \
  6329.         CHECK_GC_CONSISTENCY();                                             \
  6330.         return type_pointer_object(_type,ptrvar);                           \
  6331.       }}
  6332.    #endif
  6333.   #endif
  6334.  
  6335. # UP, beschafft ein Cons
  6336. # allocate_cons()
  6337. # < ergebnis: Pointer auf neues CONS, mit CAR und CDR =NIL
  6338. # kann GC ausl÷sen
  6339.   global object allocate_cons (void);
  6340.   global object allocate_cons()
  6341.     { allocate(cons_type,FALSE,sizeof(cons_),Cons,ptr,
  6342.                { ptr->cdr = NIL; ptr->car = NIL; }
  6343.               )
  6344.     }
  6345.  
  6346. # UP: Liefert ein neu erzeugtes uninterniertes Symbol mit gegebenem Printnamen.
  6347. # make_symbol(string)
  6348. # > string: Simple-String
  6349. # < ergebnis: neues Symbol mit diesem Namen, mit Home-Package=NIL.
  6350. # kann GC ausl÷sen
  6351.   global object make_symbol (object string);
  6352.   global object make_symbol(string)
  6353.     var reg3 object string;
  6354.     {
  6355.       #ifdef IMMUTABLE_ARRAY
  6356.       string = make_imm_array(string); # String immutabel machen
  6357.       #endif
  6358.       pushSTACK(string); # String retten
  6359.       allocate(symbol_type,TRUE,size_symbol(),Symbol,ptr,
  6360.                { ptr->symvalue = unbound; # leere Wertzelle
  6361.                  ptr->symfunction = unbound; # leere Funktionszelle
  6362.                  ptr->proplist = NIL; # leere Propertyliste
  6363.                  ptr->pname = popSTACK(); # Namen eintragen
  6364.                  ptr->homepackage = NIL; # keine Home-Package
  6365.                }
  6366.               )
  6367.     }
  6368.  
  6369. # UP, beschafft Vektor
  6370. # allocate_vector(len)
  6371. # > len: LΣnge des Vektors
  6372. # < ergebnis: neuer Vektor (Elemente werden mit NIL initialisiert)
  6373. # kann GC ausl÷sen
  6374.   global object allocate_vector (uintL len);
  6375.   global object allocate_vector (len)
  6376.     var reg2 uintL len;
  6377.     { var reg3 uintL need = size_svector(len); # ben÷tigter Speicherplatz
  6378.       allocate(svector_type,TRUE,need,Svector,ptr,
  6379.                { ptr->length = len;
  6380.                 {var reg1 object* p = &ptr->data[0];
  6381.                  dotimesL(len,len, { *p++ = NIL; } ); # Elemente mit NIL vollschreiben
  6382.                }}
  6383.               )
  6384.     }
  6385.  
  6386. # UP, beschafft Bit-Vektor
  6387. # allocate_bit_vector(len)
  6388. # > len: LΣnge des Bitvektors (in Bits)
  6389. # < ergebnis: neuer Bitvektor (LISP-Objekt)
  6390. # kann GC ausl÷sen
  6391.   global object allocate_bit_vector (uintL len);
  6392.   global object allocate_bit_vector (len)
  6393.     var reg2 uintL len;
  6394.     { var reg3 uintL need = size_sbvector(len); # ben÷tigter Speicherplatz in Bytes
  6395.       allocate(sbvector_type,TRUE,need,Sbvector,ptr,
  6396.                { ptr->length = len; } # Keine weitere Initialisierung
  6397.               )
  6398.     }
  6399.  
  6400. # UP, beschafft String
  6401. # allocate_string(len)
  6402. # > len: LΣnge des Strings (in Bytes)
  6403. # < ergebnis: neuer Simple-String (LISP-Objekt)
  6404. # kann GC ausl÷sen
  6405.   global object allocate_string (uintL len);
  6406.   global object allocate_string (len)
  6407.     var reg2 uintL len;
  6408.     { var reg4 uintL need = size_sstring(len); # ben÷tigter Speicherplatz in Bytes
  6409.       allocate(sstring_type,TRUE,need,Sstring,ptr,
  6410.                { ptr->length = len; } # Keine weitere Initialisierung
  6411.               )
  6412.     }
  6413.  
  6414. # UP, beschafft Array
  6415. # allocate_array(flags,rank,type)
  6416. # > uintB flags: Flags
  6417. # > uintC rank: Rang
  6418. # > tint type: Typinfo
  6419. # < ergebnis: LISP-Objekt Array
  6420. # kann GC ausl÷sen
  6421.   global object allocate_array (uintB flags, uintC rank, tint type);
  6422.   global object allocate_array(flags,rank,type)
  6423.     var reg3 uintB flags;
  6424.     var reg5 uintC rank;
  6425.     var reg6 tint type;
  6426.     { var reg2 uintL need = rank;
  6427.       if (flags & bit(arrayflags_fillp_bit)) { need += 1; }
  6428.       if (flags & bit(arrayflags_dispoffset_bit)) { need += 1; }
  6429.       need = size_array(need);
  6430.       allocate(type,TRUE,need,Array,ptr,
  6431.                { ptr->flags = flags; ptr->rank = rank; # Flags und Rang eintragen
  6432.                  ptr->data = NIL; # Datenvektor mit NIL initialisieren
  6433.                }
  6434.               )
  6435.     }
  6436.  
  6437. # UP, beschafft Record
  6438. # allocate_record_(flags_rectype,reclen,type)
  6439. # > uintW flags_rectype: Flags, nΣhere Typinfo
  6440. # > uintC reclen: LΣnge
  6441. # > tint type: Typinfo
  6442. # < ergebnis: LISP-Objekt Record (Elemente werden mit NIL initialisiert)
  6443. # kann GC ausl÷sen
  6444.   global object allocate_record_ (uintW flags_rectype, uintC reclen, tint type);
  6445.   global object allocate_record_(flags_rectype,reclen,type)
  6446.     var reg3 uintW flags_rectype;
  6447.     var reg2 uintC reclen;
  6448.     var reg5 tint type;
  6449.     { var reg2 uintL need = size_record(reclen);
  6450.       allocate(type,TRUE,need,Record,ptr,
  6451.                { *(uintW*)pointerplus(ptr,offsetof(record_,recflags)) = flags_rectype; # Flags, Typ eintragen
  6452.                  ptr->reclength = reclen; # LΣnge eintragen
  6453.                 {var reg1 object* p = &ptr->recdata[0];
  6454.                  dotimespC(reclen,reclen, { *p++ = NIL; } ); # Elemente mit NIL vollschreiben
  6455.                }}
  6456.               )
  6457.     }
  6458.  
  6459. #ifndef case_stream
  6460.  
  6461. # UP, beschafft Stream
  6462. # allocate_stream(flags,rectype,reclen)
  6463. # > uintB strmflags: Flags
  6464. # > uintB strmtype: nΣhere Typinfo
  6465. # > uintC reclen: LΣnge
  6466. # < ergebnis: LISP-Objekt Stream (Elemente werden mit NIL initialisiert)
  6467. # kann GC ausl÷sen
  6468.   global object allocate_stream (uintB strmflags, uintB strmtype, uintC reclen);
  6469.   global object allocate_stream(strmflags,strmtype,reclen)
  6470.     var reg3 uintB strmflags;
  6471.     var reg4 uintB strmtype;
  6472.     var reg2 uintC reclen;
  6473.     { var reg1 object obj = allocate_record(0,Rectype_Stream,reclen,orecord_type);
  6474.       TheRecord(obj)->recdata[0] = Fixnum_0; # Fixnum als Platz fⁿr strmflags und strmtype
  6475.       TheStream(obj)->strmflags = strmflags; TheStream(obj)->strmtype = strmtype;
  6476.       return obj;
  6477.     }
  6478.  
  6479. #endif
  6480.  
  6481. #ifdef FOREIGN
  6482.  
  6483. # UP, beschafft Foreign-Verpackung
  6484. # allocate_foreign(foreign)
  6485. # > foreign: vom Typ FOREIGN
  6486. # < ergebnis: LISP-Objekt, das foreign enthΣlt
  6487. # kann GC ausl÷sen
  6488.   global object allocate_foreign (FOREIGN foreign);
  6489.   global object allocate_foreign(foreign)
  6490.     var reg2 FOREIGN foreign;
  6491.     { var reg1 object result = allocate_bit_vector(sizeof(FOREIGN)*8);
  6492.       TheForeign(result) = foreign;
  6493.       return result;
  6494.     }
  6495.  
  6496. #endif
  6497.  
  6498. #ifdef FOREIGN_HANDLE
  6499.  
  6500. # UP, beschafft Handle-Verpackung
  6501. # allocate_handle(handle)
  6502. # < ergebnis: LISP-Objekt, das handle enthΣlt
  6503.   global object allocate_handle (Handle handle);
  6504.   global object allocate_handle(handle)
  6505.     var reg2 Handle handle;
  6506.     { var reg1 object result = allocate_bit_vector(sizeof(Handle)*8);
  6507.       TheHandle(result) = handle;
  6508.       return result;
  6509.     }
  6510.  
  6511. #endif
  6512.  
  6513. # UP, beschafft Bignum
  6514. # allocate_bignum(len,sign)
  6515. # > uintC len: LΣnge der Zahl (in Digits)
  6516. # > sintB sign: Flag fⁿr Vorzeichen (0 = +, -1 = -)
  6517. # < ergebnis: neues Bignum (LISP-Objekt)
  6518. # kann GC ausl÷sen
  6519.   global object allocate_bignum (uintC len, sintB sign);
  6520.   global object allocate_bignum(len,sign)
  6521.     var reg3 uintC len;
  6522.     var reg5 sintB sign;
  6523.     { var reg4 uintL need = size_bignum(len); # ben÷tigter Speicherplatz in Bytes
  6524.       allocate(bignum_type | (sign & bit(sign_bit_t)),TRUE,need,Bignum,ptr,
  6525.                { ptr->length = len; } # Keine weitere Initialisierung
  6526.               )
  6527.     }
  6528.  
  6529. # UP, beschafft Single-Float
  6530. # allocate_ffloat(value)
  6531. # > ffloat value: Zahlwert (Bit 31 = Vorzeichen)
  6532. # < ergebnis: neues Single-Float (LISP-Objekt)
  6533. # kann GC ausl÷sen
  6534.   global object allocate_ffloat (ffloat value);
  6535.   #ifndef WIDE
  6536.   global object allocate_ffloat(value)
  6537.     var reg3 ffloat value;
  6538.     { allocate(ffloat_type | ((sint32)value<0 ? bit(sign_bit_t) : 0) # Vorzeichenbit aus value
  6539.                ,TRUE,size_ffloat(),Ffloat,ptr,
  6540.                { ptr->float_value = value; }
  6541.               )
  6542.     }
  6543.   #else
  6544.   global object allocate_ffloat(value)
  6545.     var reg3 ffloat value;
  6546.     { return
  6547.         type_data_object(ffloat_type | ((sint32)value<0 ? bit(sign_bit_t) : 0), # Vorzeichenbit aus value
  6548.                          value
  6549.                         );
  6550.     }
  6551.   #endif
  6552.  
  6553. # UP, beschafft Double-Float
  6554. #ifdef intQsize
  6555. # allocate_dfloat(value)
  6556. # > dfloat value: Zahlwert (Bit 63 = Vorzeichen)
  6557. # < ergebnis: neues Double-Float (LISP-Objekt)
  6558. # kann GC ausl÷sen
  6559.   global object allocate_dfloat (dfloat value);
  6560.   global object allocate_dfloat(value)
  6561.     var reg3 dfloat value;
  6562.     { allocate(dfloat_type | ((sint64)value<0 ? bit(sign_bit_t) : 0) # Vorzeichenbit aus value
  6563.                ,TRUE,size_dfloat(),Dfloat,ptr,
  6564.                { ptr->float_value = value; }
  6565.               )
  6566.     }
  6567. #else
  6568. # allocate_dfloat(semhi,mlo)
  6569. # > semhi,mlo: Zahlwert (Bit 31 von semhi = Vorzeichen)
  6570. # < ergebnis: neues Double-Float (LISP-Objekt)
  6571. # kann GC ausl÷sen
  6572.   global object allocate_dfloat (uint32 semhi, uint32 mlo);
  6573.   global object allocate_dfloat(semhi,mlo)
  6574.     var reg3 uint32 semhi;
  6575.     var reg5 uint32 mlo;
  6576.     { allocate(dfloat_type | ((sint32)semhi<0 ? bit(sign_bit_t) : 0) # Vorzeichenbit aus value
  6577.                ,TRUE,size_dfloat(),Dfloat,ptr,
  6578.                { ptr->float_value.semhi = semhi; ptr->float_value.mlo = mlo; }
  6579.               )
  6580.     }
  6581. #endif
  6582.  
  6583. # UP, beschafft Long-Float
  6584. # allocate_lfloat(len,expo,sign)
  6585. # > uintC len: LΣnge der Mantisse (in Digits)
  6586. # > uintL expo: Exponent
  6587. # > signean sign: Vorzeichen (0 = +, -1 = -)
  6588. # < ergebnis: neues Long-Float, noch ohne Mantisse
  6589. # Ein LISP-Objekt liegt erst dann vor, wenn die Mantisse eingetragen ist!
  6590. # kann GC ausl÷sen
  6591.   global object allocate_lfloat (uintC len, uintL expo, signean sign);
  6592.   global object allocate_lfloat(len,expo,sign)
  6593.     var reg3 uintC len;
  6594.     var reg6 uintL expo;
  6595.     var reg5 signean sign;
  6596.     { var reg4 uintL need = size_lfloat(len); # ben÷tigter Speicherplatz in Bytes
  6597.       allocate(lfloat_type | ((tint)sign & bit(sign_bit_t))
  6598.                ,TRUE,need,Lfloat,ptr,
  6599.                { ptr->len = len; ptr->expo = expo; } # Keine weitere Initialisierung
  6600.               )
  6601.     }
  6602.  
  6603. # UP, erzeugt Bruch
  6604. # make_ratio(num,den)
  6605. # > object num: ZΣhler (mu▀ Integer /= 0 sein, relativ prim zu den)
  6606. # > object den: Nenner (mu▀ Integer > 1 sein)
  6607. # < ergebnis: Bruch
  6608. # kann GC ausl÷sen
  6609.   global object make_ratio (object num, object den);
  6610.   global object make_ratio(num,den)
  6611.     var reg4 object num;
  6612.     var reg5 object den;
  6613.     { pushSTACK(den); pushSTACK(num); # Argumente sichern
  6614.      {var reg3 tint type = # Vorzeichen von num ⁿbernehmen
  6615.         #ifdef fast_mtypecode
  6616.         ratio_type | (mtypecode(STACK_0) & bit(sign_bit_t))
  6617.         #else
  6618.         ratio_type | (typecode(num) & bit(sign_bit_t))
  6619.         #endif
  6620.         ;
  6621.       allocate(type,FALSE,sizeof(ratio_),Ratio,ptr,
  6622.                { ptr->rt_num = popSTACK(); # ZΣhler eintragen
  6623.                  ptr->rt_den = popSTACK(); # Nenner eintragen
  6624.                }
  6625.               )
  6626.     }}
  6627.  
  6628. # UP, erzeugt komplexe Zahl
  6629. # make_complex(real,imag)
  6630. # > real: Realteil (mu▀ reelle Zahl sein)
  6631. # > imag: ImaginΣrteil (mu▀ reelle Zahl /= Fixnum 0 sein)
  6632. # < ergebnis: komplexe Zahl
  6633. # kann GC ausl÷sen
  6634.   global object make_complex (object real, object imag);
  6635.   global object make_complex(real,imag)
  6636.     var reg4 object real;
  6637.     var reg5 object imag;
  6638.     { pushSTACK(imag); pushSTACK(real);
  6639.       allocate(complex_type,FALSE,sizeof(complex_),Complex,ptr,
  6640.                { ptr->c_real = popSTACK(); # Realteil eintragen
  6641.                  ptr->c_imag = popSTACK(); # ImaginΣrteil eintragen
  6642.                }
  6643.               )
  6644.     }
  6645.  
  6646. # ------------------------------------------------------------------------------
  6647. #                   ZirkularitΣtenfeststellung
  6648.  
  6649. # UP: Liefert eine Tabelle aller ZirkularitΣten innerhalb eines Objekts.
  6650. # (Eine ZirkularitΣt ist ein in diesem Objekt enthaltenes Teil-Objekt,
  6651. # auf den es mehr als einen Zugriffsweg gibt.)
  6652. # get_circularities(obj,pr_array,pr_closure)
  6653. # > object obj: Objekt
  6654. # > boolean pr_array: Flag, ob Arrayelemente rekursiv als Teilobjekte gelten
  6655. # > boolean pr_closure: Flag, ob Closurekomponenten rekursiv als Teilobjekte gelten
  6656. # < ergebnis: T falls Stackⁿberlauf eintrat,
  6657. #             NIL falls keine ZirkularitΣten vorhanden,
  6658. #             #(0 ...) ein (n+1)-elementiger Vektor, der die Zahl 0 und die n
  6659. #                      ZirkularitΣten als Elemente enthΣlt, n>0.
  6660. # kann GC ausl÷sen
  6661. # Methode:
  6662. # Markiere rekursiv das Objekt, lege dabei die ZirkularitΣten auf den STACK,
  6663. # demarkiere rekursiv das Objekt,
  6664. # alloziere Vektor fⁿr die ZirkularitΣten (kann GC ausl÷sen!),
  6665. # fⁿlle die ZirkularitΣten vom STACK in den Vektor um.
  6666.   global object get_circularities (object obj, boolean pr_array, boolean pr_closure);
  6667.   typedef struct { boolean pr_array;
  6668.                    boolean pr_closure;
  6669.                    uintL counter;
  6670.                    jmp_buf abbruch_context;
  6671.                    object* abbruch_STACK;
  6672.                  }
  6673.           get_circ_global;
  6674.   # Darauf mu▀ man aus den zwei lokalen Routinen heraus zugreifen.
  6675.   local void get_circ_mark (object obj, get_circ_global* env);
  6676.   local void get_circ_unmark (object obj, get_circ_global* env);
  6677.   global object get_circularities(obj,pr_array,pr_closure)
  6678.     var object obj;
  6679.     var boolean pr_array;
  6680.     var boolean pr_closure;
  6681.     { var get_circ_global my_global; # ZΣhler und Kontext (incl. STACK-Wert)
  6682.                                      # fⁿr den Fall eines Abbruchs
  6683.       set_break_sem_1(); # Break unm÷glich machen
  6684.       if (!setjmp(my_global.abbruch_context)) # Kontext abspeichern
  6685.         { my_global.pr_array = pr_array;
  6686.           my_global.pr_closure = pr_closure;
  6687.           my_global.counter = 0; # ZΣhler := 0
  6688.           my_global.abbruch_STACK = STACK;
  6689.           # Die Kontext-Konserve my_global ist jetzt fertig.
  6690.           get_circ_mark(obj,&my_global); # Objekt markieren, mehrfache
  6691.                                          # Strukturen auf dem STACK ablegen
  6692.                                          # in my_global.counter zΣhlen
  6693.           get_circ_unmark(obj,&my_global); # Markierungen wieder l÷schen
  6694.           clr_break_sem_1(); # Break wieder m÷glich
  6695.           { var reg2 uintL n = my_global.counter; # Anzahl der Objekte auf dem STACK
  6696.             if (n==0)
  6697.               return(NIL); # keine da -> NIL zurⁿck und fertig
  6698.               else
  6699.               { var reg3 object vector = allocate_vector(n+1); # Vektor mit n+1 Elementen
  6700.                 # fⁿllen:
  6701.                 var reg1 object* ptr = &TheSvector(vector)->data[0];
  6702.                 *ptr++ = Fixnum_0; # erstes Element = Fixnum 0
  6703.                 # restliche Elemente eintragen (mindestens eins):
  6704.                 dotimespL(n,n, { *ptr++ = popSTACK(); } );
  6705.                 return(vector); # Vektor als Ergebnis
  6706.         } }   }
  6707.         else
  6708.         # nach Abbruch wegen SP- oder STACK-▄berlauf
  6709.         { setSTACK(STACK = my_global.abbruch_STACK); # STACK wieder zurⁿcksetzen
  6710.           # Der Kontext ist jetzt wiederhergestellt.
  6711.           get_circ_unmark(obj,&my_global); # Markierungen wieder l÷schen
  6712.           clr_break_sem_1(); # Break wieder m÷glich
  6713.           return(T); # T als Ergebnis
  6714.         }
  6715.     }
  6716. # UP: markiert das Objekt obj, legt auftretende ZirkularitΣten auf den STACK
  6717. # und zΣhlt sie in env->counter mit.
  6718.   local void get_circ_mark(obj,env)
  6719.     var reg3 object obj;
  6720.     var reg4 get_circ_global* env;
  6721.     { entry:
  6722.       switch (typecode(obj)) # je nach Typ
  6723.         { case cons_type:
  6724.             if (marked(TheCons(obj))) goto m_schon_da; # markiert?
  6725.             { var reg2 object obj_cdr = Cdr(obj); # Komponenten (ohne Markierungsbit)
  6726.               var reg1 object obj_car = Car(obj);
  6727.               mark(TheCons(obj)); # markieren
  6728.               if (SP_overflow()) # SP-Tiefe ⁿberprⁿfen
  6729.                 longjmp(env->abbruch_context,TRUE); # Abbruch
  6730.               get_circ_mark(obj_car,env); # CAR markieren (rekursiv)
  6731.               obj = obj_cdr; goto entry; # CDR markieren (tail-end-rekursiv)
  6732.             }
  6733.           #ifdef IMMUTABLE_CONS
  6734.           case imm_cons_type:
  6735.             if (marked(TheCons(obj))) goto m_schon_da; # markiert?
  6736.             { var reg2 object obj_cdr = Cdr(obj); # Komponenten (ohne Markierungsbit)
  6737.               var reg1 object obj_car = Car(obj);
  6738.               mark(TheImmCons(obj)); # markieren
  6739.               if (SP_overflow()) # SP-Tiefe ⁿberprⁿfen
  6740.                 longjmp(env->abbruch_context,TRUE); # Abbruch
  6741.               get_circ_mark(obj_car,env); # CAR markieren (rekursiv)
  6742.               obj = obj_cdr; goto entry; # CDR markieren (tail-end-rekursiv)
  6743.             }
  6744.           #endif
  6745.           case_symbol:
  6746.             if (marked(TheSymbol(obj))) # markiert?
  6747.               if (eq(Symbol_package(obj),NIL)) # uninterniertes Symbol?
  6748.                 goto m_schon_da; # ja -> war schon da, merken
  6749.                 else
  6750.                 goto m_end; # nein -> war zwar schon da, aber unberⁿcksichtigt lassen
  6751.             # bisher unmarkiertes Symbol
  6752.             mark(TheSymbol(obj)); # markieren
  6753.             goto m_end;
  6754.           case sbvector_type: case bvector_type: # Bit-Vector
  6755.           case sstring_type: case string_type: # String
  6756.           case_bignum: # Bignum
  6757.           #ifndef WIDE
  6758.           case_ffloat: # Single-Float
  6759.           #endif
  6760.           case_dfloat: # Double-Float
  6761.           case_lfloat: # Long-Float
  6762.           case_ratio: # Ratio
  6763.           case_complex: # Complex
  6764.             # Objekt ohne Komponenten, die ausgegeben werden:
  6765.             if (marked(ThePointer(obj))) goto m_schon_da; # markiert?
  6766.             # bisher unmarkiert
  6767.             mark(ThePointer(obj)); # markieren
  6768.             goto m_end;
  6769.           #ifdef IMMUTABLE_ARRAY
  6770.           case imm_sbvector_type: case imm_bvector_type: # immutabler Bit-Vector
  6771.           case imm_sstring_type: case imm_string_type: # immutabler String
  6772.             # immutables Objekt ohne Komponenten, die ausgegeben werden:
  6773.             if (marked(ThePointer(obj))) goto m_schon_da; # markiert?
  6774.             # bisher unmarkiert
  6775.             mark(TheImmArray(obj)); # markieren
  6776.             goto m_end;
  6777.           #endif
  6778.           case svector_type: # Simple-Vector
  6779.             if (marked(TheSvector(obj))) goto m_schon_da; # markiert?
  6780.             # bisher unmarkiert
  6781.             mark(TheSvector(obj)); # markieren
  6782.             m_svector:
  6783.             if (env->pr_array) # Komponenten weiterzuverfolgen?
  6784.               { var reg2 uintL count = TheSvector(obj)->length;
  6785.                 if (!(count==0))
  6786.                   # markiere count>0 Komponenten
  6787.                   { var reg1 object* ptr = &TheSvector(obj)->data[0];
  6788.                     if (SP_overflow()) # SP-Tiefe ⁿberprⁿfen
  6789.                       longjmp(env->abbruch_context,TRUE); # Abbruch
  6790.                     dotimespL(count,count, { get_circ_mark(*ptr++,env); } ); # markiere Komponenten (rekursiv)
  6791.               }   }
  6792.             goto m_end;
  6793.           case array_type: case vector_type:
  6794.             # Nicht-simpler Array mit Komponenten, die Objekte sind:
  6795.             if (marked(TheArray(obj))) goto m_schon_da; # markiert?
  6796.             # bisher unmarkiert
  6797.             mark(TheArray(obj)); # markieren
  6798.             m_array:
  6799.             if (env->pr_array) # Komponenten weiterzuverfolgen?
  6800.               { obj=TheArray(obj)->data; goto entry; } # Datenvektor (tail-end-rekursiv) markieren
  6801.               else
  6802.               goto m_end;
  6803.           #ifdef IMMUTABLE_ARRAY
  6804.           case imm_svector_type: # immutabler Simple-Vector
  6805.             if (marked(TheSvector(obj))) goto m_schon_da; # markiert?
  6806.             # bisher unmarkiert
  6807.             mark(TheImmSvector(obj)); # markieren
  6808.             goto m_svector;
  6809.           case imm_array_type: case imm_vector_type:
  6810.             # immutabler nicht-simpler Array mit Komponenten, die Objekte sind:
  6811.             if (marked(TheArray(obj))) goto m_schon_da; # markiert?
  6812.             # bisher unmarkiert
  6813.             mark(TheImmArray(obj)); # markieren
  6814.             goto m_array;
  6815.           #endif
  6816.           case_closure: # Closure
  6817.             if (marked(TheClosure(obj))) goto m_schon_da; # markiert?
  6818.             # bisher unmarkiert
  6819.             mark(TheClosure(obj)); # markieren
  6820.             if (env->pr_closure) # Komponenten weiterzuverfolgen?
  6821.               goto m_record_components; # alle Komponenten werden ausgeben (s. unten)
  6822.               else # nur den Namen (tail-end-rekursiv) markieren
  6823.               { obj=TheClosure(obj)->clos_name; goto entry; }
  6824.           case_structure: # Structure
  6825.             if (marked(TheStructure(obj))) goto m_schon_da; # markiert?
  6826.             # bisher unmarkiert
  6827.             mark(TheStructure(obj)); # markieren
  6828.             goto m_record_components;
  6829.           case_stream: # Stream
  6830.             if (marked(TheStream(obj))) goto m_schon_da; # markiert?
  6831.             # bisher unmarkiert
  6832.             mark(TheStream(obj));
  6833.             switch (TheStream(obj)->strmtype)
  6834.               { case strmtype_broad:
  6835.                 case strmtype_concat:
  6836.                   goto m_record_components;
  6837.                 default:
  6838.                   goto m_end;
  6839.               }
  6840.           case_instance: # CLOS-Instanz
  6841.             if (marked(TheInstance(obj))) goto m_schon_da; # markiert?
  6842.             # bisher unmarkiert
  6843.             mark(TheInstance(obj)); # markieren
  6844.             goto m_record_components;
  6845.           case_orecord: # sonstigen Record markieren:
  6846.             if (marked(TheRecord(obj))) goto m_schon_da; # markiert?
  6847.             # bisher unmarkiert
  6848.             mark(TheRecord(obj)); # markieren
  6849.             switch (TheRecord(obj)->rectype)
  6850.               { case Rectype_Hashtable:
  6851.                   # Hash-Table: je nach Array-Ausgabe-Flag
  6852.                   if (env->pr_array) break; else goto m_end;
  6853.                 case Rectype_Package:
  6854.                   # Packages werden nicht komponentenweise ausgegeben
  6855.                   goto m_end;
  6856.                 case Rectype_Readtable:
  6857.                   # Readtables werden nicht komponentenweise ausgegeben
  6858.                   goto m_end;
  6859.                 #ifndef case_structure
  6860.                 case Rectype_Structure: goto case_structure;
  6861.                 #endif
  6862.                 #ifndef case_stream
  6863.                 case Rectype_Stream: goto case_stream;
  6864.                 #endif
  6865.                 default: break;
  6866.               }
  6867.             # Pathnames, Random-States, Bytes, Fsubrs, Loadtimeevals,
  6868.             # Symbol-Macros, Aliens und evtl. Hash-Tables werden evtl.
  6869.             # komponentenweise ausgegeben.
  6870.             m_record_components: # Komponenten eines Records markieren:
  6871.               { var reg2 uintC count = TheRecord(obj)->reclength;
  6872.                 if (!(count==0))
  6873.                   # markiere count>0 Komponenten
  6874.                   { var reg1 object* ptr = &TheRecord(obj)->recdata[0];
  6875.                     if (SP_overflow()) # SP-Tiefe ⁿberprⁿfen
  6876.                       longjmp(env->abbruch_context,TRUE); # Abbruch
  6877.                     dotimespC(count,count, { get_circ_mark(*ptr++,env); } ); # markiere Komponenten (rekursiv)
  6878.               }   }
  6879.             goto m_end;
  6880.           m_schon_da:
  6881.             # Objekt wurde markiert, war aber schon markiert.
  6882.             # Es ist eine ZirkularitΣt.
  6883.             if (STACK_overflow()) # STACK-Tiefe ⁿberprⁿfen
  6884.               longjmp(env->abbruch_context,TRUE); # Abbruch
  6885.             # Objekt mit gel÷schtem garcol_bit im STACK ablegen:
  6886.             pushSTACK(without_mark_bit(obj));
  6887.             env->counter++; # und mitzΣhlen
  6888.             goto m_end;
  6889.           case_machine: # Maschinenpointer
  6890.           case_char: # Character
  6891.           case_subr: # Subr
  6892.           case_system: # Frame-pointer, Read-label, system
  6893.           case_fixnum: # Fixnum
  6894.           case_sfloat: # Short-Float
  6895.           #ifdef WIDE
  6896.           case_ffloat: # Single-Float
  6897.           #endif
  6898.           default:
  6899.             # Objekt kann nicht markiert werden -> fertig
  6900.             goto m_end;
  6901.           m_end: ; # fertig
  6902.     }   }
  6903. # UP: Demarkiert Objekt obj.
  6904.   local void get_circ_unmark(obj,env)
  6905.     var reg2 object obj;
  6906.     var reg3 get_circ_global* env;
  6907.     { entry:
  6908.       switch (typecode(obj) & ~bit(garcol_bit_t)) # je nach Typinfo ohne garcol_bit
  6909.         { case cons_type:
  6910.             if (!marked(TheCons(obj))) goto u_end; # schon demarkiert?
  6911.             unmark(TheCons(obj)); # demarkieren
  6912.             get_circ_unmark(Car(obj),env); # CAR demarkieren (rekursiv)
  6913.             obj=Cdr(obj); goto entry; # CDR demarkieren (tail-end-rekursiv)
  6914.           #ifdef IMMUTABLE_CONS
  6915.           case imm_cons_type:
  6916.             if (!marked(TheCons(obj))) goto u_end; # schon demarkiert?
  6917.             unmark(TheImmCons(obj)); # demarkieren
  6918.             get_circ_unmark(Car(obj),env); # CAR demarkieren (rekursiv)
  6919.             obj=Cdr(obj); goto entry; # CDR demarkieren (tail-end-rekursiv)
  6920.           #endif
  6921.           case_symbol:
  6922.             # Symbol demarkieren. Wertzelle etc. fⁿr PRINT unwesentlich.
  6923.           case sbvector_type: case bvector_type: # Bit-Vector
  6924.           case sstring_type: case string_type: # String
  6925.           case_bignum: # Bignum
  6926.           #ifndef WIDE
  6927.           case_ffloat: # Single-Float
  6928.           #endif
  6929.           case_dfloat: # Double-Float
  6930.           case_lfloat: # Long-Float
  6931.           case_ratio: # Ratio
  6932.           case_complex: # Complex
  6933.             # Objekt demarkieren, das keine markierten Komponenten hat:
  6934.             unmark(ThePointer(obj)); # demarkieren
  6935.             goto u_end;
  6936.           #ifdef IMMUTABLE_ARRAY
  6937.           case imm_sbvector_type: case imm_bvector_type: # immutabler Bit-Vector
  6938.           case imm_sstring_type: case imm_string_type: # immutabler String
  6939.             # immutables Objekt demarkieren, das keine markierten Komponenten hat:
  6940.             unmark(TheImmArray(obj)); # demarkieren
  6941.             goto u_end;
  6942.           #endif
  6943.           case svector_type:
  6944.             # Simple-Vector demarkieren, seine Komponenten ebenfalls:
  6945.             if (!marked(TheSvector(obj))) goto u_end; # schon demarkiert?
  6946.             unmark(TheSvector(obj)); # demarkieren
  6947.             u_svector:
  6948.             if (env->pr_array) # wurden die Komponenten weiterverfolgt?
  6949.               { var reg2 uintL count = TheSvector(obj)->length;
  6950.                 if (!(count==0))
  6951.                   # demarkiere count>0 Komponenten
  6952.                   { var reg1 object* ptr = &TheSvector(obj)->data[0];
  6953.                     dotimespL(count,count, { get_circ_unmark(*ptr++,env); } ); # demarkiere Komponenten (rekursiv)
  6954.               }   }
  6955.             goto u_end;
  6956.           case array_type: case vector_type:
  6957.             # Nicht-simpler Array mit Komponenten, die Objekte sind:
  6958.             if (!marked(TheArray(obj))) goto u_end; # schon demarkiert?
  6959.             unmark(TheArray(obj)); # demarkieren
  6960.             u_array:
  6961.             if (env->pr_array) # wurden die Komponenten weiterverfolgt?
  6962.               { obj=TheArray(obj)->data; goto entry; } # Datenvektor (tail-end-rekursiv) demarkieren
  6963.               else
  6964.               goto u_end;
  6965.           #ifdef IMMUTABLE_ARRAY
  6966.           case imm_svector_type:
  6967.             # immutablen Simple-Vector demarkieren, seine Komponenten ebenfalls:
  6968.             if (!marked(TheSvector(obj))) goto u_end; # schon demarkiert?
  6969.             unmark(TheImmSvector(obj)); # demarkieren
  6970.             goto u_svector;
  6971.           case imm_array_type: case imm_vector_type:
  6972.             # immutabler nicht-simpler Array mit Komponenten, die Objekte sind:
  6973.             if (!marked(TheArray(obj))) goto u_end; # schon demarkiert?
  6974.             unmark(TheImmArray(obj)); # demarkieren
  6975.             goto u_array;
  6976.           #endif
  6977.           case_closure: # Closure demarkieren
  6978.             if (!marked(TheClosure(obj))) goto u_end; # schon demarkiert?
  6979.             unmark(TheClosure(obj)); # demarkieren
  6980.             if (env->pr_closure) # wurden Komponenten weiterverfolgt?
  6981.               goto u_record_components; # alle Komponenten werden ausgeben (s. unten)
  6982.               else # nur den Namen (tail-end-rekursiv) demarkieren
  6983.               { obj=TheClosure(obj)->clos_name; goto entry; }
  6984.           case_structure: # Structure demarkieren:
  6985.             if (!marked(TheStructure(obj))) goto u_end; # schon demarkiert?
  6986.             unmark(TheStructure(obj)); # demarkieren
  6987.             goto u_record_components;
  6988.           case_stream: # Stream demarkieren:
  6989.             if (!marked(TheStream(obj))) goto u_end; # schon demarkiert?
  6990.             unmark(TheStream(obj)); # demarkieren
  6991.             switch (TheStream(obj)->strmtype)
  6992.               { case strmtype_broad:
  6993.                 case strmtype_concat:
  6994.                   goto u_record_components;
  6995.                 default:
  6996.                   goto u_end;
  6997.               }
  6998.           case_instance: # CLOS-Instanz demarkieren:
  6999.             if (!marked(TheInstance(obj))) goto u_end; # schon demarkiert?
  7000.             unmark(TheInstance(obj)); # demarkieren
  7001.             goto u_record_components;
  7002.           case_orecord: # sonstigen Record demarkieren:
  7003.             if (!marked(TheRecord(obj))) goto u_end; # schon demarkiert?
  7004.             unmark(TheRecord(obj)); # demarkieren
  7005.             switch (TheRecord(obj)->rectype)
  7006.               { case Rectype_Hashtable:
  7007.                   # Hash-Table: je nach Array-Ausgabe-Flag
  7008.                   if (env->pr_array) break; else goto u_end;
  7009.                 case Rectype_Package:
  7010.                   # Packages werden nicht komponentenweise ausgegeben
  7011.                   goto u_end;
  7012.                 case Rectype_Readtable:
  7013.                   # Readtables werden nicht komponentenweise ausgegeben
  7014.                   goto u_end;
  7015.                 #ifndef case_structure
  7016.                 case Rectype_Structure: goto case_structure;
  7017.                 #endif
  7018.                 #ifndef case_stream
  7019.                 case Rectype_Stream: goto case_stream;
  7020.                 #endif
  7021.                 default: break;
  7022.               }
  7023.             # Pathnames, Random-States, Bytes, Fsubrs, Loadtimeevals,
  7024.             # Symbol-Macros, Aliens und evtl. Hash-Tables werden evtl.
  7025.             # komponentenweise ausgegeben.
  7026.             u_record_components: # Komponenten eines Records demarkieren:
  7027.               { var reg2 uintC count = TheRecord(obj)->reclength;
  7028.                 if (!(count==0))
  7029.                   # demarkiere count>0 Komponenten
  7030.                   { var reg1 object* ptr = &TheRecord(obj)->recdata[0];
  7031.                     dotimespC(count,count, { get_circ_unmark(*ptr++,env); } ); # demarkiere Komponenten (rekursiv)
  7032.               }   }
  7033.             goto u_end;
  7034.           case_machine: # Maschinenpointer
  7035.           case_char: # Character
  7036.           case_subr: # Subr
  7037.           case_system: # Frame-pointer, Read-label, system
  7038.           case_fixnum: # Fixnum
  7039.           case_sfloat: # Short-Float
  7040.           #ifdef WIDE
  7041.           case_ffloat: # Single-Float
  7042.           #endif
  7043.           default:
  7044.             # Objekt demarkieren, das gar keine Markierung haben kann:
  7045.             goto u_end;
  7046.           u_end: ; # fertig
  7047.     }   }
  7048.  
  7049. # UP: Entflicht #n# - Referenzen im Objekt *ptr mit Hilfe der Aliste alist.
  7050. # > *ptr : Objekt
  7051. # > alist : Aliste (Read-Label --> zu substituierendes Objekt)
  7052. # < *ptr : Objekt mit entflochtenen Referenzen
  7053. # < ergebnis : fehlerhafte Referenz oder nullobj falls alles OK
  7054.   global object subst_circ (object* ptr, object alist);
  7055. #
  7056. # ZirkularitΣtenberⁿcksichtigung ist n÷tig, damit die Substitution sich von
  7057. # zyklischen Strukturen, wie sie sich bei #. (insbesondere #.(FIND-CLASS 'FOO))
  7058. # ergeben k÷nnen, nicht durcheinanderbringen lΣ▀t.
  7059.  
  7060. #if 0 # ohne ZirkularitΣtenberⁿcksichtigung
  7061.  
  7062.   local void subst (object* ptr);
  7063.   local object subst_circ_alist;
  7064.   local jmp_buf subst_circ_jmpbuf;
  7065.   local object subst_circ_bad;
  7066.   global object subst_circ(ptr,alist)
  7067.     var reg1 object* ptr;
  7068.     var reg2 object alist;
  7069.     { subst_circ_alist = alist;
  7070.       if (!setjmp(subst_circ_jmpbuf))
  7071.         { subst(ptr); return nullobj; }
  7072.         else
  7073.         # Abbruch wegen fehlerhafter Referenz
  7074.         { return subst_circ_bad; }
  7075.     }
  7076.   local void subst(ptr)
  7077.     var reg2 object ptr;
  7078.     { check_SP();
  7079.       enter_subst:
  7080.      {var reg1 object obj = *ptr;
  7081.       # Fallunterscheidung nach Typ:
  7082.       # Objekte ohne Teilobjekte (Maschinenpointer, Bit-Vektoren,
  7083.       # Strings, Characters, SUBRs, Integers, Floats) enthalten
  7084.       # keine Referenzen. Ebenso Symbole und rationale Zahlen (bei ihnen
  7085.       # k÷nnen die Teilobjekte nicht in #n= - Syntax eingegeben worden
  7086.       # sein) und komplexe Zahlen (fⁿr ihre Komponenten sind nur
  7087.       # Integers, Floats, rationale Zahlen zugelassen, also Objekte,
  7088.       # die ihrerseits keine Referenzen enthalten k÷nnen).
  7089.       switch (mtypecode(*ptr))
  7090.         { case svector_type: # Simple-Vector
  7091.             # alle Elemente durchlaufen:
  7092.             { var reg4 uintL len = TheSvector(obj)->length;
  7093.               if (!(len==0))
  7094.                 { var reg3 object* objptr = &TheSvector(obj)->data[0];
  7095.                   dotimespL(len,len, { subst(&(*objptr++)); } );
  7096.             }   }
  7097.             break;
  7098.           case array_type:
  7099.           case vector_type:
  7100.             # nicht-simpler Array, kein String oder Bit-Vektor
  7101.             # Datenvektor durchlaufen: endrekursiv subst(Datenvektor)
  7102.             ptr = &TheArray(obj)->data; goto enter_subst;
  7103.           #ifdef IMMUTABLE_ARRAY
  7104.           case imm_svector_type: # immutabler Simple-Vector
  7105.             # alle Elemente durchlaufen:
  7106.             { var reg4 uintL len = TheSvector(obj)->length;
  7107.               if (!(len==0))
  7108.                 { var reg3 object* objptr = &TheImmSvector(obj)->data[0];
  7109.                   dotimespL(len,len, { subst(&(*objptr++)); } );
  7110.             }   }
  7111.             break;
  7112.           case imm_array_type:
  7113.           case imm_vector_type:
  7114.             # nicht-simpler Array, kein String oder Bit-Vektor
  7115.             # Datenvektor durchlaufen: endrekursiv subst(Datenvektor)
  7116.             ptr = &TheImmArray(obj)->data; goto enter_subst;
  7117.           #endif
  7118.           case_record: # Record
  7119.             # alle Elemente durchlaufen:
  7120.             { var reg4 uintC len = TheRecord(obj)->reclength;
  7121.               if (!(len==0))
  7122.                 { var reg3 object* objptr = &TheRecord(obj)->recdata[0];
  7123.                   dotimespC(len,len, { subst(&(*objptr++)); } );
  7124.             }   }
  7125.             break;
  7126.           case_system: # Frame-Pointer oder Read-Label oder System
  7127.             if (as_oint(obj) & wbit(0+oint_addr_shift))
  7128.               # Read-Label oder System
  7129.               if (as_oint(obj) & wbit(oint_data_len-1+oint_addr_shift))
  7130.                 {} # System
  7131.                 else
  7132.                 # Read-Label
  7133.                 { # Read-Label obj in der Aliste suchen:
  7134.                   var reg4 object alist = subst_circ_alist;
  7135.                   while (consp(alist))
  7136.                     { var reg3 object acons = Car(alist);
  7137.                       if (eq(Car(acons),obj))
  7138.                         # gefunden
  7139.                         { # *ptr = obj = (car acons) durch (cdr acons) ersetzen:
  7140.                           *ptr = Cdr(acons);
  7141.                           return;
  7142.                         }
  7143.                       alist = Cdr(alist);
  7144.                     }
  7145.                   # nicht gefunden -> Abbruch
  7146.                   subst_circ_bad = obj;
  7147.                   longjmp(subst_circ_jmpbuf,TRUE);
  7148.                 }
  7149.               else
  7150.               # Frame-Pointer
  7151.               {}
  7152.             break;
  7153.           case cons_type: # Cons
  7154.             # rekursiv: subst(&Car(obj))
  7155.             subst(&Car(obj));
  7156.             # endrekursiv: subst(&Cdr(obj))
  7157.             ptr = &Cdr(obj); goto enter_subst;
  7158.           #ifdef IMMUTABLE_CONS
  7159.           case imm_cons_type: # immutables Cons
  7160.             # rekursiv: subst(&Car(obj))
  7161.             subst(&TheImmCons(obj)->car);
  7162.             # endrekursiv: subst(&Cdr(obj))
  7163.             ptr = &TheImmCons(obj)->cdr; goto enter_subst;
  7164.           #endif
  7165.           case_machine: # Maschinenpointer
  7166.           case_bvector: # Bit-Vektor
  7167.           case_string: # String
  7168.           case_char: # Character
  7169.           case_subr: # SUBR
  7170.           case_number: # Zahl
  7171.           case_symbol: # Symbol
  7172.             # Objekt enthΣlt keine Referenzen -> nichts zu tun
  7173.             break;
  7174.           default: NOTREACHED
  7175.     }}  }
  7176.  
  7177. #else # mit ZirkularitΣtenberⁿcksichtigung
  7178.  
  7179. # Methode:
  7180. # Markiere rekursiv die Objekte, in denen die Substitution gerade durchgefⁿhrt
  7181. # wird/wurde. Danach demarkiere rekursiv das Objekt.
  7182.  
  7183.   local void subst_circ_mark (object* ptr);
  7184.   local void subst_circ_unmark (object* ptr);
  7185.   local object subst_circ_alist;
  7186.   local jmp_buf subst_circ_jmpbuf;
  7187.   local object subst_circ_bad;
  7188.   global object subst_circ(ptr,alist)
  7189.     var object* ptr;
  7190.     var reg1 object alist;
  7191.     { subst_circ_alist = alist;
  7192.       set_break_sem_1(); # Break unm÷glich machen
  7193.       if (!setjmp(subst_circ_jmpbuf))
  7194.         { subst_circ_mark(ptr); # markieren und substituieren
  7195.           subst_circ_unmark(ptr); # Markierungen wieder l÷schen
  7196.           clr_break_sem_1(); # Break wieder m÷glich
  7197.           return nullobj;
  7198.         }
  7199.         else
  7200.         # Abbruch aus subst_circ_mark() heraus
  7201.         { subst_circ_unmark(ptr); # erst alles demarkieren
  7202.           clr_break_sem_1(); # Break wieder m÷glich
  7203.           if (!eq(subst_circ_bad,nullobj)) # wegen fehlerhafter Referenz?
  7204.             { return subst_circ_bad; }
  7205.             else # sonst war's SP-▄berlauf
  7206.             { SP_ueber(); }
  7207.     }   }
  7208.   local void subst_circ_mark(ptr)
  7209.     var reg2 object* ptr;
  7210.     { if (SP_overflow()) # SP-Tiefe ⁿberprⁿfen
  7211.         { subst_circ_bad = nullobj; longjmp(subst_circ_jmpbuf,TRUE); } # Abbruch
  7212.       enter_subst:
  7213.      {var reg1 object obj = without_mark_bit(*ptr);
  7214.       # Fallunterscheidung nach Typ:
  7215.       # Objekte ohne Teilobjekte (Maschinenpointer, Bit-Vektoren,
  7216.       # Strings, Characters, SUBRs, Integers, Floats) enthalten
  7217.       # keine Referenzen. Ebenso Symbole und rationale Zahlen (bei ihnen
  7218.       # k÷nnen die Teilobjekte nicht in #n= - Syntax eingegeben worden
  7219.       # sein) und komplexe Zahlen (fⁿr ihre Komponenten sind nur
  7220.       # Integers, Floats, rationale Zahlen zugelassen, also Objekte,
  7221.       # die ihrerseits keine Referenzen enthalten k÷nnen).
  7222.       switch (typecode(obj))
  7223.         { case svector_type: # Simple-Vector
  7224.             if (marked(TheSvector(obj))) return; # Objekt schon markiert?
  7225.             mark(TheSvector(obj)); # markieren
  7226.             # alle Elemente durchlaufen:
  7227.             { var reg4 uintL len = TheSvector(obj)->length;
  7228.               if (!(len==0))
  7229.                 { var reg3 object* objptr = &TheSvector(obj)->data[0];
  7230.                   dotimespL(len,len, { subst_circ_mark(&(*objptr++)); } );
  7231.             }   }
  7232.             return;
  7233.           case array_type:
  7234.           case vector_type:
  7235.             # nicht-simpler Array, kein String oder Bit-Vektor
  7236.             if (marked(TheArray(obj))) return; # Objekt schon markiert?
  7237.             mark(TheArray(obj)); # markieren
  7238.             # Datenvektor durchlaufen: endrekursiv subst_circ_mark(Datenvektor)
  7239.             ptr = &TheArray(obj)->data; goto enter_subst;
  7240.           #ifdef IMMUTABLE_ARRAY
  7241.           case imm_svector_type: # immutabler Simple-Vector
  7242.             if (marked(TheSvector(obj))) return; # Objekt schon markiert?
  7243.             mark(TheImmSvector(obj)); # markieren
  7244.             # alle Elemente durchlaufen:
  7245.             { var reg4 uintL len = TheSvector(obj)->length;
  7246.               if (!(len==0))
  7247.                 { var reg3 object* objptr = &TheImmSvector(obj)->data[0];
  7248.                   dotimespL(len,len, { subst_circ_mark(&(*objptr++)); } );
  7249.             }   }
  7250.             return;
  7251.           case imm_array_type:
  7252.           case imm_vector_type:
  7253.             # nicht-simpler Array, kein String oder Bit-Vektor
  7254.             if (marked(TheArray(obj))) return; # Objekt schon markiert?
  7255.             mark(TheImmArray(obj)); # markieren
  7256.             # Datenvektor durchlaufen: endrekursiv subst_circ_mark(Datenvektor)
  7257.             ptr = &TheImmArray(obj)->data; goto enter_subst;
  7258.           #endif
  7259.           case_record: # Record
  7260.             if (marked(TheRecord(obj))) return; # Objekt schon markiert?
  7261.             mark(TheRecord(obj)); # markieren
  7262.             # Beim Ersetzen von Read-Labels in Hash-Tables verliert deren
  7263.             # Aufbau seinen Gⁿltigkeit (denn die Hashfunktion der in ihr
  7264.             # gespeicherten Objekte verΣndert sich).
  7265.             if ((sintB)(TheRecord(obj)->rectype) < 0) # eine Hash-Table ?
  7266.               { mark_ht_invalid(TheHashtable(obj)); } # ja -> fⁿr Reorganisation vormerken
  7267.             # alle Elemente durchlaufen:
  7268.             { var reg4 uintC len = TheRecord(obj)->reclength;
  7269.               if (!(len==0))
  7270.                 { var reg3 object* objptr = &TheRecord(obj)->recdata[0];
  7271.                   dotimespC(len,len, { subst_circ_mark(&(*objptr++)); } );
  7272.             }   }
  7273.             return;
  7274.           case_system: # Frame-Pointer oder Read-Label oder System
  7275.             if (as_oint(obj) & wbit(0+oint_addr_shift))
  7276.               # Read-Label oder System
  7277.               if (as_oint(obj) & wbit(oint_data_len-1+oint_addr_shift))
  7278.                 {} # System
  7279.                 else
  7280.                 # Read-Label
  7281.                 { # Read-Label obj in der Aliste suchen:
  7282.                   var reg4 object alist = subst_circ_alist;
  7283.                   while (consp(alist))
  7284.                     { var reg3 object acons = Car(alist);
  7285.                       if (eq(Car(acons),obj))
  7286.                         # gefunden
  7287.                         { # *ptr = obj = (car acons) durch (cdr acons) ersetzen,
  7288.                           # dabei aber das Markierungsbit unverΣndert lassen:
  7289.                           *ptr = (marked(ptr) ? with_mark_bit(Cdr(acons)) : Cdr(acons));
  7290.                           return;
  7291.                         }
  7292.                       alist = Cdr(alist);
  7293.                     }
  7294.                   # nicht gefunden -> Abbruch
  7295.                   subst_circ_bad = obj;
  7296.                   longjmp(subst_circ_jmpbuf,TRUE);
  7297.                 }
  7298.               else
  7299.               # Frame-Pointer
  7300.               {}
  7301.             return;
  7302.           case cons_type: # Cons
  7303.             if (marked(TheCons(obj))) return; # Objekt schon markiert?
  7304.             mark(TheCons(obj)); # markieren
  7305.             # rekursiv: subst_circ_mark(&Car(obj))
  7306.             subst_circ_mark(&Car(obj));
  7307.             # endrekursiv: subst_circ_mark(&Cdr(obj))
  7308.             ptr = &Cdr(obj); goto enter_subst;
  7309.           #ifdef IMMUTABLE_CONS
  7310.           case imm_cons_type: # immutables Cons
  7311.             if (marked(TheCons(obj))) return; # Objekt schon markiert?
  7312.             mark(TheImmCons(obj)); # markieren
  7313.             # rekursiv: subst_circ_mark(&Car(obj))
  7314.             subst_circ_mark(&TheImmCons(obj)->car);
  7315.             # endrekursiv: subst_circ_mark(&Cdr(obj))
  7316.             ptr = &TheImmCons(obj)->cdr; goto enter_subst;
  7317.           #endif
  7318.           case_machine: # Maschinenpointer
  7319.           case_bvector: # Bit-Vektor
  7320.           case_string: # String
  7321.           case_char: # Character
  7322.           case_subr: # SUBR
  7323.           case_number: # Zahl
  7324.           case_symbol: # Symbol
  7325.             # Objekt enthΣlt keine Referenzen -> nichts zu tun
  7326.             return;
  7327.           default: NOTREACHED
  7328.     }}  }
  7329.   local void subst_circ_unmark(ptr)
  7330.     var reg2 object* ptr;
  7331.     { enter_subst:
  7332.      {var reg1 object obj = *ptr;
  7333.       # Fallunterscheidung nach Typ, wie oben:
  7334.       switch (typecode(obj))
  7335.         { case svector_type: # Simple-Vector
  7336.             if (!marked(TheSvector(obj))) return; # schon demarkiert?
  7337.             unmark(TheSvector(obj)); # demarkieren
  7338.             # alle Elemente durchlaufen:
  7339.             { var reg4 uintL len = TheSvector(obj)->length;
  7340.               if (!(len==0))
  7341.                 { var reg3 object* objptr = &TheSvector(obj)->data[0];
  7342.                   dotimespL(len,len, { subst_circ_unmark(&(*objptr++)); } );
  7343.             }   }
  7344.             return;
  7345.           case array_type:
  7346.           case vector_type:
  7347.             # nicht-simpler Array, kein String oder Bit-Vektor
  7348.             if (!marked(TheArray(obj))) return; # schon demarkiert?
  7349.             unmark(TheArray(obj)); # demarkieren
  7350.             # Datenvektor durchlaufen: endrekursiv subst_circ_unmark(Datenvektor)
  7351.             ptr = &TheArray(obj)->data; goto enter_subst;
  7352.           #ifdef IMMUTABLE_ARRAY
  7353.           case imm_svector_type: # immutabler Simple-Vector
  7354.             if (!marked(TheSvector(obj))) return; # schon demarkiert?
  7355.             unmark(TheImmSvector(obj)); # demarkieren
  7356.             # alle Elemente durchlaufen:
  7357.             { var reg4 uintL len = TheSvector(obj)->length;
  7358.               if (!(len==0))
  7359.                 { var reg3 object* objptr = &TheImmSvector(obj)->data[0];
  7360.                   dotimespL(len,len, { subst_circ_unmark(&(*objptr++)); } );
  7361.             }   }
  7362.             return;
  7363.           case imm_array_type:
  7364.           case imm_vector_type:
  7365.             # nicht-simpler Array, kein String oder Bit-Vektor
  7366.             if (!marked(TheArray(obj))) return; # schon demarkiert?
  7367.             unmark(TheImmArray(obj)); # demarkieren
  7368.             # Datenvektor durchlaufen: endrekursiv subst_circ_unmark(Datenvektor)
  7369.             ptr = &TheImmArray(obj)->data; goto enter_subst;
  7370.           #endif
  7371.           case_record: # Record
  7372.             if (!marked(TheRecord(obj))) return; # schon demarkiert?
  7373.             unmark(TheRecord(obj)); # demarkieren
  7374.             # alle Elemente durchlaufen:
  7375.             { var reg4 uintC len = TheRecord(obj)->reclength;
  7376.               if (!(len==0))
  7377.                 { var reg3 object* objptr = &TheRecord(obj)->recdata[0];
  7378.                   dotimespC(len,len, { subst_circ_unmark(&(*objptr++)); } );
  7379.             }   }
  7380.             return;
  7381.           case cons_type: # Cons
  7382.             if (!marked(TheCons(obj))) return; # schon demarkiert?
  7383.             unmark(TheCons(obj)); # demarkieren
  7384.             # rekursiv: subst_circ_unmark(&Car(obj))
  7385.             subst_circ_unmark(&Car(obj));
  7386.             # endrekursiv: subst_circ_unmark(&Cdr(obj))
  7387.             ptr = &Cdr(obj); goto enter_subst;
  7388.           #ifdef IMMUTABLE_CONS
  7389.           case imm_cons_type: # immutables Cons
  7390.             if (!marked(TheCons(obj))) return; # schon demarkiert?
  7391.             unmark(TheImmCons(obj)); # demarkieren
  7392.             # rekursiv: subst_circ_unmark(&Car(obj))
  7393.             subst_circ_unmark(&TheImmCons(obj)->car);
  7394.             # endrekursiv: subst_circ_unmark(&Cdr(obj))
  7395.             ptr = &TheImmCons(obj)->cdr; goto enter_subst;
  7396.           #endif
  7397.           case_system: # Frame-Pointer oder Read-Label oder System
  7398.           case_machine: # Maschinenpointer
  7399.           case_bvector: # Bit-Vektor
  7400.           case_string: # String
  7401.           case_char: # Character
  7402.           case_subr: # SUBR
  7403.           case_number: # Zahl
  7404.           case_symbol: # Symbol
  7405.             # Objekt enthΣlt keine Referenzen -> nichts zu tun
  7406.             return;
  7407.           default: NOTREACHED
  7408.     }}  }
  7409.  
  7410. #endif
  7411.  
  7412. # ------------------------------------------------------------------------------
  7413. #                  Elementare Stringfunktionen
  7414.  
  7415. # Ausgabe eines konstanten ASCIZ-Strings, direkt ⁿbers Betriebssystem:
  7416. # asciz_out(string);
  7417. # > char* asciz: ASCIZ-String
  7418.   global void asciz_out (const char * asciz);
  7419.   global void asciz_out(asciz)
  7420.     var reg3 const char * asciz;
  7421.     {
  7422.       #ifdef ATARI
  7423.         var reg1 const uintB* ptr = asciz;
  7424.         # Nullbyte suchen und dabei Zeichen ausgeben:
  7425.         loop
  7426.           { var reg2 uintB c = *ptr++; # nΣchstes Zeichen
  7427.             if (c==0) break;
  7428.             BIOS_ConOut(c); # ausgeben
  7429.           }
  7430.       #endif
  7431.       #ifdef AMIGAOS
  7432.         begin_system_call();
  7433.         Write(Output_handle,asciz,asciz_length(asciz));
  7434.         end_system_call();
  7435.       #endif
  7436.       #if defined(UNIX) || (defined(MSDOS) && !defined(WINDOWS)) || defined(RISCOS)
  7437.         begin_system_call();
  7438.         full_write(stdout_handle,asciz,asciz_length(asciz));
  7439.         end_system_call();
  7440.       #endif
  7441.       #ifdef WINDOWS
  7442.         # Low-Level Debug Output kann nicht ⁿber Windows gehen, sondern mu▀
  7443.         # ein File zum Ziel haben. Da unter DOS offene Files die LΣnge 0
  7444.         # haben, mⁿssen wir das File sofort wieder schlie▀en.
  7445.         #ifdef EMUNIX
  7446.           # open(), close() usw. ruft bei RSX direkt DOS auf.
  7447.           static int fd = -1;
  7448.           begin_system_call();
  7449.           if (fd<0)
  7450.             { fd = open("c:/lisp.out",O_RDWR|O_CREAT|O_TRUNC|O_TEXT,my_open_mask); }
  7451.           if (fd>=0)
  7452.             { write(fd,asciz,asciz_length(asciz));
  7453.               close(dup(fd)); # effectively fsync(fd)
  7454.             }
  7455.           end_system_call();
  7456.         #else
  7457.           var int fd;
  7458.           static char buf[] = "c:/temp/lisp0000.out";
  7459.           static uintL count = 0;
  7460.           buf[12] = ((count >> 9) & 7) + '0';
  7461.           buf[13] = ((count >> 6) & 7) + '0';
  7462.           buf[14] = ((count >> 3) & 7) + '0';
  7463.           buf[15] = ((count >> 0) & 7) + '0';
  7464.           count++;
  7465.           begin_system_call();
  7466.           #ifndef WATCOM
  7467.             fd = open(buf,O_RDWR|O_CREAT|O_TRUNC|O_TEXT,my_open_mask);
  7468.             if (fd>=0) { write(fd,asciz,asciz_length(asciz)); close(fd); }
  7469.           #else # WATCOM
  7470.             # Das normale open(), close() schlie▀t nicht richtig, wenn das
  7471.             # Programm anschlie▀end abstⁿrzt.
  7472.             { var unsigned int written;
  7473.               fd = 0; _dos_creatnew(buf,0,&fd);
  7474.               _dos_write(fd,asciz,asciz_length(asciz),&written);
  7475.               _dos_close(fd);
  7476.             }
  7477.           #endif
  7478.           end_system_call();
  7479.         #endif
  7480.       #endif
  7481.     }
  7482.  
  7483. # UP: Liefert einen LISP-String mit vorgegebenem Inhalt.
  7484. # make_string(charptr,len)
  7485. # > uintB* charptr: Adresse einer Zeichenfolge
  7486. # > uintL len: LΣnge der Zeichenfolge
  7487. # < ergebnis: Simple-String mit den len Zeichen ab charptr als Inhalt
  7488. # kann GC ausl÷sen
  7489.   global object make_string (const uintB* charptr, uintL len);
  7490.   global object make_string(charptr,len)
  7491.     var reg2 const uintB* charptr;
  7492.     var reg3 uintL len;
  7493.     { var reg4 object obj = allocate_string(len); # String allozieren
  7494.       var reg1 uintB* ptr = &TheSstring(obj)->data[0];
  7495.       # Zeichenfolge von charptr nach ptr kopieren:
  7496.       dotimesL(len,len, { *ptr++ = *charptr++; } );
  7497.       return(obj);
  7498.     }
  7499.  
  7500. #ifndef asciz_length
  7501. # UP: Liefert die LΣnge eines ASCIZ-Strings.
  7502. # asciz_length(asciz)
  7503. # > char* asciz: ASCIZ-String
  7504. #       (Adresse einer durch ein Nullbyte abgeschlossenen Zeichenfolge)
  7505. # < ergebnis: LΣnge der Zeichenfolge (ohne Nullbyte)
  7506.   global uintL asciz_length (const char * asciz);
  7507.   global uintL asciz_length(asciz)
  7508.     var reg3 const char* asciz;
  7509.     { var reg1 const char* ptr = asciz;
  7510.       var reg2 uintL len = 0;
  7511.       # Nullbyte suchen und dabei LΣnge hochzΣhlen:
  7512.       while (!( *ptr++ == 0 )) { len++; }
  7513.       return len;
  7514.     }
  7515. #endif
  7516.  
  7517. #ifndef asciz_equal
  7518. # UP: Vergleicht zwei ASCIZ-Strings.
  7519. # asciz_equal(asciz1,asciz2)
  7520. # > char* asciz1: erster ASCIZ-String
  7521. # > char* asciz2: zweiter ASCIZ-String
  7522. # < ergebnis: TRUE falls die Zeichenfolgen gleich sind
  7523.   global boolean asciz_equal (const char * asciz1, const char * asciz2);
  7524.   global boolean asciz_equal(asciz1,asciz2)
  7525.     var reg2 const char* asciz1;
  7526.     var reg3 const char* asciz2;
  7527.     { # Bytes vergleichen, solange bis das erste Nullbyte kommt:
  7528.       loop
  7529.         { var reg1 char ch1 = *asciz1++;
  7530.           if (!(ch1 == *asciz2++)) goto no;
  7531.           if (ch1 == '\0') goto yes;
  7532.         }
  7533.       yes: return TRUE;
  7534.       no: return FALSE;
  7535.     }
  7536. #endif
  7537.  
  7538. # UP: Wandelt einen ASCIZ-String in einen LISP-String um.
  7539. # asciz_to_string(asciz)
  7540. # > char* asciz: ASCIZ-String
  7541. #       (Adresse einer durch ein Nullbyte abgeschlossenen Zeichenfolge)
  7542. # < ergebnis: String mit der Zeichenfolge (ohne Nullbyte) als Inhalt
  7543. # kann GC ausl÷sen
  7544.   global object asciz_to_string (const char * asciz);
  7545.   global object asciz_to_string(asciz)
  7546.     var reg1 const char* asciz;
  7547.     { return make_string((const uintB*)asciz,asciz_length(asciz)); }
  7548.  
  7549. # UP: Wandelt einen String in einen ASCIZ-String um.
  7550. # string_to_asciz(obj)
  7551. # > object obj: String
  7552. # < ergebnis: Simple-String mit denselben Zeichen und einem Nullbyte mehr am Schlu▀
  7553. # kann GC ausl÷sen
  7554.   global object string_to_asciz (object obj);
  7555.   global object string_to_asciz (obj)
  7556.     var reg5 object obj;
  7557.     { # (vgl. copy_string in CHARSTRG)
  7558.       var reg4 object new = allocate_string(vector_length(obj)+1);
  7559.           # neuer Simple-String mit einem Byte mehr LΣnge
  7560.       var uintL len;
  7561.       var reg1 uintB* sourceptr = unpack_string(obj,&len);
  7562.       # Source-String: LΣnge in len, Bytes ab sourceptr
  7563.       var reg2 uintB* destptr = &TheSstring(new)->data[0];
  7564.       # Destination-String: Bytes ab destptr
  7565.       { # Kopierschleife:
  7566.         var reg3 uintL count;
  7567.         dotimesL(count,len, { *destptr++ = *sourceptr++; } );
  7568.         *destptr++ = 0; # Nullbyte anfⁿgen
  7569.       }
  7570.       return(new);
  7571.     }
  7572.  
  7573. # ------------------------------------------------------------------------------
  7574. #                  Andere globale Hilfsfunktionen
  7575.  
  7576. #if (int_bitsize < long_bitsize)
  7577. # ▄bergabewert an setjmpl() von longjmpl():
  7578.   global long jmpl_value;
  7579. #endif
  7580.  
  7581. #ifndef SP
  7582. # Bestimmung (einer Approximation) des SP-Stackpointers.
  7583.   global void* SP (void);
  7584.   global void* SP()
  7585.     { var long dummy;
  7586.       return &dummy;
  7587.     }
  7588. #endif
  7589.  
  7590. # Fehlermeldung wegen Erreichen einer unerreichbaren Programmstelle.
  7591. # Kehrt nicht zurⁿck.
  7592. # fehler_notreached(file,line);
  7593. # > file: Filename (mit Anfⁿhrungszeichen) als konstanter ASCIZ-String
  7594. # > line: Zeilennummer
  7595.   nonreturning_function(global, fehler_notreached, (const char * file, uintL line));
  7596.   global void fehler_notreached(file,line)
  7597.     var reg2 const char * file;
  7598.     var reg1 uintL line;
  7599.     { pushSTACK(fixnum(line));
  7600.       pushSTACK(asciz_to_string(file));
  7601.       fehler(serious_condition,
  7602.              DEUTSCH ? "Interner Fehler: Anweisung in File ~, Zeile ~ wurde ausgefⁿhrt!!" NLstring
  7603.                        "Bitte schicken Sie eine Mitteilung an die Programm-Autoren, "
  7604.                        "mit der Beschreibung, wie Sie diesen Fehler erzeugt haben!" :
  7605.              ENGLISH ? "internal error: statement in file ~, line ~ has been reached!!" NLstring
  7606.                        "Please send the authors of the program "
  7607.                        "a description how you produced this error!" :
  7608.              FRANCAIS ? "Erreur interne : Dans le fichier ~, la ligne ~ fut exΘcutΘe!" NLstring
  7609.                         "Veuillez signaler aux auteurs du programme comment "
  7610.                         "vous avez pu faire apparaεtre cette erreur, s.v.p.!" :
  7611.              ""
  7612.             );
  7613.     }
  7614.  
  7615. #ifndef LANGUAGE_STATIC
  7616.  
  7617.   # Sprache, in der mit dem Benutzer kommuniziert wird:
  7618.     global uintL language;
  7619.  
  7620. #endif
  7621.  
  7622. # ------------------------------------------------------------------------------
  7623. #                       Tastatur-Unterbrechung
  7624.  
  7625. #ifdef ATARI
  7626.  
  7627. # Typ einer Interruptfunktion:
  7628. # interruptfun = Pointer auf eine Funktion ohne Argumente und ohne Ergebnis
  7629.   typedef void (*interruptfun)();
  7630.  
  7631. # meine eigene kleine VBL-Assembler-Routine, vgl. VBL.Q, VBL.LST:
  7632.   local uintW my_VBL_asm[52] = {
  7633.       0x5842,0x5241,        # 000000 :58425241                   DC.L    'XBRA'
  7634.       0x4C49,0x5350,        # 000004 :4C495350                   DC.L    'LISP'
  7635.       0,0,                  # 000008 : ^     4        OLD_VBL:   DS.L    1
  7636.                             # 00000C :                NEW_VBL:           ; EIGENE INTERRUPT-ROUTINE
  7637.       0x0817,0x0005,        # 00000C :08170005                   BTST    #5,(SP)        ; INTERRUPT AUS USER-MODE?
  7638.       0x663C,               # 000010 :663C                       BNE.S   \1             ; NEIN, DANN MAUS/TASTATUR NICHT ABFRAGEN
  7639.       0x4AB9,0,0,           # 000012 :4AB900000068               TST.L   BREAK_SEM      ; BREAK M╓GLICH?
  7640.       0x6634,               # 000018 :6634                       BNE.S   \1             ; NEIN
  7641.       0x48E7,0x8080,        # 00001A :48E78080                   MOVEM.L D0/A0,-(SP)
  7642.       0x2079,0,0,           # 00001E :20790000006C               MOVE.L  LINEA,A0       ; ADRESSE DER LINE-A VARIABLEN
  7643.       0x3028,0xFDAC,        # 000024 :3028FDAC                   MOVE.W -596(A0),D0     ; MOUSE_BT = AKTUELLER STATUS DER MAUSTASTEN
  7644.       0x4640,               # 000028 :4640                       NOT.W D0
  7645.       0xC07C,0x0003,        # 00002A :C07C0003                   AND.W #%11,D0          ; BEIDE BITS 0 (LINKS) UND 1 (RECHTS) GESETZT?
  7646.       0x661A,               # 00002E :661A                       BNE.S \2               ; NEIN -> WEITER
  7647.       0x48E7,0x60E0,        # 000030 :48E760E0                   MOVEM.L D1-D2/A0-A2,-(SP)
  7648.                             # 000034 :                           BIOS_KBSHIFT           ; SHIFT-STATUS LESEN
  7649.       0x3F3C,0xFFFF,        # 000034 :3F3CFFFF                       MOVE.W #-1,-(SP) ; MODUS=-1
  7650.       0x3F3C,0x000B,        # 000038 :3F3C000B                       MOVE.W #11,-(SP) ; KBSHIFT
  7651.       0x4E4D,               # 00003C :4E4D                           TRAP #13 ; BIOS
  7652.       0x588F,               # 00003E :588F                           ADDQ.L #4,SP
  7653.                             # 000040 :                               ENDM
  7654.       0xC03C,0x0003,        # 000040 :C03C0003                   AND.B #%00000011,D0    ; SHIFT LINKS, SHIFT RECHTS ISOLIEREN
  7655.       0x4CDF,0x0706,        # 000044 :4CDF0706                   MOVEM.L (SP)+,D1-D2/A0-A2
  7656.       0x660A,               # 000048 :660A                       BNE.S \ABBRUCH         ; SHIFT GEDR▄CKT -> ABBRUCH
  7657.       0x4CDF,0x0101,        # 00004A :4CDF0101        \2:        MOVEM.L (SP)+,D0/A0
  7658.       0x2F3A,0xFFB8,        # 00004E :2F3AFFB8        \1:        MOVE.L OLD_VBL(PC),-(SP) ; SONST ALTE ROUTINE ANSPRINGEN
  7659.       0x4E75,               # 000052 :4E75                       RTS
  7660.                             # 000054 :                \ABBRUCH:  ; BEIDE MAUSTASTEN UND EINE SHIFT-TASTE GEDR▄CKT -> ABBRECHEN
  7661.       0x0268,0xFFFC,0xFDAC, # 000054 :0268FFFCFDAC               AND.W   #-4,-596(A0)   ; BEIDE MAUSTASTEN F▄R NICHT GEDR▄CKT ERKL─REN
  7662.       0x504F,               # 00005A :504F                       ADDQ.W  #2*4,SP        ; MOVEM: GERETTETE REGISTER VERGESSEN
  7663.       0x321F,               # 00005C :321F                       MOVE.W  (SP)+,D1       ; SR VOR INTERRUPT
  7664.       0x588F,               # 00005E :588F                       ADDQ.L  #4,SP          ; PC VERGESSEN
  7665.       0x46C1,               # 000060 :46C1                       MOVE    D1,SR          ; UND ZUR▄CK IN USER-MODE
  7666.       0x4EF9,0,0,           # 000062 :4EF900000070               JMP     TAST_FEHLER
  7667.                             # 000068 :
  7668.                             # 000068 :                ; EXTERN:
  7669.                             # 000068 : ^     4        BREAK_SEM: DS.L    1
  7670.                             # 00006C : ^     4        LINEA:     DS.L    1
  7671.                             # 000070 :                TAST_FEHLER:
  7672.       };
  7673.   nonreturning_function(local, tastatur_interrupt, (void));
  7674.   local void tastatur_interrupt()
  7675.     { fehler(serious_condition,
  7676.              DEUTSCH ? "Abbruch durch Tastatur-Interrupt" :
  7677.              ENGLISH ? "User break" :
  7678.              FRANCAIS ? "Interruption clavier" :
  7679.              ""
  7680.             );
  7681.     }
  7682.   # geretteter VBL-Vektor:
  7683.     #define old_VBL  *((interruptfun*) &my_VBL_asm[4])
  7684.   # neuer VBL-Vektor:
  7685.     #define new_VBL  ((interruptfun) &my_VBL_asm[6])
  7686.   # drei Import-Stellen:
  7687.     #define new_VBL_fixup_break  *((void**) &my_VBL_asm[10])
  7688.     #define new_VBL_fixup_linea  *((void**) &my_VBL_asm[16])
  7689.     #define new_VBL_fixup_tast_fehler  *((void**) &my_VBL_asm[50])
  7690.  
  7691. #endif
  7692.  
  7693. # ------------------------------------------------------------------------------
  7694. #                        Initialisierung
  7695.  
  7696. # Name des Programms (fⁿr Fehlermeldungszwecke)
  7697.   local char* program_name;
  7698.  
  7699. # Flag, ob System vollstΣndig geladen (fⁿr Fehlermeldungsbehandlung)
  7700.   local boolean everything_ready = FALSE;
  7701.  
  7702. # Flag, ob SYS::READ-FORM sich ILISP-kompatibel verhalten soll:
  7703.   global boolean ilisp_mode = FALSE;
  7704.  
  7705. #ifdef UNIX
  7706.  
  7707. # Real User ID des laufenden Prozesses.
  7708.   global uid_t user_uid;
  7709.  
  7710. #endif
  7711.  
  7712. #ifdef ATARI
  7713.  
  7714. # Fⁿr eigene Tastatur-Abfrage-Routine:
  7715. # Keyboard-Input-Stream funktionsfΣhig machen:
  7716.   local void new_keyboard (void);
  7717.   # UP: Bit im Betriebssystem setzen, das dafⁿr sorgt, da▀ Tastendrⁿcke im
  7718.   # BIOS-Buffer nicht nur mit Scancode, sondern auch mit Sondertastenstatus
  7719.   # abgelegt werden:
  7720.     local void with_KbShift (void);
  7721.     local void with_KbShift()
  7722.       { *(uintB*)0x484 |= bit(3); } # BSET #3,$484
  7723.   local void new_keyboard()
  7724.     { Supervisor_Exec(with_KbShift); }
  7725. # Tastaturabfrage wieder in den ursprⁿnglichen Zustand versetzen:
  7726.   local void old_keyboard (void);
  7727.   # Bit im Betriebssystem wieder l÷schen:
  7728.     local void without_KbShift (void);
  7729.     local void without_KbShift()
  7730.       { *(uintB*)0x484 &= ~bit(3); } # BCLR #3,$484
  7731.   local void old_keyboard()
  7732.     { Supervisor_Exec(without_KbShift); }
  7733.  
  7734. #endif
  7735.  
  7736. #ifdef PENDING_INTERRUPTS
  7737.   # Flag, ob eine Unterbrechung anliegt.
  7738.   global uintB interrupt_pending = FALSE;
  7739. #endif
  7740.  
  7741. #ifdef HAVE_SIGNALS
  7742.  
  7743. # Pa▀t den Wert von SYS::*PRIN-LINELENGTH* an die aktuelle Breite des
  7744. # Terminal-Fensters an.
  7745. # update_linelength();
  7746.   local void update_linelength (void);
  7747.   local void update_linelength()
  7748.     { # SYS::*PRIN-LINELENGTH* := Breite des Terminal-Fensters - 1
  7749.       # [vgl. 'term.c' in 'calc' von Hans-J. B÷hm, Vernon Lee, Alan J. Demers]
  7750.       if (isatty(stdout_handle)) # Standard-Output ein Terminal?
  7751.         { /* var reg2 int lines = 0; */
  7752.           var reg1 int columns = 0;
  7753.           #ifdef TIOCGWINSZ
  7754.           # Probiere erst ioctl:
  7755.           { var struct winsize stdout_window_size;
  7756.             if (!( ioctl(stdout_handle,TIOCGWINSZ,&stdout_window_size) <0))
  7757.               { /* lines = stdout_window_size.ws_row; */
  7758.                 columns = stdout_window_size.ws_col;
  7759.           }   }
  7760.           # Das kann - entgegen der Dokumentation - scheitern!
  7761.           if (/* (lines > 0) && */ (columns > 0)) goto OK;
  7762.           #endif
  7763.           #ifndef WATCOM
  7764.           # Nun probieren wir's ⁿber termcap:
  7765.           { var reg3 char* term_name = getenv("TERM");
  7766.             if (term_name==NULL) { term_name = "unknown"; }
  7767.            {var char termcap_entry_buf[10000];
  7768.             if ( tgetent(&!termcap_entry_buf,term_name) ==1)
  7769.               { /* lines = tgetnum("li"); if (lines<0) { lines = 0; } */
  7770.                 columns = tgetnum("co"); if (columns<0) { columns = 0; }
  7771.               }
  7772.           }}
  7773.           #endif
  7774.           # Hoffentlich enthΣlt columns jetzt einen vernⁿnftigen Wert.
  7775.           if (/* (lines > 0) && */ (columns > 0)) goto OK;
  7776.           if (FALSE)
  7777.             { OK:
  7778.               # Wert von SYS::*PRIN-LINELENGTH* verΣndern:
  7779.               Symbol_value(S(prin_linelength)) =
  7780.                 fixnum(columns-1);
  7781.             }
  7782.     }   }
  7783. #if defined(SIGWINCH) && !defined(NO_ASYNC_INTERRUPTS)
  7784. # Signal-Handler fⁿr Signal SIGWINCH:
  7785.   local void sigwinch_handler (int sig);
  7786.   local void sigwinch_handler(sig)
  7787.     var int sig; # sig = SIGWINCH
  7788.     { signal_acknowledge(SIGWINCH,&sigwinch_handler);
  7789.       update_linelength();
  7790.     }
  7791. #endif
  7792.  
  7793. # Eine Tastatur-Unterbrechung (Signal SIGINT, erzeugt durch Ctrl-C)
  7794. # wird eine Sekunde lang aufgehoben. In dieser Zeit kann sie mittels
  7795. # 'interruptp' auf fortsetzbare Art behandelt werden. Nach Ablauf dieser
  7796. # Zeit wird das Programm nichtfortsetzbar unterbrochen.
  7797. # Signal-Handler fⁿr Signal SIGINT:
  7798.   local void interrupt_handler (int sig);
  7799.   local void interrupt_handler(sig)
  7800.     var int sig; # sig = SIGINT
  7801.     { signal_acknowledge(SIGINT,&interrupt_handler);
  7802.   #ifdef PENDING_INTERRUPTS
  7803.       if (!interrupt_pending) # Liegt schon ein Interrupt an -> nichts zu tun
  7804.         { interrupt_pending = TRUE; # Flag fⁿr 'interruptp' setzen
  7805.           #ifdef HAVE_UALARM
  7806.           # eine halbe Sekunde warten, dann jede 1/20 sec probieren
  7807.           ualarm(ticks_per_second/2,ticks_per_second/20);
  7808.           #else
  7809.           alarm(1); # eine Sekunde warten, weiter geht's dann bei alarm_handler
  7810.           #endif
  7811.         }
  7812.     }
  7813.   local void alarm_handler (int sig);
  7814.   local void alarm_handler(sig)
  7815.     var int sig; # sig = SIGALRM
  7816.     { # Die Zeit ist nun abgelaufen.
  7817.       #ifdef EMUNIX # Verhindere Programm-Beendigung durch SIGALRM
  7818.       #ifndef HAVE_UALARM
  7819.       #ifdef EMUNIX_OLD_8h # EMX-Bug umgehen
  7820.       alarm(1000);
  7821.       #endif
  7822.       alarm(0); # SIGALRM-Timer abbrechen
  7823.       #endif
  7824.       #endif
  7825.       signal_acknowledge(SIGALRM,&alarm_handler);
  7826.   #endif # PENDING_INTERRUPTS (!)
  7827.     #ifndef NO_ASYNC_INTERRUPTS
  7828.       # Warten, bis Unterbrechung erlaubt:
  7829.       if (!(break_sems.gesamt == 0))
  7830.     #endif
  7831.         {
  7832.           #ifndef WATCOM
  7833.           #ifndef HAVE_UALARM
  7834.           alarm(1); # Probieren wir's in einer Sekunde nochmal
  7835.           #endif
  7836.           #endif
  7837.           return; # Nach kurzer Zeit wird wieder ein SIGALRM ausgel÷st.
  7838.         }
  7839.     #ifndef NO_ASYNC_INTERRUPTS
  7840.       # Wir springen jetzt aus dem signal-Handler heraus, weder mit 'return'
  7841.       # noch mit 'longjmp'.
  7842.       #
  7843.       # Hans-J. Boehm <boehm@parc.xerox.com> weist darauf hin, da▀ dies
  7844.       # Probleme bringen kann, wenn das Signal ein laufendes malloc() oder
  7845.       # free() unterbrochen hat und die malloc()-Library nicht reentrant ist.
  7846.       # Abhilfe: statt malloc() stets xmalloc() verwenden, das eine Break-
  7847.       # Semaphore setzt? Aber was ist mit malloc()-Aufrufen, die von Routinen
  7848.       # wie opendir(), getpwnam(), tgetent(), ... abgesetzt werden? Soll man
  7849.       # malloc() selber definieren und darauf hoffen, da▀ es von allen Library-
  7850.       # funktionen aufgerufen wird (statisch gelinkt oder per DLL)??
  7851.       #
  7852.       #if defined(SIGNAL_NEED_UNBLOCK) || (defined(GNU_READLINE) && (defined(SIGNALBLOCK_BSD) || defined(SIGNALBLOCK_POSIX)))
  7853.       # Falls entweder [SIGNAL_NEED_UNBLOCK] mit signal() installierte Handler
  7854.       # sowieso mit blockiertem Signal aufgerufen werden - das sind ⁿblicherweise
  7855.       # BSD-Systeme -, oder falls andere unsichere Komponenten [GNU_READLINE]
  7856.       # per sigaction() o.Σ. das Blockieren des Signals beim Aufruf veranlassen
  7857.       # k÷nnen, mⁿssen wir das gerade blockierte Signal entblockieren:
  7858.         #if defined(SIGNALBLOCK_POSIX)
  7859.           { var sigset_t sigblock_mask;
  7860.             sigemptyset(&sigblock_mask); sigaddset(&sigblock_mask,SIGALRM);
  7861.             sigprocmask(SIG_UNBLOCK,&sigblock_mask,NULL);
  7862.           }
  7863.         #elif defined(SIGNALBLOCK_BSD)
  7864.           sigsetmask(sigblock(0) & ~sigmask(SIGALRM));
  7865.         #endif
  7866.       #endif
  7867.       #ifdef HAVE_SAVED_STACK
  7868.       # STACK auf einen sinnvollen Wert setzen:
  7869.       if (!(saved_STACK==NULL)) { setSTACK(STACK = saved_STACK); }
  7870.       #endif
  7871.       # ▄ber 'fehler' in eine Break-Schleife springen:
  7872.       fehler(serious_condition,
  7873.              DEUTSCH ? "Ctrl-C: Tastatur-Interrupt" :
  7874.              ENGLISH ? "Ctrl-C: User break" :
  7875.              FRANCAIS ? "Ctrl-C : Interruption clavier" :
  7876.              ""
  7877.             );
  7878.     #endif
  7879.     }
  7880.  
  7881. #ifdef IMMUTABLE
  7882. # Signal-Handler fⁿr Signal SIGSEGV:
  7883.   local void sigsegv_handler (int sig);
  7884.   local void sigsegv_handler(sig)
  7885.     var int sig; # sig = SIGSEGV
  7886.     { signal_acknowledge(SIGSEGV,&sigsegv_handler);
  7887.       break_sems.gesamt = 0; # Sehr gefΣhrlich!!
  7888.       #ifdef SIGNAL_NEED_UNBLOCK # Unter Linux nicht n÷tig, unter SunOS4 n÷tig.
  7889.       # gerade blockiertes Signal entblockieren:
  7890.       sigsetmask(sigblock(0) & ~sigmask(SIGSEGV));
  7891.       #endif
  7892.       #ifdef HAVE_SAVED_STACK
  7893.       # STACK auf einen sinnvollen Wert setzen:
  7894.       if (!(saved_STACK==NULL)) { setSTACK(STACK = saved_STACK); }
  7895.       #endif
  7896.       # ▄ber 'fehler' in eine Break-Schleife springen:
  7897.       fehler(error,
  7898.              DEUTSCH ? "Versuch der Modifikation unverΣnderlicher Daten." :
  7899.              ENGLISH ? "Attempt to modify read-only data" :
  7900.              FRANCAIS ? "Tentative de modification d'un objet non modifiable." :
  7901.              ""
  7902.             );
  7903.     }
  7904. #endif
  7905.  
  7906. #ifdef GENERATIONAL_GC
  7907.  
  7908.   local void install_segv_handler (void);
  7909.  
  7910.   #ifdef UNIX_NEXTSTEP
  7911.  
  7912.     # Die Fehler-Adresse bekommen wir als subcode zu einer Mach-Exception.
  7913.     # Dazu lΣuft ein Thread, der am Exception-Port horcht.
  7914.  
  7915.     #include <mach/exception.h>
  7916.     #include <mach/exc_server.h>
  7917.     #include <mach/cthreads.h>
  7918.  
  7919.     # Die Behandlungs-Methode, wird von exc_server() aufgerufen:
  7920.     global kern_return_t catch_exception_raise (port_t exception_port, port_t thread, port_t task, int exception, int code, int subcode);
  7921.     local boolean exception_handled = FALSE;
  7922.     global kern_return_t catch_exception_raise(exception_port,thread,task,exception,code,subcode)
  7923.       var port_t exception_port;
  7924.       var port_t thread;
  7925.       var port_t task;
  7926.       var reg1 int exception;
  7927.       var int code;
  7928.       var reg2 int subcode;
  7929.       { if ((exception == EXC_BAD_ACCESS)
  7930.             # siehe <mach/exception.h>:
  7931.             #   Could not access memory
  7932.             #   Code contains kern_return_t describing error.
  7933.             #   Subcode contains bad memory address.
  7934.             && handle_fault((aint)subcode)
  7935.            )
  7936.           { exception_handled = TRUE; return KERN_SUCCESS; }
  7937.           else
  7938.           { exception_handled = FALSE; return KERN_FAILURE; }
  7939.       }
  7940.  
  7941.     local port_t main_thread_port;
  7942.     local port_t old_exception_port;
  7943.     local port_t new_exception_port;
  7944.  
  7945.     # Haupt-Funktion des Threads:
  7946.     local any_t exception_thread_main (void* dummy);
  7947.     local any_t exception_thread_main(dummy)
  7948.       var void* dummy;
  7949.       { var char in_msg_data[excMaxRequestSize]; # siehe <mach/exc_server.h>
  7950.         var char out_msg_data[excMaxReplySize]; # siehe <mach/exc_server.h>
  7951.         #define in_msg  (*((msg_header_t*)&in_msg_data[0]))
  7952.         #define out_msg  (*((msg_header_t*)&out_msg_data[0]))
  7953.         var reg1 kern_return_t retval;
  7954.         loop
  7955.           { # Auf Message am Exception-Port warten:
  7956.             in_msg.msg_size = excMaxRequestSize;
  7957.             in_msg.msg_local_port = new_exception_port;
  7958.             retval = msg_receive(&in_msg,MSG_OPTION_NONE,0);
  7959.             if (!(retval==KERN_SUCCESS))
  7960.               { asciz_out("Mach msg_receive didn't succeed." CRLFstring); abort(); }
  7961.             # Exception-Handler 1 aufrufen, der liefert in out_msg eine Antwort:
  7962.             if (!exc_server(&in_msg,&out_msg))
  7963.               { asciz_out("Mach exc_server didn't succeed." CRLFstring); abort(); }
  7964.             # Antwort weiterleiten:
  7965.             retval = msg_send(&out_msg,MSG_OPTION_NONE,0);
  7966.             if (!(retval==KERN_SUCCESS))
  7967.               { asciz_out("Mach msg_send didn't succeed." CRLFstring); abort(); }
  7968.             # Rⁿckgabewert von handle_fault() anschauen:
  7969.             if (exception_handled)
  7970.               { exception_handled = FALSE; }
  7971.               else
  7972.               { # Exception-Handler 2 aufrufen:
  7973.                 in_msg.msg_remote_port = old_exception_port;
  7974.                 in_msg.msg_local_port = main_thread_port;
  7975.                 retval = msg_send(&in_msg,MSG_OPTION_NONE,0);
  7976.                 if (!(retval==KERN_SUCCESS))
  7977.                   { asciz_out("Mach msg_send to old_exception_port didn't succeed." CRLFstring); abort(); }
  7978.               }
  7979.       }   }
  7980.  
  7981.     local void install_segv_handler()
  7982.       { local var boolean already_installed = FALSE;
  7983.         if (already_installed)
  7984.           return;
  7985.         # Alten Exception-Port retten:
  7986.         if (!(task_get_exception_port(task_self(),&old_exception_port)==KERN_SUCCESS))
  7987.           { asciz_out("Mach task_get_exception_port fails." CRLFstring); abort(); }
  7988.         # Neuen Exception-Port installieren:
  7989.         if (!(port_allocate(task_self(),&new_exception_port)==KERN_SUCCESS))
  7990.           { asciz_out("Mach port_allocate fails." CRLFstring); abort(); }
  7991.         if (!(task_set_exception_port(task_self(),new_exception_port)==KERN_SUCCESS))
  7992.           { asciz_out("Mach task_set_exception_port fails." CRLFstring); abort(); }
  7993.         # Exception-Behandlungs-Thread aufsetzen:
  7994.         cthread_detach(cthread_fork(&exception_thread_main,NULL));
  7995.         already_installed = TRUE;
  7996.       }
  7997.  
  7998.   #else
  7999.  
  8000.     local void install_sigsegv_handler (int sig);
  8001.  
  8002.     # Signal-Handler fⁿr Signal SIGSEGV u.Σ.:
  8003.     local void sigsegv_handler (FAULT_HANDLER_ARGLIST)
  8004.       FAULT_HANDLER_ARGDECL
  8005.       { var char* address = (char*)(FAULT_ADDRESS);
  8006.         if (handle_fault((aint)address))
  8007.           # erfolgreich
  8008.           {
  8009.             #ifdef SIGNAL_NEED_REINSTALL
  8010.             install_sigsegv_handler(sig);
  8011.             #endif
  8012.           }
  8013.           else
  8014.           # erfolglos
  8015.           { asciz_out(DEUTSCH ? CRLFstring "SIGSEGV kann nicht behoben werden. Fehler-Adresse = 0x" :
  8016.                       ENGLISH ? CRLFstring "SIGSEGV cannot be cured. Fault address = 0x" :
  8017.                       FRANCAIS ? CRLFstring "SIGSEGV ne peut Ωtre relevΘ. Adresse fautive = 0x" :
  8018.                       ""
  8019.                      );
  8020.             hex_out(address);
  8021.             asciz_out("." CRLFstring);
  8022.             # Der Default-Handler wird uns in den Debugger fⁿhren.
  8023.             SIGNAL(sig,SIG_DFL);
  8024.           }
  8025.       }
  8026.  
  8027.     # Signal-Handler sorgfΣltig installieren:
  8028.     local void install_sigsegv_handler(sig)
  8029.       var reg1 int sig;
  8030.       {
  8031.         #ifdef HAVE_SIGACTION
  8032.           struct sigaction action;
  8033.           action.sa_handler = &sigsegv_handler;
  8034.           # WΣhrend einer SIGSEGV-Behandlung sollten alle Signale blockiert
  8035.           # sein, deren Behandlung auf Lisp-Objekte zugreifen mu▀.
  8036.           sigemptyset(&action.sa_mask);
  8037.           sigaddset(&action.sa_mask,SIGINT);
  8038.           sigaddset(&action.sa_mask,SIGALRM);
  8039.           #ifdef SIGWINCH
  8040.           sigaddset(&action.sa_mask,SIGWINCH);
  8041.           #endif
  8042.           # Eventuell mu▀ das Betriebssystem dem Handler
  8043.           # ein "siginfo_t" ⁿbergeben:
  8044.           action.sa_flags =
  8045.                             #ifdef FAULT_ADDRESS_FROM_SIGINFO
  8046.                             SA_SIGINFO |
  8047.                             #endif
  8048.                             0;
  8049.           sigaction(sig,&action,(struct sigaction *)0);
  8050.         #else
  8051.           SIGNAL(sig,&sigsegv_handler);
  8052.         #endif
  8053.       }
  8054.  
  8055.     # Alle Signal-Handler installieren:
  8056.     local void install_segv_handler()
  8057.       {
  8058.         #define FAULT_HANDLER(sig)  install_sigsegv_handler(sig);
  8059.         WP_SIGNAL
  8060.         #undef FAULT_HANDLER
  8061.       }
  8062.  
  8063.   #endif
  8064.  
  8065. #endif
  8066.  
  8067. #endif
  8068.  
  8069. #ifdef ATARI
  8070.  
  8071. # GEMDOS-Fehler wΣhrend Initialisierung behandeln:
  8072.   nonreturning_function(local, gemerror, (sintW errorcode));
  8073.   local void gemerror (errorcode)
  8074.     var reg1 sintW errorcode;
  8075.     { if (everything_ready) # LISP vollstΣndig initialisiert?
  8076.         { OS_error(errorcode); } # ja -> ⁿbers Lisp ausgeben
  8077.         else
  8078.         { quit_sofort(1); } # nein -> Lisp sofort abbrechen
  8079.     }
  8080.  
  8081. #endif
  8082.  
  8083. # Umwandlung der Argumenttypen eines FSUBR in einen Code:
  8084.   local fsubr_argtype_ fsubr_argtype (uintW req_anz, uintW opt_anz, fsubr_body_ body_flag);
  8085.   local fsubr_argtype_ fsubr_argtype(req_anz,opt_anz,body_flag)
  8086.     var reg1 uintW req_anz;
  8087.     var reg2 uintW opt_anz;
  8088.     var reg3 fsubr_body_ body_flag;
  8089.     { switch (body_flag)
  8090.         { case fsubr_nobody:
  8091.             switch (opt_anz)
  8092.               { case 0:
  8093.                   switch (req_anz)
  8094.                     { case 1: return(fsubr_argtype_1_0_nobody);
  8095.                       case 2: return(fsubr_argtype_2_0_nobody);
  8096.                       default: goto illegal;
  8097.                     }
  8098.                 case 1:
  8099.                   switch (req_anz)
  8100.                     { case 1: return(fsubr_argtype_1_1_nobody);
  8101.                       case 2: return(fsubr_argtype_2_1_nobody);
  8102.                       default: goto illegal;
  8103.                     }
  8104.                 default: goto illegal;
  8105.               }
  8106.           case fsubr_body:
  8107.             switch (opt_anz)
  8108.               { case 0:
  8109.                   switch (req_anz)
  8110.                     { case 0: return(fsubr_argtype_0_body);
  8111.                       case 1: return(fsubr_argtype_1_body);
  8112.                       case 2: return(fsubr_argtype_2_body);
  8113.                       default: goto illegal;
  8114.                     }
  8115.                 default: goto illegal;
  8116.               }
  8117.           default: goto illegal;
  8118.         }
  8119.       illegal:
  8120.         asciz_out(
  8121.                   DEUTSCH ? "Unbekannter FSUBR-Argumenttyp" CRLFstring :
  8122.                   ENGLISH ? "Unknown signature of an FSUBR" CRLFstring :
  8123.                   FRANCAIS ? "Type d'argument inconnu pour FSUBR" CRLFstring :
  8124.                   ""
  8125.                  );
  8126.         quit_sofort(1);
  8127.     }
  8128.  
  8129. # Umwandlung der Argumenttypen eines SUBR in einen Code:
  8130.   local subr_argtype_ subr_argtype (uintW req_anz, uintW opt_anz, subr_rest_ rest_flag, subr_key_ key_flag);
  8131.   local subr_argtype_ subr_argtype(req_anz,opt_anz,rest_flag,key_flag)
  8132.     var reg1 uintW req_anz;
  8133.     var reg2 uintW opt_anz;
  8134.     var reg3 subr_rest_ rest_flag;
  8135.     var reg4 subr_key_ key_flag;
  8136.     { switch (key_flag)
  8137.         { case subr_nokey:
  8138.             switch (rest_flag)
  8139.               { case subr_norest:
  8140.                   switch (opt_anz)
  8141.                     { case 0:
  8142.                         switch (req_anz)
  8143.                           { case 0: return(subr_argtype_0_0);
  8144.                             case 1: return(subr_argtype_1_0);
  8145.                             case 2: return(subr_argtype_2_0);
  8146.                             case 3: return(subr_argtype_3_0);
  8147.                             case 4: return(subr_argtype_4_0);
  8148.                             case 5: return(subr_argtype_5_0);
  8149.                             case 6: return(subr_argtype_6_0);
  8150.                             default: goto illegal;
  8151.                           }
  8152.                       case 1:
  8153.                         switch (req_anz)
  8154.                           { case 0: return(subr_argtype_0_1);
  8155.                             case 1: return(subr_argtype_1_1);
  8156.                             case 2: return(subr_argtype_2_1);
  8157.                             case 3: return(subr_argtype_3_1);
  8158.                             case 4: return(subr_argtype_4_1);
  8159.                             default: goto illegal;
  8160.                           }
  8161.                       case 2:
  8162.                         switch (req_anz)
  8163.                           { case 0: return(subr_argtype_0_2);
  8164.                             case 1: return(subr_argtype_1_2);
  8165.                             case 2: return(subr_argtype_2_2);
  8166.                             default: goto illegal;
  8167.                           }
  8168.                       case 3:
  8169.                         switch (req_anz)
  8170.                           { case 0: return(subr_argtype_0_3);
  8171.                             default: goto illegal;
  8172.                           }
  8173.                       case 4:
  8174.                         switch (req_anz)
  8175.                           { case 0: return(subr_argtype_0_4);
  8176.                             default: goto illegal;
  8177.                           }
  8178.                       case 5:
  8179.                         switch (req_anz)
  8180.                           { case 0: return(subr_argtype_0_5);
  8181.                             default: goto illegal;
  8182.                           }
  8183.                       default: goto illegal;
  8184.                     }
  8185.                 case subr_rest:
  8186.                   switch (opt_anz)
  8187.                     { case 0:
  8188.                         switch (req_anz)
  8189.                           { case 0: return(subr_argtype_0_0_rest);
  8190.                             case 1: return(subr_argtype_1_0_rest);
  8191.                             case 2: return(subr_argtype_2_0_rest);
  8192.                             case 3: return(subr_argtype_3_0_rest);
  8193.                             default: goto illegal;
  8194.                           }
  8195.                       default: goto illegal;
  8196.                     }
  8197.                 default: goto illegal;
  8198.               }
  8199.           case subr_key:
  8200.             switch (rest_flag)
  8201.               { case subr_norest:
  8202.                   switch (opt_anz)
  8203.                     { case 0:
  8204.                         switch (req_anz)
  8205.                           { case 0: return(subr_argtype_0_0_key);
  8206.                             case 1: return(subr_argtype_1_0_key);
  8207.                             case 2: return(subr_argtype_2_0_key);
  8208.                             case 3: return(subr_argtype_3_0_key);
  8209.                             case 4: return(subr_argtype_4_0_key);
  8210.                             default: goto illegal;
  8211.                           }
  8212.                       case 1:
  8213.                         switch (req_anz)
  8214.                           { case 0: return(subr_argtype_0_1_key);
  8215.                             case 1: return(subr_argtype_1_1_key);
  8216.                             default: goto illegal;
  8217.                           }
  8218.                       case 2:
  8219.                         switch (req_anz)
  8220.                           { case 1: return(subr_argtype_1_2_key);
  8221.                             default: goto illegal;
  8222.                           }
  8223.                       default: goto illegal;
  8224.                     }
  8225.                 case subr_rest:
  8226.                 default: goto illegal;
  8227.               }
  8228.           case subr_key_allow: goto illegal;
  8229.           default: goto illegal;
  8230.         }
  8231.       illegal:
  8232.         asciz_out(
  8233.                   DEUTSCH ? "Unbekannter SUBR-Argumenttyp" CRLFstring :
  8234.                   ENGLISH ? "Unknown signature of a SUBR" CRLFstring :
  8235.                   FRANCAIS ? "Type d'argument inconnu pour SUBR" CRLFstring :
  8236.                   ""
  8237.                  );
  8238.         quit_sofort(1);
  8239.     }
  8240.  
  8241. # Initialisierungs-Routinen fⁿr die Tabellen
  8242. # wΣhrend des 1. Teils der Initialisierungsphase:
  8243.   # subr_tab initialisieren:
  8244.     local void init_subr_tab_1 (void);
  8245.     local void init_subr_tab_1()
  8246.       {
  8247.         #if defined(INIT_SUBR_TAB)
  8248.           #ifdef MAP_MEMORY
  8249.             # Tabelle in den vorgesehenen Bereich kopieren:
  8250.             subr_tab = subr_tab_data;
  8251.           #endif
  8252.           #if !NIL_IS_CONSTANT
  8253.           # Erst noch den name-Slot initialisieren:
  8254.           { var reg1 subr_* ptr = (subr_*)&subr_tab; # subr_tab durchgehen
  8255.             #define LISPFUN  LISPFUN_E
  8256.             #include "subr.c"
  8257.             #undef LISPFUN
  8258.           }
  8259.           # und den keywords-Slot vorlΣufig initialisieren:
  8260.           { var reg1 subr_* ptr = (subr_*)&subr_tab; # subr_tab durchgehen
  8261.             var reg2 uintC count = subr_anz;
  8262.             dotimesC(count,subr_anz, { ptr->keywords = NIL; ptr++; });
  8263.           }
  8264.           #endif
  8265.           # Durch SPVWTABF sind schon alle Slots au▀er keywords und argtype
  8266.           # initialisiert.
  8267.           # Nun den argtype-Slot initialisieren:
  8268.           { var reg1 subr_* ptr = (subr_*)&subr_tab; # subr_tab durchgehen
  8269.             var reg2 uintC count;
  8270.             dotimesC(count,subr_anz,
  8271.               { ptr->argtype =
  8272.                   (uintW)subr_argtype(ptr->req_anz,ptr->opt_anz,ptr->rest_flag,ptr->key_flag);
  8273.                 ptr++;
  8274.               });
  8275.           }
  8276.         #else
  8277.           # Alle Slots au▀er keywords initialisieren:
  8278.           { var reg1 subr_* ptr = (subr_*)&subr_tab; # subr_tab durchgehen
  8279.             #define LISPFUN  LISPFUN_D
  8280.             #include "subr.c"
  8281.             #undef LISPFUN
  8282.           }
  8283.         #endif
  8284.         { var reg3 module_* module;
  8285.           for_modules(all_other_modules,
  8286.             { var reg1 subr_* ptr = module->stab; # subr_tab durchgehen
  8287.               var reg2 uintC count;
  8288.               dotimesC(count,*module->stab_size,
  8289.                 { ptr->argtype =
  8290.                     (uintW)subr_argtype(ptr->req_anz,ptr->opt_anz,ptr->rest_flag,ptr->key_flag);
  8291.                   ptr++;
  8292.                 });
  8293.             });
  8294.         }
  8295.         #ifdef MAP_MEMORY
  8296.         # Andere Tabellen ebenfalls in den gemappten Bereich kopieren:
  8297.         { var reg2 subr_* newptr = (subr_*)&subr_tab;
  8298.           var reg4 module_* module;
  8299.           main_module.stab = newptr; newptr += subr_anz;
  8300.           for_modules(all_other_modules,
  8301.             { var reg1 subr_* oldptr = module->stab;
  8302.               var reg3 uintC count;
  8303.               module->stab = newptr;
  8304.               dotimesC(count,*module->stab_size, { *newptr++ = *oldptr++; } );
  8305.             });
  8306.           ASSERT(newptr == (subr_*)&subr_tab + total_subr_anz);
  8307.         }
  8308.         #endif
  8309.       }
  8310.   # symbol_tab initialisieren:
  8311.     local void init_symbol_tab_1 (void);
  8312.     local void init_symbol_tab_1()
  8313.       {
  8314.         #if defined(INIT_SYMBOL_TAB) && NIL_IS_CONSTANT
  8315.           #ifdef MAP_MEMORY
  8316.             # Tabelle in den vorgesehenen Bereich kopieren:
  8317.             symbol_tab = symbol_tab_data;
  8318.           #endif
  8319.         #else
  8320.           #if 0 # wozu so viel Code produzieren?
  8321.             { var reg1 symbol_* ptr = (symbol_*)&symbol_tab; # symbol_tab durchgehen
  8322.               #define LISPSYM  LISPSYM_B
  8323.               #include "constsym.c"
  8324.               #undef LISPSYM
  8325.             }
  8326.           #else
  8327.             { var reg1 symbol_* ptr = (symbol_*)&symbol_tab; # symbol_tab durchgehen
  8328.               var reg2 uintC count;
  8329.               dotimesC(count,symbol_anz,
  8330.                 { ptr->GCself = symbol_tab_ptr_as_object(ptr);
  8331.                   ptr->symvalue = unbound;
  8332.                   ptr->symfunction = unbound;
  8333.                   ptr->proplist = NIL;
  8334.                   ptr->pname = NIL;
  8335.                   ptr->homepackage = NIL;
  8336.                   ptr++;
  8337.                 });
  8338.               #undef ptr_as_symbol
  8339.             }
  8340.           #endif
  8341.         #endif
  8342.       }
  8343.   # object_tab initialisieren:
  8344.     local void init_object_tab_1 (void);
  8345.     local void init_object_tab_1()
  8346.       { var reg3 module_* module;
  8347.         #if defined(INIT_OBJECT_TAB) && NIL_IS_CONSTANT # object_tab schon vorinitialisiert?
  8348.           for_modules(all_other_modules,
  8349.             { var reg1 object* ptr = module->otab; # object_tab durchgehen
  8350.               var reg2 uintC count;
  8351.               dotimesC(count,*module->otab_size, { *ptr++ = NIL; });
  8352.             });
  8353.         #else
  8354.           for_modules(all_modules,
  8355.             { var reg1 object* ptr = module->otab; # object_tab durchgehen
  8356.               var reg2 uintC count;
  8357.               dotimesC(count,*module->otab_size, { *ptr++ = NIL; });
  8358.             });
  8359.         #endif
  8360.       }
  8361.  
  8362. # Initialisierungs-Routinen fⁿr die Tabellen
  8363. # wΣhrend des 2. Teils der Initialisierungsphase:
  8364.   # subr_tab fertig initialisieren: Keyword-Vektoren eintragen.
  8365.     local void init_subr_tab_2 (void);
  8366.     local void init_subr_tab_2()
  8367.       #if 0
  8368.         # Ich hΣtt's gern so einfach, aber
  8369.         # bei TURBO-C reicht der Speicher zum Compilieren nicht!
  8370.         { # subr_tab durchgehen
  8371.           var reg2 object vec;
  8372.           var reg1 object* vecptr;
  8373.           #define LISPFUN  LISPFUN_H
  8374.           #define kw(name)  *vecptr++ = S(K##name)
  8375.           #include "subr.c"
  8376.           #undef LISPFUN
  8377.           #undef kw
  8378.         }
  8379.       #else
  8380.         { # Keyword-Vektoren einzeln erzeugen:
  8381.           var reg2 object vec;
  8382.           var reg1 object* vecptr;
  8383.           # fⁿllt ein einzelnes Keyword mehr in den Vektor ein:
  8384.             #define kw(name)  *vecptr++ = S(K##name)
  8385.           # bildet Vektor mit gegebenen Keywords:
  8386.             #define v(key_anz,keywords)  \
  8387.               vec = allocate_vector(key_anz); \
  8388.               vecptr = &TheSvector(vec)->data[0]; \
  8389.               keywords;
  8390.           # setzt den Vektor als Keyword-Vektor zum SUBR name fest:
  8391.             #define s(name)  subr_tab.D_##name.keywords = vec;
  8392.           v(7, (kw(adjustable),kw(element_type),kw(initial_element),
  8393.                 kw(initial_contents),kw(fill_pointer),
  8394.                 kw(displaced_to),kw(displaced_index_offset)) )
  8395.           s(make_array)
  8396.           v(6, (kw(element_type),kw(initial_element),
  8397.                 kw(initial_contents),kw(fill_pointer),
  8398.                 kw(displaced_to),kw(displaced_index_offset)) )
  8399.           s(adjust_array)
  8400.           v(4, (kw(start1),kw(end1),kw(start2),kw(end2)) )
  8401.           s(string_gleich)
  8402.           s(string_ungleich)
  8403.           s(string_kleiner)
  8404.           s(string_groesser)
  8405.           s(string_klgleich)
  8406.           s(string_grgleich)
  8407.           s(string_equal)
  8408.           s(string_not_equal)
  8409.           s(string_lessp)
  8410.           s(string_greaterp)
  8411.           s(string_not_greaterp)
  8412.           s(string_not_lessp)
  8413.           s(search_string_gleich)
  8414.           s(search_string_equal)
  8415.           s(replace)
  8416.           v(1, (kw(initial_element)) )
  8417.           s(make_string)
  8418.           s(make_list)
  8419.           v(2, (kw(start),kw(end)) )
  8420.           s(nstring_upcase)
  8421.           s(string_upcase)
  8422.           s(nstring_downcase)
  8423.           s(string_downcase)
  8424.           s(nstring_capitalize)
  8425.           s(string_capitalize)
  8426.           s(write_string)
  8427.           s(write_line)
  8428.           s(fill)
  8429.           s(read_char_sequence)
  8430.           s(write_char_sequence)
  8431.           s(read_byte_sequence)
  8432.           s(write_byte_sequence)
  8433.           v(5, (kw(initial_contents),
  8434.                 kw(test),kw(size),kw(rehash_size),kw(rehash_threshold)) )
  8435.           s(make_hash_table)
  8436.           v(3, (kw(preserve_whitespace),kw(start),kw(end)) )
  8437.           s(read_from_string)
  8438.           v(4, (kw(start),kw(end),kw(radix),kw(junk_allowed)) )
  8439.           s(parse_integer)
  8440.           v(13, (kw(case),kw(level),kw(length),kw(gensym),kw(escape),kw(radix),
  8441.                  kw(base),kw(array),kw(circle),kw(pretty),kw(closure),kw(readably),
  8442.                  kw(stream)) )
  8443.           s(write)
  8444.           v(12, (kw(case),kw(level),kw(length),kw(gensym),kw(escape),kw(radix),
  8445.                  kw(base),kw(array),kw(circle),kw(pretty),kw(closure),kw(readably)) )
  8446.           s(write_to_string)
  8447.           v(2, (kw(type),kw(identity)) )
  8448.           s(write_unreadable)
  8449.           v(2, (kw(test),kw(test_not)) )
  8450.           s(tree_equal)
  8451.           v(3, (kw(test),kw(test_not),kw(key)) )
  8452.           s(subst)
  8453.           s(nsubst)
  8454.           s(sublis)
  8455.           s(nsublis)
  8456.           s(member)
  8457.           s(adjoin)
  8458.           s(assoc)
  8459.           s(rassoc)
  8460.           v(1, (kw(key)) )
  8461.           s(subst_if)
  8462.           s(subst_if_not)
  8463.           s(nsubst_if)
  8464.           s(nsubst_if_not)
  8465.           s(member_if)
  8466.           s(member_if_not)
  8467.           s(assoc_if)
  8468.           s(assoc_if_not)
  8469.           s(rassoc_if)
  8470.           s(rassoc_if_not)
  8471.           s(merge)
  8472.           v(2, (kw(nicknames),kw(use)) )
  8473.           s(make_package)
  8474.           s(pin_package)
  8475.           s(in_package)
  8476.           v(2, (kw(initial_element),kw(update)) )
  8477.           s(make_sequence)
  8478.           v(5, (kw(from_end),kw(start),kw(end),kw(key),kw(initial_value)) )
  8479.           s(reduce)
  8480.           v(7, (kw(from_end),kw(start),kw(end),kw(key),kw(test),kw(test_not),kw(count)) )
  8481.           s(remove)
  8482.           s(delete)
  8483.           s(substitute)
  8484.           s(nsubstitute)
  8485.           v(5, (kw(from_end),kw(start),kw(end),kw(key),kw(count)) )
  8486.           s(remove_if)
  8487.           s(remove_if_not)
  8488.           s(delete_if)
  8489.           s(delete_if_not)
  8490.           s(substitute_if)
  8491.           s(substitute_if_not)
  8492.           s(nsubstitute_if)
  8493.           s(nsubstitute_if_not)
  8494.           v(6, (kw(from_end),kw(start),kw(end),kw(key),kw(test),kw(test_not)) )
  8495.           s(remove_duplicates)
  8496.           s(delete_duplicates)
  8497.           s(find)
  8498.           s(position)
  8499.           s(count)
  8500.           v(4, (kw(from_end),kw(start),kw(end),kw(key)) )
  8501.           s(find_if)
  8502.           s(find_if_not)
  8503.           s(position_if)
  8504.           s(position_if_not)
  8505.           s(count_if)
  8506.           s(count_if_not)
  8507.           v(8, (kw(start1),kw(end1),kw(start2),kw(end2),kw(from_end),
  8508.                 kw(key),kw(test),kw(test_not)) )
  8509.           s(mismatch)
  8510.           s(search)
  8511.           v(3, (kw(key),kw(start),kw(end)) )
  8512.           s(sort)
  8513.           s(stable_sort)
  8514.           v(3, (kw(start),kw(end),kw(junk_allowed)) )
  8515.           s(parse_namestring)
  8516.           v(1, (kw(case)) )
  8517.           s(pathnamehost)
  8518.           s(pathnamedevice)
  8519.           s(pathnamedirectory)
  8520.           s(pathnamename)
  8521.           s(pathnametype)
  8522.           #ifdef LOGICAL_PATHNAMES
  8523.           v(0, )
  8524.           s(translate_logical_pathname)
  8525.           #endif
  8526.           v(1, (kw(wild)) )
  8527.           s(merge_pathnames)
  8528.           v(8, (kw(defaults),kw(case),kw(host),kw(device),kw(directory),kw(name),kw(type),kw(version)) )
  8529.           s(make_pathname)
  8530.           #ifdef LOGICAL_PATHNAMES
  8531.           s(make_logical_pathname)
  8532.           #endif
  8533.           v(2, (kw(all),kw(merge)) )
  8534.           s(translate_pathname)
  8535.           v(4, (kw(direction),kw(element_type),kw(if_exists),kw(if_does_not_exist)) )
  8536.           s(open)
  8537.           v(2, (kw(circle),kw(full)) )
  8538.           s(directory)
  8539.           v(1, (kw(abort)) )
  8540.           s(close)
  8541.           #ifdef REXX
  8542.           v(6, (kw(result),kw(string),kw(token),kw(async),kw(io),kw(return)) )
  8543.           s(rexx_put)
  8544.           #endif
  8545.           #undef s
  8546.           #undef v
  8547.           #undef kw
  8548.         }
  8549.       #endif
  8550.   # symbol_tab zu Ende initialisieren: Printnamen und Home-Package eintragen.
  8551.     local void init_symbol_tab_2 (void);
  8552.     local void init_symbol_tab_2()
  8553.       { # Tabelle der Printnamen:
  8554.         local char* pname_table[symbol_anz] =
  8555.           {
  8556.             #define LISPSYM  LISPSYM_D
  8557.             #include "constsym.c"
  8558.             #undef LISPSYM
  8559.           };
  8560.         # Tabelle der Packages:
  8561.         enum { # Die Werte dieser AufzΣhlung sind der Reihe nach 0,1,2,...
  8562.                enum_lisp_index,
  8563.                enum_user_index,
  8564.                enum_system_index,
  8565.                enum_keyword_index,
  8566.                #define LISPPACK  LISPPACK_A
  8567.                #include "constpack.c"
  8568.                #undef LISPPACK
  8569.                enum_dummy_index
  8570.           };
  8571.         #define package_anz  ((uintL)enum_dummy_index)
  8572.         local uintB package_index_table[symbol_anz] =
  8573.           {
  8574.             #define LISPSYM  LISPSYM_E
  8575.             #include "constsym.c"
  8576.             #undef LISPSYM
  8577.           };
  8578.         {var reg1 object list = O(all_packages); # Liste der Packages
  8579.          # kurz nach der Initialisierung:
  8580.          # (#<PACKAGE LISP> #<PACKAGE USER> #<PACKAGE SYSTEM> #<PACKAGE KEYWORD> ...)
  8581.          var reg2 uintC count;
  8582.          dotimespC(count,package_anz, { pushSTACK(Car(list)); list = Cdr(list); });
  8583.         }
  8584.        {var reg3 symbol_* ptr = (symbol_*)&symbol_tab; # symbol_tab durchgehen
  8585.         var reg4 char** pname_ptr = &pname_table[0]; # pname_table durchgehen
  8586.         var reg5 uintB* index_ptr = &package_index_table[0]; # package_index_table durchgehen
  8587.         var reg6 uintC count;
  8588.         dotimesC(count,symbol_anz,
  8589.           { ptr->pname = make_imm_array(asciz_to_string(*pname_ptr++)); # Printnamen eintragen
  8590.            {var reg2 uintB index = *index_ptr++;
  8591.             var reg1 object* package_ = &STACK_(package_anz-1) STACKop -(uintP)index; # Pointer auf Package
  8592.             pushSTACK(symbol_tab_ptr_as_object(ptr)); # Symbol
  8593.             import(&STACK_0,package_); # erst normal importieren
  8594.             if (index == (uintB)enum_lisp_index) # in #<PACKAGE LISP> ?
  8595.               { export(&STACK_0,package_); } # ja -> auch exportieren
  8596.             Symbol_package(popSTACK()) = *package_; # und die Home-Package setzen
  8597.             ptr++;
  8598.           }});
  8599.         skipSTACK(package_anz);
  8600.       }}
  8601.   # FSUBRs/SUBRs in ihre Symbole eintragen:
  8602.     local void init_symbol_functions (void);
  8603.     local void init_symbol_functions()
  8604.       {# FSUBRs eintragen:
  8605.        {typedef struct {
  8606.                         #if defined(INIT_SUBR_TAB) && NIL_IS_CONSTANT
  8607.                           #define LISPSPECFORM LISPSPECFORM_F
  8608.                           object name;
  8609.                           #define fsubr_name(p)  (p)->name
  8610.                         #else
  8611.                           #define LISPSPECFORM LISPSPECFORM_E
  8612.                           uintL name_offset;
  8613.                           #define fsubr_name(p)  symbol_tab_ptr_as_object((char*)&symbol_tab+(p)->name_offset)
  8614.                         #endif
  8615.                         uintW req_anz;
  8616.                         uintW opt_anz;
  8617.                         uintW body_flag;
  8618.                        }
  8619.                 fsubr_data;
  8620.         local fsubr_data fsubr_data_tab[] = {
  8621.                                               #include "fsubr.c"
  8622.                                             };
  8623.         #undef LISPSPECFORM
  8624.         var reg4 fsubr_* ptr1 = (fsubr_*)&fsubr_tab; # fsubr_tab durchgehen
  8625.         var reg2 fsubr_data* ptr2 = &fsubr_data_tab[0]; # fsubr_data_tab durchgehen
  8626.         var reg5 uintC count;
  8627.         dotimesC(count,fsubr_anz,
  8628.           { var reg3 object sym = fsubr_name(ptr2);
  8629.             var reg1 object obj = allocate_fsubr();
  8630.             TheFsubr(obj)->name = sym;
  8631.             TheFsubr(obj)->argtype = fixnum((uintW)fsubr_argtype(ptr2->req_anz,ptr2->opt_anz,ptr2->body_flag));
  8632.             TheFsubr(obj)->function = type_pointer_object(machine_type,*ptr1);
  8633.             Symbol_function(sym) = obj;
  8634.             ptr1++; ptr2++;
  8635.           });
  8636.        }
  8637.        # SUBRs eintragen:
  8638.        {var reg1 subr_* ptr = (subr_*)&subr_tab; # subr_tab durchgehen
  8639.         var reg2 uintC count;
  8640.         dotimesC(count,subr_anz,
  8641.           { Symbol_function(ptr->name) = subr_tab_ptr_as_object(ptr);
  8642.             ptr++;
  8643.           });
  8644.       }}
  8645.   # Konstanten/Variablen ihre Werte zuweisen:
  8646.     local void init_symbol_values (void);
  8647.     local void init_symbol_values()
  8648.       { # Hilfsmacro: Konstante := wert+1
  8649.         #if defined(UNIX_COHERENT) && !defined(GNU) # Bug in Coherent cc umgehen
  8650.           #define define_constant_UL1(symbol,wert)  \
  8651.             { var reg1 object x = # wert+1 als Integer \
  8652.                 I_1_plus_I(UL_to_I(wert));             \
  8653.               define_constant(symbol,x);               \
  8654.             }
  8655.         #else
  8656.           #define define_constant_UL1(symbol,wert)  \
  8657.             { var reg1 object x = # wert+1 als Integer             \
  8658.                 ( ((uintL)(wert) < (uintL)(bitm(oint_data_len)-1)) \
  8659.                   ? fixnum(wert+1)                                 \
  8660.                   : I_1_plus_I(UL_to_I(wert))                      \
  8661.                 );                                                 \
  8662.               define_constant(symbol,x);                           \
  8663.             }
  8664.         #endif
  8665.         # allgemein:
  8666.         define_constant(S(nil),S(nil));                 # NIL := NIL
  8667.         define_constant(S(t),S(t));                     # T := T
  8668.         # zu EVAL/CONTROL:
  8669.         define_constant_UL1(S(lambda_parameters_limit),lp_limit_1); # LAMBDA-PARAMETERS-LIMIT := lp_limit_1 + 1
  8670.         define_constant_UL1(S(call_arguments_limit),ca_limit_1); # CALL-ARGUMENTS-LIMIT := ca_limit_1 + 1
  8671.         define_constant(S(multiple_values_limit),       # MULTIPLE-VALUES-LIMIT
  8672.           fixnum(mv_limit));      # := mv_limit
  8673.         define_constant(S(jmpbuf_size),                 # SYS::*JMPBUF-SIZE* := Gr÷▀e eines jmp_buf
  8674.           fixnum(jmpbufsize));
  8675.         define_constant(S(big_endian),(BIG_ENDIAN_P ? T : NIL)); # SYS::*BIG-ENDIAN* := NIL bzw. T
  8676.         define_variable(S(macroexpand_hook),L(pfuncall)); # *MACROEXPAND-HOOK* := #'SYS::%FUNCALL
  8677.         define_variable(S(evalhookstern),NIL);          # *EVALHOOK*
  8678.         define_variable(S(applyhookstern),NIL);         # *APPLYHOOK*
  8679.         # zu PACKAGE:
  8680.         define_variable(S(packagestern),Car(O(all_packages))); # *PACKAGE* := '#<PACKAGE LISP>
  8681.         # zu LISPARIT:
  8682.         init_arith(); # definiert folgende:
  8683.         # define_variable(S(pi),);                      # PI
  8684.         # define_constant(S(most_positive_fixnum),);    # MOST-POSITIVE-FIXNUM
  8685.         # define_constant(S(most_negative_fixnum),);    # MOST-NEGATIVE-FIXNUM
  8686.         # define_constant(S(most_positive_short_float),); # MOST-POSITIVE-SHORT-FLOAT
  8687.         # define_constant(S(least_positive_short_float),); # LEAST-POSITIVE-SHORT-FLOAT
  8688.         # define_constant(S(least_negative_short_float),); # LEAST-NEGATIVE-SHORT-FLOAT
  8689.         # define_constant(S(most_negative_short_float),); # MOST-NEGATIVE-SHORT-FLOAT
  8690.         # define_constant(S(most_positive_single_float),); # MOST-POSITIVE-SINGLE-FLOAT
  8691.         # define_constant(S(least_positive_single_float),); # LEAST-POSITIVE-SINGLE-FLOAT
  8692.         # define_constant(S(least_negative_single_float),); # LEAST-NEGATIVE-SINGLE-FLOAT
  8693.         # define_constant(S(most_negative_single_float),); # MOST-NEGATIVE-SINGLE-FLOAT
  8694.         # define_constant(S(most_positive_double_float),); # MOST-POSITIVE-DOUBLE-FLOAT
  8695.         # define_constant(S(least_positive_double_float),); # LEAST-POSITIVE-DOUBLE-FLOAT
  8696.         # define_constant(S(least_negative_double_float),); # LEAST-NEGATIVE-DOUBLE-FLOAT
  8697.         # define_constant(S(most_negative_double_float),); # MOST-NEGATIVE-DOUBLE-FLOAT
  8698.         # define_variable(S(most_positive_long_float),); # MOST-POSITIVE-LONG-FLOAT
  8699.         # define_variable(S(least_positive_long_float),); # LEAST-POSITIVE-LONG-FLOAT
  8700.         # define_variable(S(least_negative_long_float),); # LEAST-NEGATIVE-LONG-FLOAT
  8701.         # define_variable(S(most_negative_long_float),); # MOST-NEGATIVE-LONG-FLOAT
  8702.         # define_constant(S(short_float_epsilon),);     # SHORT-FLOAT-EPSILON
  8703.         # define_constant(S(single_float_epsilon),);    # SINGLE-FLOAT-EPSILON
  8704.         # define_constant(S(double_float_epsilon),);    # DOUBLE-FLOAT-EPSILON
  8705.         # define_variable(S(long_float_epsilon),);      # LONG-FLOAT-EPSILON
  8706.         # define_constant(S(short_float_negative_epsilon),); # SHORT-FLOAT-NEGATIVE-EPSILON
  8707.         # define_constant(S(single_float_negative_epsilon),); # SINGLE-FLOAT-NEGATIVE-EPSILON
  8708.         # define_constant(S(double_float_negative_epsilon),); # DOUBLE-FLOAT-NEGATIVE-EPSILON
  8709.         # define_variable(S(long_float_negative_epsilon),); # LONG-FLOAT-NEGATIVE-EPSILON
  8710.         # define_variable(S(read_default_float_format),); # *READ-DEFAULT-FLOAT-FORMAT*
  8711.         # define_variable(S(random_state),);            # *RANDOM-STATE*
  8712.         # zu ARRAY:
  8713.         define_constant_UL1(S(array_total_size_limit),arraysize_limit_1); # ARRAY-TOTAL-SIZE-LIMIT := arraysize_limit_1 + 1
  8714.         define_constant_UL1(S(array_dimension_limit),arraysize_limit_1); # ARRAY-DIMENSION-LIMIT := arraysize_limit_1 + 1
  8715.         define_constant_UL1(S(array_rank_limit),arrayrank_limit_1); # ARRAY-RANK-LIMIT := arrayrank_limit_1 + 1
  8716.         # zu DEBUG:
  8717.         define_variable(S(plus),NIL);                   # +
  8718.         define_variable(S(plus2),NIL);                  # ++
  8719.         define_variable(S(plus3),NIL);                  # +++
  8720.         define_variable(S(minus),NIL);                  # -
  8721.         define_variable(S(mal),NIL);                    # *
  8722.         define_variable(S(mal2),NIL);                   # **
  8723.         define_variable(S(mal3),NIL);                   # ***
  8724.         define_variable(S(durch),NIL);                  # /
  8725.         define_variable(S(durch2),NIL);                 # //
  8726.         define_variable(S(durch3),NIL);                 # ///
  8727.         define_variable(S(driverstern),NIL);            # *DRIVER* := NIL
  8728.         define_variable(S(break_driver),NIL);           # *BREAK-DRIVER* := NIL
  8729.         define_variable(S(break_count),Fixnum_0);       # SYS::*BREAK-COUNT* := 0
  8730.         # zu STREAM:
  8731.         # spΣter: init_streamvars(); # definiert folgende:
  8732.         # define_variable(S(standard_input),);          # *STANDARD-INPUT*
  8733.         # define_variable(S(standard_output),);         # *STANDARD-OUTPUT*
  8734.         # define_variable(S(error_output),);            # *ERROR-OUTPUT*
  8735.         # define_variable(S(query_io),);                # *QUERY-IO*
  8736.         # define_variable(S(debug_io),);                # *DEBUG-IO*
  8737.         # define_variable(S(terminal_io),);             # *TERMINAL-IO*
  8738.         # define_variable(S(trace_output),);            # *TRACE-OUTPUT*
  8739.         # define_variable(S(keyboard_input),);          # *KEYBOARD-INPUT*
  8740.         define_variable(S(default_pathname_defaults),unbound); # *DEFAULT-PATHNAME-DEFAULTS*
  8741.         #ifdef PRINTER_ATARI
  8742.           define_variable(S(printer_timeout),fixnum(1000)); # *PRINTER-TIMEOUT* := 1000 (= 5 Sekunden)
  8743.         #endif
  8744.         # zu IO:
  8745.         init_reader(); # definiert folgende:
  8746.         # define_variable(S(read_base),);               # *READ-BASE* := 10
  8747.         # define_variable(S(read_suppress),);           # *READ-SUPPRESS* := NIL
  8748.         # define_variable(S(readtablestern),);          # *READTABLE*
  8749.         define_variable(S(read_preserve_whitespace),unbound); # SYS::*READ-PRESERVE-WHITESPACE*
  8750.         define_variable(S(read_recursive_p),unbound);   # SYS::*READ-RECURSIVE-P*
  8751.         define_variable(S(read_reference_table),unbound); # SYS::*READ-REFERENCE-TABLE*
  8752.         define_variable(S(backquote_level),unbound);    # SYS::*BACKQUOTE-LEVEL*
  8753.         define_variable(S(compiling),NIL);              # SYS::*COMPILING* ;= NIL
  8754.         define_variable(S(print_case),S(Kupcase));      # *PRINT-CASE* := :UPCASE
  8755.         define_variable(S(print_level),NIL);            # *PRINT-LEVEL* := NIL
  8756.         define_variable(S(print_length),NIL);           # *PRINT-LENGTH* := NIL
  8757.         define_variable(S(print_gensym),T);             # *PRINT-GENSYM* := T
  8758.         define_variable(S(print_escape),T);             # *PRINT-ESCAPE* := T
  8759.         define_variable(S(print_radix),NIL);            # *PRINT-RADIX* := NIL
  8760.         define_variable(S(print_base),fixnum(10));      # *PRINT-BASE* := 10
  8761.         define_variable(S(print_array),T);              # *PRINT-ARRAY* := T
  8762.         define_variable(S(print_circle),NIL);           # *PRINT-CIRCLE* := NIL
  8763.         define_variable(S(print_pretty),NIL);           # *PRINT-PRETTY* := NIL
  8764.         define_variable(S(print_closure),NIL);          # *PRINT-CLOSURE* := NIL
  8765.         define_variable(S(print_readably),NIL);         # *PRINT-READABLY* := NIL
  8766.         define_variable(S(print_rpars),T);              # *PRINT-RPARS* := T
  8767.         define_variable(S(print_circle_table),unbound); # SYS::*PRINT-CIRCLE-TABLE*
  8768.         define_variable(S(prin_level),unbound);         # SYS::*PRIN-LEVEL*
  8769.         define_variable(S(prin_stream),unbound);        # SYS::*PRIN-STREAM*
  8770.         define_variable(S(prin_linelength),fixnum(79)); # SYS::*PRIN-LINELENGTH* := 79 (vorlΣufig)
  8771.         define_variable(S(prin_l1),unbound);            # SYS::*PRIN-L1*
  8772.         define_variable(S(prin_lm),unbound);            # SYS::*PRIN-LM*
  8773.         define_variable(S(prin_rpar),unbound);          # SYS::*PRIN-RPAR*
  8774.         define_variable(S(prin_jblocks),unbound);       # SYS::*PRIN-JBLOCKS*
  8775.         define_variable(S(prin_jbstrings),unbound);     # SYS::*PRIN-JBSTRINGS*
  8776.         define_variable(S(prin_jbmodus),unbound);       # SYS::*PRIN-JBMODUS*
  8777.         define_variable(S(prin_jblpos),unbound);        # SYS::*PRIN-JBLPOS*
  8778.         # zu EVAL:
  8779.         define_variable(S(evalhookstern),NIL);          # *EVALHOOK* := NIL
  8780.         define_variable(S(applyhookstern),NIL);         # *APPLYHOOK* := NIL
  8781.         # zu MISC:
  8782.         define_constant(S(internal_time_units_per_second),  # INTERNAL-TIME-UNITS-PER-SECOND
  8783.           fixnum(ticks_per_second) ); # := 200 bzw. 1000000
  8784.         # zu ERROR:
  8785.         define_variable(S(use_clcs),NIL);               # SYS::*USE-CLCS* := NIL
  8786.         define_variable(S(recursive_error_count),Fixnum_0); # SYS::*RECURSIVE-ERROR-COUNT* := 0
  8787.         define_variable(S(error_handler),NIL);          # *ERROR-HANDLER* := NIL
  8788.         # zu SPVW:
  8789.         define_variable(S(quiet),NIL);                  # SYS::*QUIET* := NIL
  8790.         # zu PATHNAME:
  8791.         #ifdef LOGICAL_PATHNAMES
  8792.         { # SYS::*LOGICAL-PATHNAME-TRANSLATIONS* := (MAKE-HASH-TABLE :TEST #'EQUAL)
  8793.           pushSTACK(S(Ktest)); pushSTACK(L(equal)); funcall(L(make_hash_table),2);
  8794.           define_variable(S(logpathname_translations),value1);
  8795.         }
  8796.         O(empty_logical_pathname) = allocate_logpathname();
  8797.         #endif
  8798.         # *DEFAULT-PATHNAME-DEFAULTS* vorlΣufig initialisieren:
  8799.         define_variable(S(default_pathname_defaults),allocate_pathname());
  8800.         #undef define_constant_UL1
  8801.       }
  8802.   # sonstige Objekte kreieren und Objekttabelle fⁿllen:
  8803.     local void init_object_tab (void);
  8804.     local void init_object_tab()
  8805.       { # Tabelle mit Initialisierungsstrings:
  8806.         local var char* object_initstring_tab []
  8807.           = {
  8808.              #define LISPOBJ LISPOBJ_C
  8809.              #include "constobj.c"
  8810.              #undef LISPOBJ
  8811.             };
  8812.         # *FEATURES* initialisieren:
  8813.         { var reg2 char* features_initstring =
  8814.             "(CLISP CLTL1 COMMON-LISP INTERPRETER"
  8815.             #ifdef FAST_SP
  8816.               " SYSTEM::CLISP2"
  8817.             #else
  8818.               " SYSTEM::CLISP3"
  8819.             #endif
  8820.             #ifdef LOGICAL_PATHNAMES
  8821.               " LOGICAL-PATHNAMES"
  8822.             #endif
  8823.             #ifdef ATARI
  8824.               " ATARI"
  8825.             #endif
  8826.             #ifdef AMIGA
  8827.               " AMIGA"
  8828.             #endif
  8829.             #ifdef SUN3
  8830.               " SUN3"
  8831.             #endif
  8832.             #ifdef SUN386
  8833.               " SUN386"
  8834.             #endif
  8835.             #ifdef SUN4
  8836.               " SUN4"
  8837.             #endif
  8838.             #ifdef PC386
  8839.               " PC386"
  8840.             #endif
  8841.             #ifdef MSDOS
  8842.              #ifdef OS2
  8843.               " OS/2"
  8844.              #else
  8845.               " DOS"
  8846.              #endif
  8847.             #endif
  8848.             #ifdef RISCOS
  8849.               " ACORN-RISCOS"
  8850.             #endif
  8851.             #ifdef UNIX
  8852.               " UNIX"
  8853.             #endif
  8854.             ")"
  8855.             ;
  8856.           pushSTACK(asciz_to_string(features_initstring));
  8857.          {var reg1 object list = (funcall(L(read_from_string),1), value1);
  8858.           define_variable(S(features),list);             # *FEATURES*
  8859.         }}
  8860.         # Objekte aus den Strings lesen:
  8861.         { var reg1 object* objptr = (object*)&object_tab; # object_tab durchgehen
  8862.           var reg2 char** stringptr = &object_initstring_tab[0]; # Stringtabelle durchgehen
  8863.           var reg3 uintC count;
  8864.           dotimesC(count,object_anz,
  8865.             { pushSTACK(asciz_to_string(*stringptr++)); # String
  8866.               funcall(L(make_string_input_stream),1); # in Stream verpacken
  8867.               pushSTACK(value1);
  8868.              {var reg4 object obj = read(&STACK_0,NIL,NIL); # Objekt lesen
  8869.               skipSTACK(1);
  8870.               if (!eq(obj,dot_value)) { *objptr = obj; } # und eintragen (au▀er ".")
  8871.               objptr++;
  8872.             }});
  8873.         }
  8874.         TheSstring(O(null_string))->data[0] = 0; # Nullbyte in den Null-String einfⁿgen
  8875.         Car(O(top_decl_env)) = O(declaration_types); # Toplevel-Deklarations-Environment bauen
  8876.       }
  8877.   # Zu-Fu▀-Initialisierung aller LISP-Daten:
  8878.     local void initmem (void);
  8879.     local void initmem()
  8880.       { init_symbol_tab_1(); # symbol_tab initialisieren
  8881.         init_object_tab_1(); # object_tab initialisieren
  8882.         # Jetzt sind die Tabellen erst einmal grob initialisiert, bei GC
  8883.         # kann nichts passieren.
  8884.         # subr_tab fertig initialisieren:
  8885.         init_subr_tab_2();
  8886.         # Packages initialisieren:
  8887.         init_packages();
  8888.         # symbol_tab fertig initialisieren:
  8889.         init_symbol_tab_2();
  8890.         # SUBRs/FSUBRs in ihre Symbole eintragen:
  8891.         init_symbol_functions();
  8892.         # Konstanten/Variablen: Wert in die Symbole eintragen:
  8893.         init_symbol_values();
  8894.         # sonstige Objekte kreieren:
  8895.         init_object_tab();
  8896.       }
  8897.   # Laden vom MEM-File:
  8898.     local void loadmem (char* filename); # siehe unten
  8899.   # Initialiserung der anderen, noch nicht initialisierten Module:
  8900.     local void init_other_modules (void);
  8901.     local void init_other_modules()
  8902.       { var reg7 module_* module; # modules durchgehen
  8903.         for_modules(all_other_modules,
  8904.           { if (!module->initialized)
  8905.               { # Subr-Symbole eintragen:
  8906.                 { var reg2 subr_* subr_ptr = module->stab;
  8907.                   var reg1 subr_initdata* init_ptr = module->stab_initdata;
  8908.                   var reg3 uintC count;
  8909.                   dotimesC(count,*module->stab_size,
  8910.                     { var reg5 char* packname = init_ptr->packname;
  8911.                       var reg6 object symname = asciz_to_string(init_ptr->symname);
  8912.                       var object symbol;
  8913.                       if (packname==NULL)
  8914.                         { symbol = make_symbol(symname); }
  8915.                         else
  8916.                         { var reg4 object pack = find_package(asciz_to_string(packname));
  8917.                           if (nullp(pack)) # Package nicht gefunden?
  8918.                             { asciz_out(DEUTSCH ? "Modul `" :
  8919.                                         ENGLISH ? "module `" :
  8920.                                         FRANCAIS ? "Pas de module ½" :
  8921.                                         ""
  8922.                                        );
  8923.                               asciz_out(module->name);
  8924.                               asciz_out(DEUTSCH ? "' ben÷tigt Package " :
  8925.                                         ENGLISH ? "' requires package " :
  8926.                                         FRANCAIS ? "╗ sans le paquetage " :
  8927.                                         ""
  8928.                                        );
  8929.                               asciz_out(packname);
  8930.                               asciz_out("." CRLFstring);
  8931.                               quit_sofort(1);
  8932.                             }
  8933.                           intern(symname,pack,&symbol);
  8934.                         }
  8935.                       subr_ptr->name = symbol; # Subr komplett machen
  8936.                       Symbol_function(symbol) = subr_tab_ptr_as_object(subr_ptr); # Funktion definieren
  8937.                       init_ptr++; subr_ptr++;
  8938.                     });
  8939.                 }
  8940.                 # Initialisierungsfunktion aufrufen:
  8941.                 (*module->initfunction)(module);
  8942.               }
  8943.           });
  8944.       }
  8945.  
  8946. #ifdef ATARI
  8947.   # Am Anfang nur den wirklich gebrauchten Speicher behalten.
  8948.   #ifdef GNU
  8949.     # GNU-C auf dem Atari: siehe libsrc/lib/crt0.c
  8950.     long _stksize = 0;
  8951.     #define basepage  _base
  8952.   #endif
  8953.   #ifdef ATARI_TURBO
  8954.     # TURBO-C auf dem Atari: siehe lib/tcstart.s
  8955.     # _StkSize sollte = 4KB sein; das mu▀ beim Compilieren eingestellt werden!
  8956.     #define basepage  _BasPag
  8957.   #endif
  8958.   extern BASEPAGE* basepage; # Zeiger auf die Base-Page
  8959. #endif
  8960.  
  8961. #ifdef AMIGAOS
  8962.  
  8963.   # Diese beiden Variablen werden, wenn man Glⁿck hat, vom Startup-System
  8964.   # (von dem main() aufgerufen wird) sinnvoll vorbesetzt:
  8965.   global Handle Input_handle = Handle_NULL;    # low-level stdin Eingabekanal
  8966.   global Handle Output_handle = Handle_NULL;   # low-level stdout Ausgabekanal
  8967.  
  8968.   global BPTR orig_dir_lock = BPTR_NONE; # das Current Directory beim Programmstart
  8969.   # wird verwendet von PATHNAME
  8970.  
  8971.   # Initialisierung, ganz zuerst in main() durchzufⁿhren:
  8972.     local void init_amiga (void);
  8973.     local void init_amiga()
  8974.       {
  8975.         cpu_is_68000 = ((SysBase->AttnFlags & (AFF_68020|AFF_68030|AFF_68040)) == 0);
  8976.         #ifdef MC68000
  8977.         # Diese Version ben÷tigt einen 68000. (Wegen addressbus_mask.)
  8978.         if (!cpu_is_68000)
  8979.           { exit(RETURN_FAIL); }
  8980.         #endif
  8981.         #ifdef MC680Y0
  8982.         # Diese Version ben÷tigt mindestens einen 68020, lΣuft nicht auf 68000.
  8983.         # (Wegen ari68020.d, einiger asm()s und wegen gcc-Option -m68020.)
  8984.         if (cpu_is_68000)
  8985.           { exit(RETURN_FAIL); }
  8986.         #endif
  8987.         if (Input_handle==Handle_NULL) { Input_handle = Input(); }
  8988.         if (Output_handle==Handle_NULL) { Output_handle = Output(); }
  8989.         # Abfrage, ob Workbench-Aufruf ohne besonderen Startup:
  8990.         if ((Input_handle==Handle_NULL) || (Output_handle==Handle_NULL))
  8991.           { exit(RETURN_FAIL); }
  8992.         # Benutzter Speicher mu▀ in [0..2^oint_addr_len-1] liegen:
  8993.         if (!(pointable_usable_test((aint)&init_amiga) # Code-Segment ⁿberprⁿfen
  8994.               && pointable_usable_test((aint)&symbol_tab) # Daten-Segment ⁿberprⁿfen
  8995.            ) )
  8996.           { asciz_out(DEUTSCH ? "Diese CLISP-Version mu▀ in Speicher mit niedrigen Adressen ablaufen." CRLFstring :
  8997.                       ENGLISH ? "This version of CLISP runs only in low address memory." CRLFstring :
  8998.                       FRANCAIS ? "Cette version de CLISP ne marche qu'en mΘmoire α adresse basse." CRLFstring :
  8999.                       ""
  9000.                      );
  9001.             asciz_out("CODE: "); hex_out((aint)&init_amiga);
  9002.             asciz_out(", DATA: "); hex_out((aint)&symbol_tab);
  9003.             asciz_out("." CRLFstring);
  9004.             exit(RETURN_FAIL);
  9005.           }
  9006.         #if !(defined(WIDE) || defined(MC68000))
  9007.         # Ein Flag, das uns hilft, Speicher mit niedrigen Adressen zu bekommen:
  9008.         retry_allocmemflag =
  9009.           (CPU_IS_68000              # der 68000 hat nur 24 Bit Adre▀bereich,
  9010.            ? MEMF_ANY                # nie ein zweiter Versuch n÷tig
  9011.            : SysBase->LibNode.lib_Version > 35 # Betriebssystem-Version >= 2.0 ?
  9012.              ? MEMF_24BITDMA                   # ja -> hat Flag MEMF_24BITDMA
  9013.              : MEMF_CHIP                       # nein -> mu▀ MEMF_CHIP verwenden
  9014.           );
  9015.         #endif
  9016.       }
  9017.  
  9018.   # Rⁿckgabe aller Ressourcen und Programmende:
  9019.   nonreturning_function(local, exit_amiga, (sintL code));
  9020.   local void exit_amiga(code)
  9021.     var reg3 sintL code;
  9022.     { begin_system_call();
  9023.       # Zurⁿck ins Verzeichnis, in das wir beim Programmstart waren:
  9024.       if (!(orig_dir_lock == BPTR_NONE)) # haben wir das Verzeichnis je gewechselt?
  9025.         { var reg1 BPTR lock = CurrentDir(orig_dir_lock); # zurⁿck ins alte
  9026.           UnLock(lock); # dieses nun freigeben
  9027.         }
  9028.       # Speicher freigeben:
  9029.       { var reg1 MemBlockHeader* memblocks = allocmemblocks;
  9030.         until (memblocks==NULL)
  9031.           { var reg2 MemBlockHeader* next = memblocks->next;
  9032.             FreeMem(memblocks,memblocks->size);
  9033.             memblocks = next;
  9034.       }   }
  9035.       # Programmende:
  9036.       exit(code);
  9037.     }
  9038.  
  9039. #endif
  9040.  
  9041. # Hauptprogramm trΣgt den Namen 'main'.
  9042.   #ifndef argc_t
  9043.     #define argc_t int  # Typ von argc ist meist 'int'.
  9044.   #endif
  9045.   global int main (argc_t argc, char* argv[]);
  9046.   local boolean argv_quiet = FALSE; # ob beim Start Quiet-Option angegeben
  9047.   global int main(argc,argv)
  9048.     var reg1 argc_t argc;
  9049.     var reg1 char* * argv;
  9050.     { # Initialisierung der Speicherverwaltung.
  9051.       # Gesamtvorgehen:
  9052.       # Command-Line-Argumente verarbeiten.
  9053.       # Speicheraufteilung bestimmen.
  9054.       # Commandstring anschauen und entweder LISP-Daten vom .MEM-File
  9055.       #   laden oder zu Fu▀ erzeugen und statische LISP-Daten initialisieren.
  9056.       # Interrupt-Handler aufbauen.
  9057.       # Begrⁿ▀ung ausgeben.
  9058.       # In den Driver springen.
  9059.       #
  9060.       #ifdef AMIGAOS
  9061.       init_amiga();
  9062.       #endif
  9063.       #ifdef EMUNIX
  9064.       # Wildcards und Response-Files in der Kommandozeile expandieren:
  9065.       _response(&argc,&argv);
  9066.       _wildcard(&argc,&argv);
  9067.       #endif
  9068.       #ifdef DJUNIX
  9069.       # Ctrl-Break verbieten, so weit es geht:
  9070.       local var int cbrk;
  9071.       cbrk = getcbrk();
  9072.       if (cbrk) { setcbrk(0); }
  9073.       # Ctrl-Break wollen wir abfangen:
  9074.       _go32_want_ctrl_break(1);
  9075.       #endif
  9076.       #if defined(MSDOS) && 0 # normalerweise unn÷tig
  9077.       # Auf stdin und stdout im Text-Modus zugreifen:
  9078.       begin_system_call();
  9079.       setmode(stdin_handle,O_TEXT);
  9080.       setmode(stdout_handle,O_TEXT);
  9081.       end_system_call();
  9082.       #endif
  9083.       #ifdef RISCOS
  9084.       # Disable UnixLib's automatic name munging:
  9085.       __uname_control = 1;
  9086.       #endif
  9087.       #ifdef UNIX
  9088.       user_uid = getuid();
  9089.       #ifdef GRAPHICS_SWITCH
  9090.       # Programm mu▀ mit "setuid root"-Privileg installiert werden:
  9091.       # (chown root, chmod 4755). Vom root-Privileg befreien wir uns so schnell
  9092.       # wie m÷glich - sicherheitshalber.
  9093.       { extern uid_t root_uid;
  9094.         root_uid = geteuid();
  9095.         setreuid(root_uid,user_uid);
  9096.       }
  9097.       #endif
  9098.       #endif
  9099.      {var uintL argv_memneed = 0;
  9100.       #ifndef NO_SP_MALLOC
  9101.       var uintL argv_stackneed = 0;
  9102.       #endif
  9103.       #ifdef MULTIMAP_MEMORY_VIA_FILE
  9104.       var local char* argv_tmpdir = NULL;
  9105.       #endif
  9106.       var local char* argv_memfile = NULL;
  9107.       var local uintL argv_init_filecount = 0;
  9108.       var local char** argv_init_files;
  9109.       var local boolean argv_compile = FALSE;
  9110.       var local boolean argv_compile_listing = FALSE;
  9111.       var local uintL argv_compile_filecount = 0;
  9112.       typedef struct { char* input_file; char* output_file; } argv_compile_file;
  9113.       var local argv_compile_file* argv_compile_files;
  9114.       var local char* argv_expr = NULL;
  9115.       var local char* argv_language = NULL;
  9116.       {var DYNAMIC_ARRAY(,argv_init_files_array,char*,(uintL)argc); # maximal argc Init-Files
  9117.        argv_init_files = argv_init_files_array;
  9118.       {var DYNAMIC_ARRAY(,argv_compile_files_array,argv_compile_file,(uintL)argc); # maximal argc File-Argumente
  9119.        argv_compile_files = argv_compile_files_array;
  9120.       if (!(setjmp(&!original_context) == 0)) goto end_of_main;
  9121.       # Argumente argv[0..argc-1] abarbeiten:
  9122.       #   -h              Help
  9123.       #   -m size         Memory size (size = xxxxxxxB oder xxxxKB oder xMB)
  9124.       #   -s size         Stack size (size = xxxxxxxB oder xxxxKB oder xMB)
  9125.       #   -t directory    temporΣres Directory
  9126.       #   -M file         MEM-File laden
  9127.       #   -L language     sets the user language
  9128.       #   -q              quiet: keine Copyright-Meldung
  9129.       #   -I              ILISP-freundlich
  9130.       #   -i file ...     LISP-File zur Initialisierung laden
  9131.       #   -c file ...     LISP-Files compilieren, dann LISP verlassen
  9132.       #   -l              Beim Compilieren: Listings anlegen
  9133.       #   -x expr         LISP-Expressions ausfⁿhren, dann LISP verlassen
  9134.       program_name = argv[0]; # argv[0] ist der Programmname
  9135.       if (FALSE)
  9136.         { usage:
  9137.           asciz_out("Usage:  ");
  9138.           asciz_out(program_name);
  9139.           asciz_out(" [-h] [-m memsize]");
  9140.           #ifndef NO_SP_MALLOC
  9141.           asciz_out(" [-s stacksize]");
  9142.           #endif
  9143.           #ifdef MULTIMAP_MEMORY_VIA_FILE
  9144.           asciz_out(" [-t tmpdir]");
  9145.           #endif
  9146.           asciz_out(" [-M memfile] [-L language] [-q] [-I] [-i initfile ...]"
  9147.                     " [-c [-l] lispfile [-o outputfile] ...] [-x expression]" CRLFstring);
  9148.           quit_sofort(1); # anormales Programmende
  9149.         }
  9150.      {var reg2 char** argptr = &argv[1];
  9151.       var reg3 char** argptr_limit = &argv[argc];
  9152.       var reg5 enum { illegal, for_init, for_compile } argv_for = illegal;
  9153.       # Durchlaufen und Optionen abarbeiten, alles Abgearbeitete durch NULL
  9154.       # ersetzen:
  9155.       while (argptr < argptr_limit)
  9156.         { var reg1 char* arg = *argptr++; # nΣchstes Argument
  9157.           if (arg[0] == '-')
  9158.             { switch (arg[1])
  9159.                 { case 'h': # Help
  9160.                     goto usage;
  9161.                   # Liefert nach einem einbuchstabigen Kⁿrzel den Rest der
  9162.                   # Option in arg. Evtl. Space wird ⁿbergangen.
  9163.                   #define OPTION_ARG  \
  9164.                     if (arg[2] == '\0') \
  9165.                       { if (argptr < argptr_limit) arg = *argptr++; else goto usage; } \
  9166.                       else { arg = &arg[2]; }
  9167.                   # Parst den Rest einer Option, die eine Byte-Gr÷▀e angibt.
  9168.                   # ▄berprⁿft auch, ob gewisse Grenzen eingehalten werden.
  9169.                   #define SIZE_ARG(docstring,sizevar,limit_low,limit_high)  \
  9170.                     # arg sollte aus einigen Dezimalstellen, dann   \
  9171.                     # evtl. K oder M, dann evtl. B oder W bestehen. \
  9172.                     {var reg4 uintL val = 0;                        \
  9173.                      while ((*arg >= '0') && (*arg <= '9'))         \
  9174.                        { val = 10*val + (uintL)(*arg++ - '0'); }    \
  9175.                      switch (*arg)                                  \
  9176.                        { case 'k': case 'K': # Angabe in Kilobytes  \
  9177.                            val = val * 1024; arg++; break;          \
  9178.                          case 'm': case 'M': # Angabe in Megabytes  \
  9179.                            val = val * 1024*1024; arg++; break;     \
  9180.                        }                                            \
  9181.                      switch (*arg)                                  \
  9182.                        { case 'w': case 'W': # Angabe in Worten     \
  9183.                            val = val * sizeof(object);              \
  9184.                          case 'b': case 'B': # Angabe in Bytes      \
  9185.                            arg++; break;                            \
  9186.                        }                                            \
  9187.                      if (!(*arg == '\0')) # Argument zu Ende?       \
  9188.                        { asciz_out("Syntax for " docstring ": nnnnnnn or nnnnKB or nMB" CRLFstring); \
  9189.                          goto usage;                                \
  9190.                        }                                            \
  9191.                      if (!((val >= limit_low) && (val <= limit_high))) \
  9192.                        { asciz_out(docstring " out of range" CRLFstring); \
  9193.                          goto usage;                                \
  9194.                        }                                            \
  9195.                      # Bei mehreren -m bzw. -s Argumenten zΣhlt nur das letzte. \
  9196.                      sizevar = val;                                 \
  9197.                     }
  9198.                   case 'm': # Memory size
  9199.                     OPTION_ARG
  9200.                     SIZE_ARG("memory size",argv_memneed,100000,
  9201.                              (oint_addr_len+addr_shift < intLsize-1 # memory size begrenzt durch
  9202.                               ? bitm(oint_addr_len+addr_shift)      # Adre▀raum in oint_addr_len+addr_shift Bits
  9203.                               : (uintL)bit(intLsize-1)-1            # (bzw. gro▀e Dummy-Grenze)
  9204.                             ))
  9205.                     break;
  9206.                   #ifndef NO_SP_MALLOC
  9207.                   case 's': # Stack size
  9208.                     OPTION_ARG
  9209.                     SIZE_ARG("stack size",argv_stackneed,40000,8*1024*1024)
  9210.                     break;
  9211.                   #endif
  9212.                   #ifdef MULTIMAP_MEMORY_VIA_FILE
  9213.                   case 't': # temporΣres Directory
  9214.                     OPTION_ARG
  9215.                     if (!(argv_tmpdir == NULL)) goto usage;
  9216.                     argv_tmpdir = arg;
  9217.                     break;
  9218.                   #endif
  9219.                   case 'M': # MEM-File
  9220.                     OPTION_ARG
  9221.                     # Bei mehreren -M Argumenten zΣhlt nur das letzte.
  9222.                     argv_memfile = arg;
  9223.                     break;
  9224.                   case 'L': # Language
  9225.                     OPTION_ARG
  9226.                     # Bei mehreren -L Argumenten zΣhlt nur das letzte.
  9227.                     argv_language = arg;
  9228.                     break;
  9229.                   case 'q': # keine Copyright-Meldung
  9230.                     argv_quiet = TRUE;
  9231.                     if (!(arg[2] == '\0')) goto usage;
  9232.                     break;
  9233.                   case 'I': # ILISP-freundlich
  9234.                     ilisp_mode = TRUE;
  9235.                     if (!(arg[2] == '\0')) goto usage;
  9236.                     break;
  9237.                   case 'i': # Initialisierungs-Files
  9238.                     argv_for = for_init;
  9239.                     if (!(arg[2] == '\0')) goto usage;
  9240.                     break;
  9241.                   case 'c': # Zu compilierende Files
  9242.                     argv_compile = TRUE;
  9243.                     argv_for = for_compile;
  9244.                     if (arg[2] == 'l')
  9245.                       { argv_compile_listing = TRUE;
  9246.                         if (!(arg[3] == '\0')) goto usage;
  9247.                       }
  9248.                       else
  9249.                       { if (!(arg[2] == '\0')) goto usage; }
  9250.                     break;
  9251.                   case 'l': # Compilate und Listings
  9252.                     argv_compile_listing = TRUE;
  9253.                     if (!(arg[2] == '\0')) goto usage;
  9254.                     break;
  9255.                   case 'o': # Ziel fⁿr zu compilierendes File
  9256.                     if (!(arg[2] == '\0')) goto usage;
  9257.                     OPTION_ARG
  9258.                     if (!((argv_compile_filecount > 0) && (argv_compile_files[argv_compile_filecount-1].output_file==NULL))) goto usage;
  9259.                     argv_compile_files[argv_compile_filecount-1].output_file = arg;
  9260.                     break;
  9261.                   case 'x': # LISP-Expression ausfⁿhren
  9262.                     OPTION_ARG
  9263.                     if (!(argv_expr == NULL)) goto usage;
  9264.                     argv_expr = arg;
  9265.                     break;
  9266.                   default: # Unbekannte Option
  9267.                     goto usage;
  9268.             }   }
  9269.             else
  9270.             # keine Option,
  9271.             # wird als zu ladendes / zu compilerendes File interpretiert
  9272.             { switch (argv_for)
  9273.                 { case for_init:
  9274.                     argv_init_files[argv_init_filecount++] = arg; break;
  9275.                   case for_compile:
  9276.                     argv_compile_files[argv_compile_filecount].input_file = arg;
  9277.                     argv_compile_files[argv_compile_filecount].output_file = NULL;
  9278.                     argv_compile_filecount++;
  9279.                     break;
  9280.                   case illegal:
  9281.                   default:
  9282.                     goto usage;
  9283.             }   }
  9284.         }
  9285.       # Optionen semantisch ⁿberprⁿfen und Defaults eintragen:
  9286.       if (argv_memneed == 0)
  9287.         #if defined(ATARI)
  9288.         { argv_memneed = GEMDOS_FreeMem(); } # freien Platz erfragen
  9289.         #else
  9290.         { argv_memneed = 512*1024*sizeof(object); } # 512 KW = 2 MB Default
  9291.         #endif
  9292.       #ifdef MULTIMAP_MEMORY_VIA_FILE
  9293.       if (argv_tmpdir == NULL)
  9294.         { argv_tmpdir = getenv("TMPDIR"); # Environment-Variable probieren
  9295.           if (argv_tmpdir == NULL)
  9296.             { argv_tmpdir = "/tmp"; }
  9297.         }
  9298.       #endif
  9299.       #ifndef LANGUAGE_STATIC
  9300.       if (argv_language
  9301.           #ifdef HAVE_ENVIRONMENT
  9302.           || (argv_language = getenv("CLISP_LANGUAGE"))
  9303.           #endif
  9304.          )
  9305.         { if (asciz_equal(argv_language,"ENGLISH") || asciz_equal(argv_language,"english"))
  9306.             { language = language_english; }
  9307.           elif (asciz_equal(argv_language,"DEUTSCH") || asciz_equal(argv_language,"deutsch")
  9308.                 || asciz_equal(argv_language,"GERMAN") || asciz_equal(argv_language,"german")
  9309.                )
  9310.             { language = language_deutsch; }
  9311.           elif (asciz_equal(argv_language,"FRANCAIS") || asciz_equal(argv_language,"francais")
  9312.                 || asciz_equal(argv_language,"FRENCH") || asciz_equal(argv_language,"french")
  9313.                )
  9314.             { language = language_francais; }
  9315.           else # Default: Englisch
  9316.             { language = language_english; }
  9317.         }
  9318.       #endif
  9319.       if (!argv_compile)
  9320.         # Manche Optionen sind nur zusammen mit '-c' sinnvoll:
  9321.         { if (argv_compile_listing) goto usage; }
  9322.         else
  9323.         # Andere Optionen sind nur ohne '-c' sinnvoll:
  9324.         { if (!(argv_expr == NULL)) goto usage; }
  9325.      }
  9326.      # Tabelle von Fehlermeldungen initialisieren:
  9327.      if (init_errormsg_table()<0) goto no_mem;
  9328.      # Speicher holen:
  9329.      #ifdef SPVW_PURE
  9330.      { var reg1 uintL heapnr;
  9331.        for (heapnr=0; heapnr<heapcount; heapnr++)
  9332.          { switch (heapnr)
  9333.              { # NB: IMMUTABLE spielt hier keine Rolle, denn die Heaps zu
  9334.                # case_imm_array  und  case imm_cons_type  werden immer leer
  9335.                # bleiben, da fⁿr sie keine allocate()-Anforderungen kommen.
  9336.                case_sstring:
  9337.                case_sbvector:
  9338.                case_bignum:
  9339.                #ifndef WIDE
  9340.                case_ffloat:
  9341.                #endif
  9342.                case_dfloat:
  9343.                case_lfloat:
  9344.                  mem.heaptype[heapnr] = 2; break;
  9345.                case_ostring:
  9346.                case_obvector:
  9347.                case_vector:
  9348.                case_array1:
  9349.                case_record:
  9350.                case_symbol:
  9351.                  mem.heaptype[heapnr] = 1; break;
  9352.                case_cons:
  9353.                case_ratio:
  9354.                case_complex:
  9355.                  mem.heaptype[heapnr] = 0; break;
  9356.                default:
  9357.                  mem.heaptype[heapnr] = -1; break;
  9358.          }   }
  9359.      }
  9360.      init_speicher_laengen();
  9361.      #endif
  9362.      #ifdef MAP_MEMORY
  9363.      # total_subr_anz bestimmen:
  9364.      { var reg2 uintC total = 0;
  9365.        var reg1 module_* module;
  9366.        for_modules(all_modules, { total += *module->stab_size; } );
  9367.        total_subr_anz = total;
  9368.      }
  9369.      #endif
  9370.      {# Aufteilung des Gesamtspeichers in Teile:
  9371.       #define teile             16  # 16/16
  9372.         #ifdef NO_SP_MALLOC # wird SP vom Betriebssystem bereitgestellt?
  9373.         #define teile_SP         0
  9374.         #else
  9375.         #define teile_SP         2  # 2/16 (1/16 reicht oft nicht)
  9376.         #endif
  9377.         #define teile_STACK      2  # 2/16
  9378.         #ifdef HAVE_NUM_STACK
  9379.         #define teile_NUM_STACK  1  # 1/16
  9380.         #else
  9381.         #define teile_NUM_STACK  0
  9382.         #endif
  9383.         #define teile_stacks     (teile_SP + teile_STACK + teile_NUM_STACK)
  9384.         #ifdef SPVW_MIXED_BLOCKS
  9385.         #define teile_objects    (teile - teile_stacks)  # Rest
  9386.         #else
  9387.         #define teile_objects    0
  9388.         #endif
  9389.       var reg4 uintL pagesize = # LΣnge einer Speicherseite
  9390.         #if defined(MULTIMAP_MEMORY_VIA_FILE)
  9391.         getpagesize()
  9392.         #elif defined(MULTIMAP_MEMORY_VIA_SHM)
  9393.         SHMLBA
  9394.         #elif (defined(SINGLEMAP_MEMORY) || defined(TRIVIALMAP_MEMORY)) && defined(HAVE_MACH_VM)
  9395.         vm_page_size
  9396.         #else # wenn die System-Speicherseiten-LΣnge keine Rolle spielt
  9397.         teile*Varobject_alignment
  9398.         #endif
  9399.         ;
  9400.       var reg5 uintL memneed = argv_memneed; # ben÷tigter Speicher
  9401.       var reg6 aint memblock; # untere Adresse des bereitgestellten Speicherblocks
  9402.       #ifndef SPVW_MIXED_BLOCKS_OPPOSITE
  9403.       memneed = teile_stacks*floor(memneed,teile); # noch keinen Speicher fⁿr objects berechnen
  9404.       #undef teile
  9405.       #define teile  teile_stacks
  9406.       #endif
  9407.       #ifndef NO_SP_MALLOC
  9408.       if (!(argv_stackneed==0))
  9409.         { memneed = memneed*(teile-teile_SP)/teile;
  9410.           # Die mit Option -s angegebene SP-Gr÷▀e ist noch nicht in memneed inbegriffen.
  9411.           memneed = memneed + argv_stackneed;
  9412.         }
  9413.       #endif
  9414.       #if defined(MULTIMAP_MEMORY_VIA_SHM) && (defined(UNIX_SUNOS4) || defined(UNIX_SUNOS5))
  9415.       # SunOS 4 weigert sich, ein shmat() in einen vorher mallozierten Bereich
  9416.       # hinein zu machen, selbst wenn dawischen ein munmap() liegt:
  9417.       # errno = EINVAL. Auch das Umgekehrte, erst shmat() zu machen und dann
  9418.       # mit sbrk() oder brk() den belegten Bereich dem Datensegment einzu-
  9419.       # verleiben, scheitert mit errno = ENOMEM.
  9420.       # Der einzige Ausweg ist, sich den ben÷tigten Speicher von weit weg,
  9421.       # m÷glichst au▀er Reichweite von malloc(), zu holen.
  9422.       { var reg1 uintL memhave = round_down(bit(oint_addr_len) - (aint)sbrk(0),SHMLBA);
  9423.         if (memhave < memneed) { memneed = memhave; }
  9424.         memblock = round_down(bit(oint_addr_len) - memneed,SHMLBA);
  9425.       }
  9426.       #else
  9427.       loop
  9428.         { memblock = (aint)mymalloc(memneed); # Speicher allozieren versuchen
  9429.           if (!((void*)memblock == NULL)) break; # gelungen -> OK
  9430.           memneed = floor(memneed,8)*7; # sonst mit 7/8 davon nochmals versuchen
  9431.           if (memneed < MINIMUM_SPACE+RESERVE) # aber mit weniger als MINIMUM_SPACE
  9432.             # geben wir uns nicht zufrieden:
  9433.             { asciz_out(DEUTSCH ? "Nur " :
  9434.                         ENGLISH ? "Only " :
  9435.                         FRANCAIS ? "Seuls " :
  9436.                         ""
  9437.                        );
  9438.               dez_out(memneed);
  9439.               asciz_out(DEUTSCH ? " Bytes verfⁿgbar." :
  9440.                         ENGLISH ? " bytes available." :
  9441.                         FRANCAIS ? " octets libres." :
  9442.                         ""
  9443.                        );
  9444.               asciz_out(CRLFstring);
  9445.               goto no_mem;
  9446.         }   }
  9447.       #endif
  9448.       #ifdef ATARI
  9449.       MEMBLOCK = memblock;
  9450.       #endif
  9451.       #ifdef MULTIMAP_MEMORY
  9452.       # Wir brauchen zwar nur diesen Adre▀raum und nicht seinen Inhalt, dⁿrfen
  9453.       # ihn aber nicht freigeben, da er in unserer Kontrolle bleiben soll.
  9454.       #endif
  9455.       # Aufrunden zur nΣchsten Speicherseitengrenze:
  9456.       {var reg1 uintL unaligned = (uintL)(-memblock) % pagesize;
  9457.        memblock += unaligned; memneed -= unaligned;
  9458.       }
  9459.       # Abrunden zur letzen Speicherseitengrenze:
  9460.       {var reg1 uintL unaligned = memneed % pagesize;
  9461.        memneed -= unaligned;
  9462.       }
  9463.       # Der Speicherbereich [memblock,memblock+memneed-1] ist nun frei,
  9464.       # und seine Grenzen liegen auf Speicherseitengrenzen.
  9465.       #ifdef MULTIMAP_MEMORY
  9466.         map_pagesize = pagesize;
  9467.         #ifdef MULTIMAP_MEMORY_VIA_FILE
  9468.         if ( initmap(argv_tmpdir) <0) goto no_mem;
  9469.         #else
  9470.         if ( initmap() <0) goto no_mem;
  9471.         #endif
  9472.         multimap(case_machine: case_array: case_record: case_system:
  9473.                  case_bignum: case_ratio: case_ffloat: case_dfloat: case_lfloat: case_complex:
  9474.                  case_symbolflagged: case_cons:, IMM_TYPECASES, IMM_FLAG,
  9475.                  memblock, memneed);
  9476.         # Dazu noch symbol_tab an die Adresse 0 legen:
  9477.         {var reg3 uintL memneed = round_up(sizeof(symbol_tab),pagesize); # LΣnge aufrunden
  9478.          multimap(case_symbolflagged: , , FALSE, 0, memneed);
  9479.         }
  9480.         # Dazu noch subr_tab an die Adresse 0 legen:
  9481.         if ( zeromap(&subr_tab,round_up(total_subr_anz*sizeof(subr_),pagesize)) <0) goto no_mem;
  9482.         #ifdef MULTIMAP_MEMORY_VIA_FILE
  9483.         if ( CLOSE(zero_fd) <0)
  9484.           { asciz_out(DEUTSCH ? "Kann /dev/zero nicht schlie▀en." :
  9485.                       ENGLISH ? "Cannot close /dev/zero ." :
  9486.                       FRANCAIS ? "Ne peux pas fermer /dev/zero ." :
  9487.                       ""
  9488.                      );
  9489.             errno_out(errno);
  9490.             goto no_mem;
  9491.           }
  9492.         #endif
  9493.       #endif
  9494.       #if defined(SINGLEMAP_MEMORY) || defined(TRIVIALMAP_MEMORY) # <==> SPVW_PURE_BLOCKS || TRIVIALMAP_MEMORY
  9495.         map_pagesize = # LΣnge einer Hardware-Speicherseite
  9496.           # UNIX_SUNOS5 hat doch tatsΣchlich mmap(), aber kein getpagesize() !
  9497.           #if defined(HAVE_GETPAGESIZE)
  9498.           getpagesize()
  9499.           #elif defined(HAVE_MACH_VM)
  9500.           vm_page_size
  9501.           #elif defined(HAVE_SHM)
  9502.           SHMLBA
  9503.           #elif defined(UNIX_SUNOS5)
  9504.           PAGESIZE # siehe <sys/param.h>
  9505.           #else
  9506.           4096
  9507.           #endif
  9508.           ;
  9509.         if ( initmap() <0) goto no_mem;
  9510.         #ifdef SINGLEMAP_MEMORY
  9511.         # Alle Heaps vor-initialisieren:
  9512.         { var reg2 uintL heapnr;
  9513.           for (heapnr=0; heapnr<heapcount; heapnr++)
  9514.             { var reg1 Heap* heapptr = &mem.heaps[heapnr];
  9515.               heapptr->heap_limit = (aint)type_pointer_object(heapnr,0);
  9516.         }   }
  9517.         # Dazu noch symbol_tab, subr_tab an die Adresse 0 legen:
  9518.         # (Hierzu mu▀ case_symbolflagged mit case_symbol Σquivalent sein!)
  9519.         #define map_tab(tab,size)  \
  9520.           { var reg1 uintL map_len = round_up(size,map_pagesize); \
  9521.             if ( zeromap(&tab,map_len) <0) goto no_mem;           \
  9522.             mem.heaps[typecode(&tab)].heap_limit += map_len;      \
  9523.           }
  9524.         map_tab(symbol_tab,sizeof(symbol_tab));
  9525.         map_tab(subr_tab,total_subr_anz*sizeof(subr_));
  9526.         #endif
  9527.         #ifdef TRIVIALMAP_MEMORY
  9528.         # Alle Heaps als leer initialisieren.
  9529.         # Dabei den gesamten zur Verfⁿgung stehenden Platz im VerhΣltnis 1:1 aufteilen.
  9530.         { var reg3 void* malloc_addr = malloc(1);
  9531.           var reg1 aint start = round_up((aint)malloc_addr+1*1024*1024,map_pagesize); # 1 MB Reserve fⁿr malloc()
  9532.           var reg2 aint end = bitm(oint_addr_len+addr_shift);
  9533.           mem.heaps[0].heap_limit = start;
  9534.           mem.heaps[1].heap_limit = start + round_down(floor(end-start,2),map_pagesize);
  9535.           free(malloc_addr);
  9536.         }
  9537.         #endif
  9538.         # Alle Heaps als leer initialisieren:
  9539.         { var reg2 uintL heapnr;
  9540.           for (heapnr=0; heapnr<heapcount; heapnr++)
  9541.             { var reg1 Heap* heapptr = &mem.heaps[heapnr];
  9542.               heapptr->heap_start = heapptr->heap_end = heapptr->heap_limit;
  9543.               #ifdef GENERATIONAL_GC
  9544.               heapptr->heap_gen0_start = heapptr->heap_gen0_end = heapptr->heap_gen1_start = heapptr->heap_limit;
  9545.               heapptr->physpages = NULL;
  9546.               #endif
  9547.         }   }
  9548.        #ifdef SINGLEMAP_MEMORY_STACK
  9549.         # STACK initialisieren:
  9550.         { var reg1 uintL map_len = round_up(memneed * teile_STACK/teile, map_pagesize);
  9551.           # Der Stack belegt das Intervall von 0 bis map_len bei Typcode = system_type:
  9552.           var reg2 aint low = (aint)type_pointer_object(system_type,0);
  9553.           var reg3 aint high = low + map_len;
  9554.           if ( zeromap((void*)low,map_len) <0) goto no_mem;
  9555.           #ifdef STACK_DOWN
  9556.             STACK_bound = (object*)(low + 0x100); # 64 Pointer Sicherheitsmarge
  9557.             setSTACK(STACK = (object*)high); # STACK initialisieren
  9558.           #endif
  9559.           #ifdef STACK_UP
  9560.             setSTACK(STACK = (object*)low); # STACK initialisieren
  9561.             STACK_bound = (object*)(high - 0x100); # 64 Pointer Sicherheitsmarge
  9562.           #endif
  9563.         }
  9564.         #undef teile_STACK
  9565.         #define teile_STACK 0  # brauche keinen Platz mehr fⁿr den STACK
  9566.         #if (teile==0)
  9567.           #undef teile
  9568.           #define teile 1  # Division durch 0 vermeiden
  9569.         #endif
  9570.        #endif
  9571.        #ifdef GENERATIONAL_GC
  9572.        physpagesize = map_pagesize;
  9573.        # physpageshift = log2(physpagesize);
  9574.        { var reg1 uintL x = physpagesize;
  9575.          var reg2 uintL i = 0;
  9576.          until ((x >>= 1) == 0) { i++; }
  9577.          if (!((1UL << i) == physpagesize)) abort();
  9578.          physpageshift = i;
  9579.        }
  9580.        #endif
  9581.       #endif
  9582.       # Speicherblock aufteilen:
  9583.       { var reg3 uintL free_reserved; # Anzahl reservierter Bytes
  9584.         #ifndef NO_SP_MALLOC
  9585.         var reg10 void* initial_SP; # Initialwert fⁿr SP-Stackpointer
  9586.         var reg9 uintL for_SP = 0; # Anzahl Bytes fⁿr SP-Stack
  9587.         #define min_for_SP  40000 # minimale SP-Stack-Gr÷▀e
  9588.         #endif
  9589.         var reg7 uintL for_STACK; # Anzahl Bytes fⁿr Lisp-STACK
  9590.         var reg9 uintL for_NUM_STACK; # Anzahl Bytes fⁿr Zahlen-STACK
  9591.         var reg8 uintL for_objects; # Anzahl Bytes fⁿr Lisp-Objekte
  9592.         # Der STACK braucht Alignment, da bei Frame-Pointern das letzte Bit =0 sein mu▀:
  9593.         #define STACK_alignment  bit(addr_shift+1)
  9594.         #define alignment  (Varobject_alignment>STACK_alignment ? Varobject_alignment : STACK_alignment)
  9595.         free_reserved = memneed;
  9596.         #ifndef NO_SP_MALLOC
  9597.         if (!(argv_stackneed==0))
  9598.           if (2*argv_stackneed <= free_reserved) # nicht zu viel fⁿr den SP-Stack reservieren
  9599.             { for_SP = round_down(argv_stackneed,Varobject_alignment);
  9600.               free_reserved -= argv_stackneed;
  9601.             }
  9602.         #endif
  9603.         # Durch teile*alignment teilbar machen, damit jedes Sechzehntel aligned ist:
  9604.         free_reserved = round_down(free_reserved,teile*alignment);
  9605.         free_reserved = free_reserved - RESERVE;
  9606.        {var reg2 uintL teil = free_reserved/teile; # ein Teilblock, ein Sechzehntel des Platzes
  9607.         var reg1 aint ptr = memblock;
  9608.         mem.MEMBOT = ptr;
  9609.         #ifndef NO_SP_MALLOC
  9610.         # SP allozieren:
  9611.         if (for_SP==0)
  9612.           { for_SP = teile_SP*teil; } # 2/16 fⁿr Programmstack
  9613.           else
  9614.           # Platz fⁿr SP ist schon abgezwackt.
  9615.           { # teile := teile-teile_SP; # geht nicht mehr, stattdessen:
  9616.             teil = round_down(free_reserved/(teile-teile_SP),alignment);
  9617.           }
  9618.         if (for_SP < min_for_SP) { for_SP = round_up(min_for_SP,alignment); } # aber nicht zu wenig
  9619.         #ifdef SP_DOWN
  9620.           SP_bound = (void*)(ptr + 0x800); # 512 Pointer Sicherheitsmarge
  9621.           ptr += for_SP;
  9622.           initial_SP = (void*)ptr;
  9623.         #endif
  9624.         #ifdef SP_UP
  9625.           initial_SP = (void*)ptr;
  9626.           ptr += for_SP;
  9627.           SP_bound = (void*)(ptr - 0x800); # 512 Pointer Sicherheitsmarge
  9628.         #endif
  9629.         #endif
  9630.         # STACK allozieren:
  9631.         #ifdef SINGLEMAP_MEMORY_STACK
  9632.         for_STACK = 0; # STACK ist schon woanders alloziert.
  9633.         #else
  9634.         #ifdef STACK_DOWN
  9635.           STACK_bound = (object*)(ptr + 0x100); # 64 Pointer Sicherheitsmarge
  9636.           ptr += for_STACK = teile_STACK*teil; # 2/16 fⁿr Lisp-STACK
  9637.           setSTACK(STACK = (object*)ptr); # STACK initialisieren
  9638.         #endif
  9639.         #ifdef STACK_UP
  9640.           setSTACK(STACK = (object*)ptr); # STACK initialisieren
  9641.           ptr += for_STACK = teile_STACK*teil; # 2/16 fⁿr Lisp-STACK
  9642.           STACK_bound = (object*)(ptr - 0x100); # 64 Pointer Sicherheitsmarge
  9643.         #endif
  9644.         #endif
  9645.         #ifdef HAVE_NUM_STACK
  9646.         # NUM_STACK allozieren:
  9647.         #ifdef NUM_STACK_DOWN
  9648.           NUM_STACK_bound = (uintD*)ptr;
  9649.           ptr += for_NUM_STACK = teile_NUM_STACK*teil; # 1/16 fⁿr Zahlen-STACK
  9650.           NUM_STACK = NUM_STACK_normal = (uintD*)round_down(ptr,sizeof(uintD)); # NUM_STACK initialisieren
  9651.         #endif
  9652.         #ifdef NUM_STACK_UP
  9653.           NUM_STACK = NUM_STACK_normal = (uintD*)round_up(ptr,sizeof(uintD)); # NUM_STACK initialisieren
  9654.           ptr += for_NUM_STACK = teile_NUM_STACK*teil; # 1/16 fⁿr Zahlen-STACK
  9655.           NUM_STACK_bound = (uintD*)ptr;
  9656.         #endif
  9657.         #else
  9658.         for_NUM_STACK = 0; # kein Zahlen-Stack vorhanden
  9659.         #endif
  9660.         #ifdef SPVW_MIXED_BLOCKS_OPPOSITE
  9661.         # Nun fangen die Lisp-Objekte an:
  9662.         mem.objects.start = ptr;
  9663.         mem.objects.end = ptr; # Noch gibt es keine Objekte variabler LΣnge
  9664.         # Rest (14/16 oder etwas weniger) fⁿr Lisp-Objekte:
  9665.         for_objects = memblock+free_reserved - ptr; # etwa = teile_objects*teil
  9666.         ptr += for_objects;
  9667.         mem.conses.start = ptr; # Noch gibt es keine Conses
  9668.         mem.conses.end = ptr;
  9669.         # ptr = memblock+free_reserved, da 2/16 + 14/16 = 1
  9670.         # Reservespeicher allozieren:
  9671.         ptr += RESERVE;
  9672.         # oberes Speicherende erreicht.
  9673.         mem.MEMTOP = ptr;
  9674.         # Darⁿber (weit weg) der Maschinenstack.
  9675.         #endif
  9676.         #if defined(SPVW_PURE_BLOCKS) || defined(TRIVIALMAP_MEMORY)
  9677.         mem.total_room = 0;
  9678.         #ifdef GENERATIONAL_GC
  9679.         mem.last_gcend_space0 = 0;
  9680.         mem.last_gcend_space1 = 0;
  9681.         #endif
  9682.         #endif
  9683.         #ifdef SPVW_PAGES
  9684.         for_each_heap(heap, { heap->inuse = EMPTY; } );
  9685.         for_each_cons_heap(heap, { heap->lastused = dummy_lastused; } );
  9686.         dummy_lastused->page_room = 0;
  9687.         mem.free_pages = NULL;
  9688.         mem.total_space = 0;
  9689.         mem.used_space = 0;
  9690.         mem.last_gcend_space = 0;
  9691.         mem.gctrigger_space = 0;
  9692.         #endif
  9693.         # Stacks initialisieren:
  9694.         #ifdef NO_SP_MALLOC
  9695.           #ifdef AMIGAOS
  9696.           { var struct Process * myprocess = (struct Process *)FindTask(NULL);
  9697.             var aint original_SP = process->pr_ReturnAddr; # SP beim Programmstart
  9698.             # Die Shell legt die Stackgr÷▀e vor dem Start auf den SP.
  9699.             ptr = original_SP - *(ULONG*)original_SP;
  9700.             SP_bound = ptr + 0x1000; # 1024 Pointer Sicherheitsmarge
  9701.           }
  9702.           #endif
  9703.         #else
  9704.           #ifdef GNU
  9705.             # eine kleine Dummy-Aktion, die ein hinausgez÷gertes AufrΣumen des SP
  9706.             # zu einem spΣteren Zeitpunkt verhindert:
  9707.             if (mem.MEMBOT) { asciz_out(""); }
  9708.           #endif
  9709.           #if defined(EMUNIX) && defined(WINDOWS)
  9710.           SP_start = SP(); # Fⁿr System-Calls mⁿssen wir auf diesen Stack zurⁿck!!
  9711.           #endif
  9712.           setSP(initial_SP); # SP setzen! Dabei gehen alle lokalen Variablen verloren!
  9713.         #endif
  9714.         pushSTACK(nullobj); pushSTACK(nullobj); # Zwei Nullpointer als STACKende-Kennung
  9715.      }}}
  9716.       #ifdef ATARI
  9717.         # Line-A-Routinen initialisieren:
  9718.         LineA_Init();
  9719.         # Maus abschalten:
  9720.         LineA_MouseHide();
  9721.         # Bildschirmausgabe initialisieren:
  9722.         asciz_out(
  9723.           ESCstring "E"  # CLEAR HOME, Bildschirm l÷schen
  9724.           ESCstring "v"  # Ab jetzt bei Zeilenⁿberlauf immer in neue Zeile
  9725.           ESCstring "q"  # Reverse off
  9726.           ESCstring "f"  # Cursor ausschalten
  9727.           );
  9728.       #endif
  9729.       init_subr_tab_1(); # subr_tab initialisieren
  9730.       if (argv_memfile==NULL)
  9731.        #ifdef ATARI
  9732.         # Auf dem Atari mu▀ man meist ohne Kommandozeilen-Option auskommen.
  9733.         { argv_memfile = "lispinit.mem"; } # Daher ein sinnvoller Default.
  9734.        #else
  9735.         # Zu-Fu▀-Initialisierung:
  9736.         { initmem(); }
  9737.         else
  9738.        #endif
  9739.         # Speicherfile laden:
  9740.         { loadmem(argv_memfile); }
  9741.       init_other_modules(); # die noch unitialisierten Module initialisieren
  9742.       # aktuelle Evaluator-Environments auf den Toplevel-Wert setzen:
  9743.       aktenv.var_env   = NIL;
  9744.       aktenv.fun_env   = NIL;
  9745.       aktenv.block_env = NIL;
  9746.       aktenv.go_env    = NIL;
  9747.       aktenv.decl_env  = O(top_decl_env);
  9748.       # Alles fertig initialisiert.
  9749.       set_break_sem_1(); clr_break_sem_2(); clr_break_sem_3(); clr_break_sem_4();
  9750.       everything_ready = TRUE;
  9751.       # Interrupt-Handler einrichten:
  9752.       #ifdef ATARI
  9753.         # VBL-Routine modifizieren:
  9754.         set_break_sem_1(); # neue Routine erstmal sperren
  9755.         new_VBL_fixup_break = &break_sems.gesamt;
  9756.         new_VBL_fixup_linea = &linea;
  9757.         new_VBL_fixup_tast_fehler = &tastatur_interrupt;
  9758.         old_VBL = BIOS_GetException(28);
  9759.         BIOS_SetException(28,new_VBL);
  9760.       #endif
  9761.       #if defined(HAVE_SIGNALS)
  9762.         #if defined(SIGWINCH) && !defined(NO_ASYNC_INTERRUPTS)
  9763.         # Eine verΣnderte Gr÷▀e des Terminal-Fensters soll sich auch sofort
  9764.         # in SYS::*PRIN-LINELENGTH* bemerkbar machen:
  9765.         SIGNAL(SIGWINCH,&sigwinch_handler);
  9766.         #endif
  9767.         # Die Gr÷▀e des Terminal-Fensters auch jetzt beim Programmstart erfragen:
  9768.         begin_system_call();
  9769.         update_linelength();
  9770.         end_system_call();
  9771.       #endif
  9772.       #if defined(MSDOS) && defined(WINDOWS)
  9773.         { var int width;
  9774.           var int height;
  9775.           get_text_size(main_window,&width,&height);
  9776.           if (width > 0)
  9777.             { # Wert von SYS::*PRIN-LINELENGTH* verΣndern:
  9778.               Symbol_value(S(prin_linelength)) = fixnum(width-1);
  9779.         }   }
  9780.       #endif
  9781.       #if defined(MSDOS) && !defined(WINDOWS)
  9782.         # Die Breite des Bildschirms im aktuellen Bildschirm-Modus
  9783.         # jetzt beim Programmstart erfragen:
  9784.         if (isatty(stdout_handle)) # Standard-Output ein Terminal?
  9785.           { extern uintW v_cols(); # siehe STREAM.D
  9786.             #ifdef EMUNIX_PORTABEL
  9787.             var int scrsize[2];
  9788.             var reg1 uintL columns;
  9789.             #ifdef EMUNIX_OLD_8d
  9790.             if (_osmode == DOS_MODE)
  9791.               /* unter DOS */ { columns = v_cols(); }
  9792.               else
  9793.               /* unter OS/2 */
  9794.             #endif
  9795.             columns = (_scrsize(&!scrsize), scrsize[0]);
  9796.             #else
  9797.             var reg1 uintL columns = v_cols();
  9798.             #endif
  9799.             if (columns > 0)
  9800.               { # Wert von SYS::*PRIN-LINELENGTH* verΣndern:
  9801.                 Symbol_value(S(prin_linelength)) =
  9802.                   fixnum(columns-1);
  9803.           }   }
  9804.       #endif
  9805.       #if defined(AMIGAOS) && 0
  9806.         # frage beim console.driver nach??
  9807.         if (IsInteractive(Input_handle) && IsInteractive(Output_handle)) # ??
  9808.           { var reg1 uintL len;
  9809.             var uintB question[4] = { CSI, '0', ' ', 'q' };
  9810.             var uintB response[30+1];
  9811.             Write(Output_handle,question,4);
  9812.             len = Read(Input_handle,response,30);
  9813.             response[len] = `\0`; sscanf(&response[5],"%d;%d", &lines, &columns); # ??
  9814.           }
  9815.       #endif
  9816.       #if defined(HAVE_SIGNALS)
  9817.       #if defined(UNIX) || defined(EMUNIX) || defined(RISCOS)
  9818.         # Ctrl-C-Handler einsetzen:
  9819.         SIGNAL(SIGINT,&interrupt_handler);
  9820.         #ifdef PENDING_INTERRUPTS
  9821.         SIGNAL(SIGALRM,&alarm_handler);
  9822.         #endif
  9823.         #ifdef IMMUTABLE
  9824.         SIGNAL(SIGSEGV,&sigsegv_handler);
  9825.         #endif
  9826.         #ifdef GENERATIONAL_GC
  9827.         install_segv_handler();
  9828.         #endif
  9829.       #endif
  9830.       #if defined(SIGCLD)
  9831.         # Wir wollen es ignorieren, wenn ein von uns erzeugter Proze▀ endet:
  9832.         SIGNAL(SIGCLD,SIG_IGN);
  9833.         # (Das ist im wesentlichen Σquivalent zur Installation eines Signal-
  9834.         # Handlers, der ein  while (waitpid(-1,NULL,WNOHANG) > 0);  ausfⁿhrt.)
  9835.       #endif
  9836.       #endif
  9837.       # Zeitvariablen initialisieren:
  9838.       # Es ist noch keine GC dagewesen -> hat auch noch keine Zeit verbraucht.
  9839.       # gc_count=0;
  9840.       # gc_time=0;
  9841.       # gc_space=0;
  9842.       #ifdef TIME_RELATIVE
  9843.       realstart_time = get_time(); # ZeitzΣhler jetzt, beim Systemstart
  9844.       #endif
  9845.       #ifndef HAVE_RUN_TIME
  9846.       # run_time = 0; # Noch keine Run-Time verbraucht,
  9847.       # run_flag = FALSE; # denn System lΣuft noch nicht.
  9848.       run_time_restart(); # Run-Time-Stoppuhr loslaufen lassen
  9849.       #endif
  9850.       #ifdef TIME_UNIX
  9851.       realstart_time = *(get_real_time()); # ZeitzΣhler jetzt, beim Systemstart
  9852.       #endif
  9853.       #ifdef TIME_RELATIVE
  9854.       # Start-Zeit holen und merken:
  9855.       { var decoded_time timepoint;
  9856.         #ifdef ATARI
  9857.         { var reg1 uintW date;
  9858.           var reg2 uintW time;
  9859.           do { date = GEMDOS_GetDate(); # externes Datum holen
  9860.                time = GEMDOS_GetTime(); # externe Uhrzeit holen
  9861.              } # und wiederholen, falls sich das Datum zwischenzeitlich
  9862.                # geΣndert hat:
  9863.              until (date==GEMDOS_GetDate());
  9864.           convert_timedate(time,date,&timepoint); # in Decoded-Time umwandeln
  9865.         }
  9866.         # Sekunden-Wert (gerades Fixnum >=0, <60) um 1 erh÷hen,
  9867.         # verringert die Ungenauigkeit:
  9868.         timepoint.Sekunden = fixnum_inc(timepoint.Sekunden,1);
  9869.         #endif
  9870.         #ifdef AMIGAOS
  9871.         { var struct DateStamp datestamp; # aktuelle Uhrzeit
  9872.           DateStamp(&datestamp);
  9873.           convert_time(&datestamp,&timepoint); # in Decoded-Time umwandeln
  9874.         }
  9875.         #endif
  9876.         #if defined(DJUNIX) && 0 # das geht eine Stunde nach!!
  9877.         { var struct timeval real_time;
  9878.           gettimeofday(&real_time,NULL); # aktuelle Uhrzeit
  9879.           convert_time(&real_time.tv_sec,&timepoint); # in Decoded-Time umwandeln
  9880.         }
  9881.         #endif
  9882.         #if defined(DJUNIX) || defined(WATCOM) || defined(EMUNIX_OLD_8d) || defined(WINDOWS)
  9883.         { var internal_decoded_time idt;
  9884.           get_decoded_time(&idt);
  9885.           timepoint.Sekunden = fixnum(idt.sec);
  9886.           timepoint.Minuten  = fixnum(idt.min);
  9887.           timepoint.Stunden  = fixnum(idt.hour);
  9888.           timepoint.Tag      = fixnum(idt.day);
  9889.           timepoint.Monat    = fixnum(idt.month);
  9890.           timepoint.Jahr     = fixnum(idt.year);
  9891.         }
  9892.         #endif
  9893.         #if defined(EMUNIX_NEW_8e) && !defined(WINDOWS)
  9894.         { var struct timeb real_time;
  9895.           begin_system_call();
  9896.           __ftime(&real_time); # aktuelle Uhrzeit
  9897.           end_system_call();
  9898.           convert_time(&real_time.time,&timepoint); # in Decoded-Time umwandeln
  9899.         }
  9900.         #endif
  9901.         #if defined(UNIX) || defined(RISCOS) # TIME_UNIX_TIMES || TIME_RISCOS
  9902.         { var time_t real_time;
  9903.           begin_system_call();
  9904.           time(&real_time); # aktuelle Uhrzeit
  9905.           end_system_call();
  9906.           convert_time(&real_time,&timepoint); # in Decoded-Time umwandeln
  9907.         }
  9908.         #endif
  9909.         set_start_time(&timepoint); # Start-Zeit merken
  9910.       }
  9911.       #endif
  9912.       # Stream-Variablen initialisieren:
  9913.       init_streamvars();
  9914.       #ifdef ATARI
  9915.       # Keyboard-Input-Stream funktionsfΣhig machen:
  9916.       new_keyboard();
  9917.       #endif
  9918.       # Break erm÷glichen:
  9919.       end_system_call();
  9920.       clr_break_sem_1();
  9921.       # Pathnames initialisieren:
  9922.       init_pathnames();
  9923.       #ifdef REXX
  9924.       # Rexx-Interface initialisieren:
  9925.       init_rexx();
  9926.       # Auf eine Fehlermeldung im Falle des Scheiterns verzichten wir.
  9927.       # Deswegen wollen wir das CLISP doch nicht unbrauchbar machen!
  9928.       #endif
  9929.       # Begrⁿ▀ung ausgeben:
  9930.       if (!nullp(Symbol_value(S(quiet)))) # SYS::*QUIET* /= NIL ?
  9931.         { argv_quiet = TRUE; } # verhindert die Begrⁿ▀ung
  9932.       if (!argv_quiet)
  9933.         { local char* banner[] = { # einige Zeilen α 66 Zeichen
  9934.           #  |Spalte 0           |Spalte 20                                    |Spalte 66
  9935.             "  i i i i i i i       ooooo    o        ooooooo   ooooo   ooooo   " NLstring,
  9936.             "  I I I I I I I      8     8   8           8     8     o  8    8  " NLstring,
  9937.             "  I I I I I I I      8         8           8     8        8    8  " NLstring,
  9938.             "  I I I I I I I      8         8           8      ooooo   8oooo   " NLstring,
  9939.            "  I  \\ `+' /  I      8         8           8           8  8       " NLstring,
  9940.            "   \\  `-+-'  /       8     o   8           8     o     8  8       " NLstring,
  9941.             "    `-__|__-'         ooooo    8oooooo  ooo8ooo   ooooo   8       " NLstring,
  9942.             "        |                                                         " NLstring,
  9943.             "  ------+------     Copyright (c) Bruno Haible, Michael Stoll 1992, 1993" NLstring,
  9944.             "                    Copyright (c) Bruno Haible, Marcus Daniels 1994, 1995" NLstring,
  9945.             };
  9946.           #ifdef AMIGA
  9947.           var char* banner2 =
  9948.             DEUTSCH ?
  9949.             "                    Amiga-Version: J÷rg H÷hle                     " NLstring :
  9950.             ENGLISH ?
  9951.             "                    Amiga version: J÷rg H÷hle                     " NLstring :
  9952.             FRANCAIS ?
  9953.             "                    version Amiga: J÷rg H÷hle                     " NLstring :
  9954.             "";
  9955.           #endif
  9956.           #ifdef DJUNIX
  9957.           var char* banner2 =
  9958.             DEUTSCH ?
  9959.             "                    DOS-Portierung: Jⁿrgen Weber, Bruno Haible    " NLstring :
  9960.             ENGLISH ?
  9961.             "                    DOS port: Jⁿrgen Weber, Bruno Haible          " NLstring :
  9962.             FRANCAIS ?
  9963.             "                    adaptΘ α DOS par Jⁿrgen Weber et Bruno Haible " NLstring :
  9964.             "";
  9965.           #endif
  9966.           local char* banner3 =
  9967.             "                                                                  " NLstring ;
  9968.           var reg3 uintL offset = (posfixnum_to_L(Symbol_value(S(prin_linelength))) >= 73 ? 0 : 20);
  9969.           var reg1 char** ptr = &banner[0];
  9970.           var reg2 uintC count;
  9971.           pushSTACK(var_stream(S(standard_output))); # auf *STANDARD-OUTPUT*
  9972.           dotimesC(count,sizeof(banner)/sizeof(banner[0]),
  9973.             { write_sstring(&STACK_0,asciz_to_string(&(*ptr++)[offset])); }
  9974.             );
  9975.           #if defined(AMIGA) || defined(DJUNIX)
  9976.           write_sstring(&STACK_0,asciz_to_string(&banner2[offset]));
  9977.           #endif
  9978.           write_sstring(&STACK_0,asciz_to_string(&banner3[offset]));
  9979.           skipSTACK(1);
  9980.         }
  9981.       if (argv_compile || !(argv_expr == NULL))
  9982.         # '-c' oder '-x' angegeben -> LISP lΣuft im Batch-Modus:
  9983.         { # (setq *debug-io*
  9984.           #   (make-two-way-stream (make-string-input-stream "") *query-io*)
  9985.           # )
  9986.           funcall(L(make_concatenated_stream),0); # (MAKE-CONCATENATED-STREAM)
  9987.           pushSTACK(value1); # leerer Input-Stream
  9988.          {var reg1 object stream = var_stream(S(query_io));
  9989.           Symbol_value(S(debug_io)) = make_twoway_stream(popSTACK(),stream);
  9990.         }}
  9991.       # fⁿr jedes initfile (LOAD initfile) ausfⁿhren:
  9992.       { var reg1 char** fileptr = &argv_init_files[0];
  9993.         var reg2 uintL count;
  9994.         dotimesL(count,argv_init_filecount,
  9995.           { var reg3 object filename = asciz_to_string(*fileptr++);
  9996.             pushSTACK(filename); funcall(S(load),1);
  9997.           });
  9998.       }
  9999.       if (argv_compile)
  10000.         # fⁿr jedes File
  10001.         #   (COMPILE-FILE (setq file (MERGE-PATHNAMES file (MERGE-PATHNAMES '#".lsp" (CD))))
  10002.         #                 [:OUTPUT-FILE (setq output-file (MERGE-PATHNAMES output-file (MERGE-PATHNAMES '#".fas file)))]
  10003.         #                 [:LISTING (MERGE-PATHNAMES '#".lis" (or output-file file))]
  10004.         #   )
  10005.         # durchfⁿhren:
  10006.         { var reg1 argv_compile_file* fileptr = &argv_compile_files[0];
  10007.           var reg4 uintL count;
  10008.           dotimesL(count,argv_compile_filecount,
  10009.             { var reg2 uintC argcount = 1;
  10010.               var reg3 object filename = asciz_to_string(fileptr->input_file);
  10011.               pushSTACK(filename);
  10012.               pushSTACK(O(source_file_type)); # #".lsp"
  10013.               funcall(L(cd),0); pushSTACK(value1); # (CD)
  10014.               funcall(L(merge_pathnames),2); # (MERGE-PATHNAMES '#".lsp" (CD))
  10015.               pushSTACK(value1);
  10016.               funcall(L(merge_pathnames),2); # (MERGE-PATHNAMES file ...)
  10017.               pushSTACK(value1);
  10018.               if (fileptr->output_file)
  10019.                 { filename = asciz_to_string(fileptr->output_file);
  10020.                   pushSTACK(S(Koutput_file));
  10021.                   pushSTACK(filename);
  10022.                   pushSTACK(O(compiled_file_type)); # #".fas"
  10023.                   pushSTACK(STACK_3); # file
  10024.                   funcall(L(merge_pathnames),2); # (MERGE-PATHNAMES '#".fas" file)
  10025.                   pushSTACK(value1);
  10026.                   funcall(L(merge_pathnames),2); # (MERGE-PATHNAMES output-file ...)
  10027.                   pushSTACK(value1);
  10028.                   argcount += 2;
  10029.                 }
  10030.               if (argv_compile_listing)
  10031.                 { pushSTACK(S(Klisting));
  10032.                   pushSTACK(O(listing_file_type)); # #".lis"
  10033.                   pushSTACK(STACK_2); # (or output-file file)
  10034.                   funcall(L(merge_pathnames),2); # (MERGE-PATHNAMES '#".lis" ...)
  10035.                   pushSTACK(value1);
  10036.                   argcount += 2;
  10037.                 }
  10038.               funcall(S(compile_file),argcount);
  10039.               fileptr++;
  10040.             });
  10041.           quit();
  10042.         }
  10043.       if (!(argv_expr == NULL))
  10044.         # *STANDARD-INPUT* auf einen Stream setzen, der argv_expr produziert:
  10045.         { pushSTACK(asciz_to_string(argv_expr));
  10046.           funcall(L(make_string_input_stream),1);
  10047.           Symbol_value(S(standard_input)) = value1;
  10048.           # Dann den Driver aufrufen. Stringende -> EOF -> Programmende.
  10049.         }
  10050.       # Read-Eval-Print-Schleife aufrufen:
  10051.       driver();
  10052.       quit();
  10053.       /*NOTREACHED*/
  10054.       # Falls der Speicher nicht ausreichte:
  10055.       no_mem:
  10056.       asciz_out(program_name); asciz_out(": ");
  10057.       asciz_out(
  10058.         DEUTSCH ? "Nicht genug Speicher fⁿr LISP" CRLFstring :
  10059.         ENGLISH ? "Not enough memory for Lisp." CRLFstring :
  10060.         FRANCAIS ? "Il n'y a pas assez de mΘmoire pour LISP." CRLFstring :
  10061.         ""
  10062.         );
  10063.       #ifdef ATARI
  10064.       GEMDOS_ConIn(); # auf Tastendruck warten, bevor der Bildschirm gel÷scht wird
  10065.       #endif
  10066.       quit_sofort(1);
  10067.       /*NOTREACHED*/
  10068.      # Beendigung des Programms durch quit_sofort():
  10069.       end_of_main:
  10070.       #ifdef MULTIMAP_MEMORY
  10071.       exitmap();
  10072.       #endif
  10073.       FREE_DYNAMIC_ARRAY(argv_compile_files); }
  10074.       FREE_DYNAMIC_ARRAY(argv_init_files); }
  10075.       #ifdef GRAPHICS_SWITCH
  10076.       switch_text_mode(); # Rⁿckkehr zum normalen Text-Modus
  10077.       #endif
  10078.       #if defined(UNIX) || defined(AMIGAOS) || defined(RISCOS)
  10079.       terminal_sane(); # Terminal wieder in Normalzustand schalten
  10080.       #endif
  10081.       #ifdef DJUNIX
  10082.       if (cbrk) { setcbrk(cbrk); } # Ctrl-Break wieder zulassen
  10083.       _go32_want_ctrl_break(0); # Ctrl-Break wieder normal
  10084.       #endif
  10085.       #if defined(UNIX) || (defined(MSDOS) && !defined(WINDOWS)) || defined(RISCOS)
  10086.         _exit(exitcode);
  10087.       #endif
  10088.       #ifdef ATARI
  10089.         GEMDOS_exit();
  10090.       #endif
  10091.       #ifdef AMIGAOS
  10092.         exit_amiga(exitcode ? RETURN_FAIL : RETURN_OK);
  10093.       #endif
  10094.       # Wenn das nichts geholfen haben sollte:
  10095.       return exitcode;
  10096.     }}
  10097.  
  10098. # LISP-Interpreter verlassen
  10099. # > final_exitcode: 0 bei normalem Ende, 1 bei Abbruch
  10100.   nonreturning_function(global, quit, (void));
  10101.   global boolean final_exitcode = 0;
  10102.   global void quit()
  10103.     { # Erst den STACK bis STACK-Ende "unwinden":
  10104.       value1 = NIL; mv_count=0; # Bei UNWIND-PROTECT-Frames keine Werte retten
  10105.       unwind_protect_to_save.fun = (restart)&quit;
  10106.       loop
  10107.         { # H÷rt der STACK hier auf?
  10108.           if (eq(STACK_0,nullobj) && eq(STACK_1,nullobj)) break;
  10109.           if (mtypecode(STACK_0) & bit(frame_bit_t))
  10110.             # Bei STACK_0 beginnt ein Frame
  10111.             { unwind(); } # Frame aufl÷sen
  10112.             else
  10113.             # STACK_0 enthΣlt ein normales LISP-Objekt
  10114.             { skipSTACK(1); }
  10115.         }
  10116.       # Dann eine Abschiedsmeldung:
  10117.       { funcall(L(fresh_line),0); # (FRESH-LINE [*standard-output*])
  10118.         if (!argv_quiet)
  10119.           { # (WRITE-LINE "Bye." [*standard-output*]) :
  10120.             pushSTACK(OL(bye_string)); funcall(L(write_line),1);
  10121.       }   }
  10122.       close_all_files(); # alle Files schlie▀en
  10123.       #ifdef REXX
  10124.       close_rexx(); # Rexx-Kommunikation herunterfahren
  10125.       #endif
  10126.       #ifdef ATARI
  10127.       old_keyboard(); # Tastaturabfrage wieder in Urzustand bringen
  10128.       BIOS_SetException(28,old_VBL); # alten Exception-Vektor zurⁿckschreiben
  10129.       LineA_MouseUnhide(); # Maus wieder in Urzustand bringen
  10130.       #endif
  10131.       quit_sofort(final_exitcode); # Programm verlassen
  10132.     }
  10133.  
  10134. # ------------------------------------------------------------------------------
  10135. #                  Speichern und Laden von MEM-Files
  10136.  
  10137. #if defined(UNIX) || defined(DJUNIX) || defined(EMUNIX) || defined(WATCOM) || defined(RISCOS)
  10138.   # Betriebssystem-Funktion read sichtbar machen:
  10139.     #undef read
  10140. #endif
  10141.  
  10142. # Format:
  10143. # ein Header:
  10144.   typedef struct { uintL _magic; # Erkennung
  10145.                      #define memdump_magic  0x70768BD2UL
  10146.                    oint _oint_type_mask;
  10147.                    oint _oint_addr_mask;
  10148.                    tint _cons_type, _complex_type, _symbol_type, _system_type;
  10149.                    uintC _varobject_alignment;
  10150.                    uintC _hashtable_length;
  10151.                    uintC _module_count;
  10152.                    uintL _module_names_size;
  10153.                    uintC _fsubr_anz;
  10154.                    uintC _pseudofun_anz;
  10155.                    uintC _symbol_anz;
  10156.                    uintL _page_alignment;
  10157.                    aint _subr_tab_addr;
  10158.                    aint _symbol_tab_addr;
  10159.                    #ifdef SPVW_MIXED_BLOCKS_OPPOSITE
  10160.                    aint _mem_objects_start;
  10161.                    aint _mem_objects_end;
  10162.                    aint _mem_conses_start;
  10163.                    aint _mem_conses_end;
  10164.                    #endif
  10165.                    #ifndef SPVW_MIXED_BLOCKS_OPPOSITE
  10166.                    uintC _heapcount;
  10167.                    #endif
  10168.                  }
  10169.           memdump_header;
  10170.   # dann die Modulnamen,
  10171.   # dann fsubr_tab, pseudofun_tab, symbol_tab,
  10172.   # und zu jedem Modul subr_addr, subr_anz, object_anz, subr_tab, object_tab,
  10173. #ifdef SPVW_MIXED_BLOCKS_OPPOSITE
  10174.   # dann die Objekte variabler LΣnge (zwischen mem.objects.start und mem.objects.end),
  10175.   # dann die Conses (zwischen mem.conses.start und mem.conses.end).
  10176. #else
  10177.   #if defined(SPVW_PURE_BLOCKS) || defined(TRIVIALMAP_MEMORY)
  10178.     # dann zu jedem Heap (Block) die Start- und Endadresse,
  10179.   #endif
  10180.   #ifdef SPVW_PAGES
  10181.     # SPVW_PAGES: dann zu jedem Heap die Anzahl der Pages,
  10182.     # dann zu jedem Heap und zu jeder Page des Heaps die Start- und Endadresse,
  10183.   #endif
  10184.   typedef struct { aint _page_start; aint _page_end; } memdump_page;
  10185.   # dann der Inhalt der Pages in derselben Reihenfolge.
  10186. #endif
  10187.  
  10188. # page_alignment = Alignment fⁿr die Page-Inhalte im File.
  10189. #if ((defined(SPVW_PURE_BLOCKS) && defined(SINGLEMAP_MEMORY)) || defined(TRIVIALMAP_MEMORY)) && defined(HAVE_MMAP)
  10190.   #define page_alignment  map_pagesize
  10191.   #define WRITE_page_alignment(position)  \
  10192.     { var reg4 uintL aligncount = (uintL)(-position) % page_alignment; \
  10193.       if (aligncount > 0)                                              \
  10194.         { # Ein Stⁿck durchgenullten Speicher besorgen:                \
  10195.           var DYNAMIC_ARRAY(reg5,zeroes,uintB,aligncount);             \
  10196.           var reg1 uintB* ptr = &zeroes[0];                            \
  10197.           var reg2 uintL count;                                        \
  10198.           dotimespL(count,aligncount, { *ptr++ = 0; } );               \
  10199.           # und schreiben:                                             \
  10200.           WRITE(&zeroes[0],aligncount);                                \
  10201.           FREE_DYNAMIC_ARRAY(zeroes);                                  \
  10202.     }   }
  10203.   #define READ_page_alignment(position)  \
  10204.     { var reg4 uintL aligncount = (uintL)(-position) % page_alignment; \
  10205.       if (aligncount > 0)                                              \
  10206.         { var DYNAMIC_ARRAY(reg5,dummy,uintB,aligncount);              \
  10207.           READ(&dummy[0],aligncount);                                  \
  10208.           FREE_DYNAMIC_ARRAY(dummy);                                   \
  10209.     }   }
  10210. #else
  10211.   #define page_alignment  1
  10212.   #define WRITE_page_alignment(position)
  10213.   #define READ_page_alignment(position)
  10214. #endif
  10215.  
  10216. # UP, speichert Speicherabbild auf Diskette
  10217. # savemem(stream);
  10218. # > object stream: offener File-Output-Stream, wird geschlossen
  10219. # kann GC ausl÷sen
  10220.   global void savemem (object stream);
  10221.   global void savemem(stream)
  10222.     var reg4 object stream;
  10223.     { # Wir brauchen den Stream nur wegen des fⁿr ihn bereitgestellten Handles.
  10224.       # Wir mⁿssen ihn aber im Fehlerfalle schlie▀en (der Aufrufer macht kein
  10225.       # WITH-OPEN-FILE, sondern nur OPEN). Daher bekommen wir den ganzen
  10226.       # Stream ⁿbergeben, um ihn schlie▀en zu k÷nnen.
  10227.       var reg3 Handle handle = TheHandle(TheStream(stream)->strm_file_handle);
  10228.       pushSTACK(stream); # Stream retten
  10229.       # Erst eine GC ausfⁿhren:
  10230.       gar_col();
  10231.       #ifdef ATARI
  10232.         #define WRITE(buf,len)  \
  10233.           { begin_system_call();                                        \
  10234.            {var reg1 sintL ergebnis = GEMDOS_write(handle,len,buf);     \
  10235.             if (!(ergebnis==(len)))                                     \
  10236.               { stream_close(&STACK_0);                                 \
  10237.                 if (ergebnis<0) { OS_error(ergebnis); } # Fehler aufgetreten? \
  10238.                 pushSTACK(TheStream(STACK_0)->strm_file_truename); # Wert fⁿr Slot PATHNAME von FILE-ERROR \
  10239.                 fehler(file_error,                                      \
  10240.                        DEUTSCH ? "Diskette/Platte voll." :              \
  10241.                        ENGLISH ? "disk full" :                          \
  10242.                        FRANCAIS ? "Disque plein." :                     \
  10243.                        ""                                               \
  10244.                       );                                                \
  10245.               }                                                         \
  10246.             end_system_call();                                          \
  10247.           }}
  10248.       #endif
  10249.       #ifdef AMIGAOS
  10250.         #define WRITE(buf,len)  \
  10251.           { begin_system_call();                                      \
  10252.            {var reg1 sintL ergebnis = Write(handle,(void*)buf,len);   \
  10253.             if (!(ergebnis==(len)))                                   \
  10254.               { stream_close(&STACK_0);                               \
  10255.                 if (ergebnis<0) { OS_error(); } # Fehler aufgetreten? \
  10256.                 pushSTACK(TheStream(STACK_0)->strm_file_truename); # Wert fⁿr Slot PATHNAME von FILE-ERROR \
  10257.                 fehler(file_error,                                    \
  10258.                        DEUTSCH ? "DatentrΣger vermutlich voll." :     \
  10259.                        ENGLISH ? "device possibly full" :             \
  10260.                        FRANCAIS ? "Disque peut-Ωtre plein." :         \
  10261.                        ""                                             \
  10262.                       );                                              \
  10263.               }                                                       \
  10264.             end_system_call();                                        \
  10265.           }}
  10266.       #endif
  10267.       #if defined(UNIX) || defined(DJUNIX) || defined(EMUNIX) || defined(WATCOM) || defined(RISCOS)
  10268.         #define WRITE(buf,len)  \
  10269.           { begin_system_call();                                            \
  10270.            {var reg1 sintL ergebnis = full_write(handle,(RW_BUF_T)buf,len); \
  10271.             if (!(ergebnis==(len)))                                         \
  10272.               { stream_close(&STACK_0);                                     \
  10273.                 if (ergebnis<0) { OS_error(); } # Fehler aufgetreten?       \
  10274.                 pushSTACK(TheStream(STACK_0)->strm_file_truename); # Wert fⁿr Slot PATHNAME von FILE-ERROR \
  10275.                 fehler(file_error,                                          \
  10276.                        DEUTSCH ? "Diskette/Platte voll." :                  \
  10277.                        ENGLISH ? "disk full" :                              \
  10278.                        FRANCAIS ? "Disque plein." :                         \
  10279.                        ""                                                   \
  10280.                       );                                                    \
  10281.               }                                                             \
  10282.             end_system_call();                                              \
  10283.           }}
  10284.       #endif
  10285.       # Grundinformation rausschreiben:
  10286.      {var memdump_header header;
  10287.       var reg7 uintL module_names_size;
  10288.       header._magic = memdump_magic;
  10289.       header._oint_type_mask = oint_type_mask;
  10290.       header._oint_addr_mask = oint_addr_mask;
  10291.       header._cons_type    = cons_type;
  10292.       header._complex_type = complex_type;
  10293.       header._symbol_type  = symbol_type;
  10294.       header._system_type  = system_type;
  10295.       header._varobject_alignment = Varobject_alignment;
  10296.       header._hashtable_length = hashtable_length;
  10297.       header._module_count = module_count;
  10298.       { var reg1 module_* module;
  10299.         module_names_size = 0;
  10300.         for_modules(all_modules,
  10301.           { module_names_size += asciz_length(module->name)+1; }
  10302.           );
  10303.         module_names_size = round_up(module_names_size,Varobject_alignment);
  10304.       }
  10305.       header._module_names_size = module_names_size;
  10306.       header._fsubr_anz     = fsubr_anz;
  10307.       header._pseudofun_anz = pseudofun_anz;
  10308.       header._symbol_anz    = symbol_anz;
  10309.       header._page_alignment = page_alignment;
  10310.       header._subr_tab_addr   = (aint)(&subr_tab);
  10311.       header._symbol_tab_addr = (aint)(&symbol_tab);
  10312.       #ifdef SPVW_MIXED_BLOCKS_OPPOSITE
  10313.       header._mem_objects_start = mem.objects.start;
  10314.       header._mem_objects_end   = mem.objects.end;
  10315.       header._mem_conses_start  = mem.conses.start;
  10316.       header._mem_conses_end    = mem.conses.end;
  10317.       #endif
  10318.       #ifndef SPVW_MIXED_BLOCKS_OPPOSITE
  10319.       header._heapcount = heapcount;
  10320.       #endif
  10321.       WRITE(&header,sizeof(header));
  10322.       # Modulnamen rausschreiben:
  10323.       { var DYNAMIC_ARRAY(,module_names_buffer,char,module_names_size);
  10324.        {var reg2 char* ptr2 = &module_names_buffer[0];
  10325.         var reg3 module_* module;
  10326.         var reg4 uintC count;
  10327.         for_modules(all_modules,
  10328.           { var reg1 char* ptr1 = module->name;
  10329.             until ((*ptr2++ = *ptr1++) == '\0') ;
  10330.           });
  10331.         dotimesC(count,&module_names_buffer[module_names_size] - ptr2,
  10332.           { *ptr2++ = 0; }
  10333.           );
  10334.         WRITE(module_names_buffer,module_names_size);
  10335.         FREE_DYNAMIC_ARRAY(module_names_buffer);
  10336.       }}
  10337.       # fsubr_tab, pseudofun_tab, symbol_tab rausschreiben:
  10338.       WRITE(&fsubr_tab,sizeof(fsubr_tab));
  10339.       WRITE(&pseudofun_tab,sizeof(pseudofun_tab));
  10340.       WRITE(&symbol_tab,sizeof(symbol_tab));
  10341.       # Zu jedem Modul subr_addr, subr_anz, object_anz, subr_tab, object_tab rausschreiben:
  10342.       { var reg2 module_* module;
  10343.         for_modules(all_modules,
  10344.           { WRITE(&module->stab,sizeof(subr_*));
  10345.             WRITE(module->stab_size,sizeof(uintC));
  10346.             WRITE(module->otab_size,sizeof(uintC));
  10347.             WRITE(module->stab,*module->stab_size*sizeof(subr_));
  10348.             WRITE(module->otab,*module->otab_size*sizeof(object));
  10349.           });
  10350.       }
  10351.       #ifdef SPVW_MIXED_BLOCKS_OPPOSITE
  10352.       # Objekte variabler LΣnge rausschreiben:
  10353.       {var reg2 uintL len = header._mem_objects_end - header._mem_objects_start;
  10354.        WRITE(header._mem_objects_start,len);
  10355.       }
  10356.       # Conses rausschreiben:
  10357.       {var reg2 uintL len = header._mem_conses_end - header._mem_conses_start;
  10358.        WRITE(header._mem_conses_start,len);
  10359.       }
  10360.       #endif
  10361.       #ifndef SPVW_MIXED_BLOCKS_OPPOSITE
  10362.       #ifdef SPVW_PAGES
  10363.       {var reg6 uintL heapnr;
  10364.        for (heapnr=0; heapnr<heapcount; heapnr++)
  10365.          { var uintC pagecount = 0;
  10366.            map_heap(mem.heaps[heapnr],page, { pagecount++; } );
  10367.            WRITE(&pagecount,sizeof(pagecount));
  10368.       }  }
  10369.       #endif
  10370.       {var reg6 uintL heapnr;
  10371.        for (heapnr=0; heapnr<heapcount; heapnr++)
  10372.          {
  10373.            #if !defined(GENERATIONAL_GC)
  10374.            map_heap(mem.heaps[heapnr],page,
  10375.              { var memdump_page _page;
  10376.                _page._page_start = page->page_start;
  10377.                _page._page_end = page->page_end;
  10378.                WRITE(&_page,sizeof(_page));
  10379.              });
  10380.            #else # defined(GENERATIONAL_GC)
  10381.            var reg4 Heap* heap = &mem.heaps[heapnr];
  10382.            var memdump_page _page;
  10383.            _page._page_start = heap->heap_gen0_start;
  10384.            _page._page_end = heap->heap_gen0_end;
  10385.            WRITE(&_page,sizeof(_page));
  10386.            #endif
  10387.       }  }
  10388.       #if (defined(SPVW_PURE_BLOCKS) && defined(SINGLEMAP_MEMORY)) || defined(TRIVIALMAP_MEMORY)
  10389.        #if defined(HAVE_MMAP) # sonst ist page_alignment sowieso = 1
  10390.         # Alignment verwirklichen:
  10391.         { begin_system_call();
  10392.          {var reg1 sintL ergebnis = lseek(handle,0,SEEK_CUR); # File-Position holen
  10393.           end_system_call();
  10394.           if (ergebnis<0) { stream_close(&STACK_0); OS_error(); } # Fehler?
  10395.           WRITE_page_alignment(ergebnis);
  10396.         }}
  10397.        #endif
  10398.       #endif
  10399.       {var reg6 uintL heapnr;
  10400.        for (heapnr=0; heapnr<heapcount; heapnr++)
  10401.          {
  10402.            #if !defined(GENERATIONAL_GC)
  10403.            map_heap(mem.heaps[heapnr],page,
  10404.              { var reg2 uintL len = page->page_end - page->page_start;
  10405.                WRITE(page->page_start,len);
  10406.                WRITE_page_alignment(len);
  10407.              });
  10408.            #else # defined(GENERATIONAL_GC)
  10409.            var reg4 Heap* heap = &mem.heaps[heapnr];
  10410.            var reg2 uintL len = heap->heap_gen0_end - heap->heap_gen0_start;
  10411.            WRITE(heap->heap_gen0_start,len);
  10412.            WRITE_page_alignment(len);
  10413.            #endif
  10414.       }  }
  10415.       #endif
  10416.       #undef WRITE
  10417.       # Stream schlie▀en (Stream-Buffer ist unverΣndert, aber dadurch wird
  10418.       # auch das Handle beim Betriebssystem geschlossen):
  10419.       stream_close(&STACK_0);
  10420.       skipSTACK(1);
  10421.     }}
  10422.  
  10423. # UP, lΣdt Speicherabbild von Diskette
  10424. # loadmem(filename);
  10425. # Zerst÷rt alle LISP-Daten.
  10426.   #ifdef UNIX
  10427.   local void loadmem_from_handle (int handle);
  10428.   #endif
  10429.   # Aktualisierung eines Objektes im Speicher:
  10430.   #ifdef SPVW_MIXED_BLOCKS_OPPOSITE
  10431.   local var oint offset_objects_o;
  10432.   local var oint offset_conses_o;
  10433.   #endif
  10434.   #ifdef TRIVIALMAP_MEMORY
  10435.   local var oint offset_heaps_o[heapcount];
  10436.   #define offset_objects_o  offset_heaps_o[0]
  10437.   #define offset_conses_o   offset_heaps_o[1]
  10438.   #endif
  10439.   #ifdef SPVW_PAGES
  10440.   local var struct { aint old_page_start; oint offset_page_o; } *offset_pages;
  10441.   #define addr_mask  ~(((oint_addr_mask>>oint_addr_shift) & ~ (wbit(oint_addr_relevant_len)-1)) << addr_shift) # meist = ~0
  10442.   #define pagenr_of(addr)  floor(addr,min_page_size_brutto)
  10443.   #define offset_pages_len  (pagenr_of((wbit(oint_addr_relevant_len)-1)<<addr_shift)+1)
  10444.   #endif
  10445.   #if !defined(SINGLEMAP_MEMORY)
  10446.   local var oint offset_symbols_o;
  10447.   #if !defined(MULTIMAP_MEMORY)
  10448.   local var oint old_symbol_tab_o;
  10449.   #endif
  10450.   #endif
  10451.   typedef struct { oint low_o; oint high_o; oint offset_o; } offset_subrs_t;
  10452.   local var offset_subrs_t* offset_subrs;
  10453.   local var uintC offset_subrs_anz;
  10454.   local var struct fsubr_tab_ old_fsubr_tab;
  10455.   local var struct pseudofun_tab_ old_pseudofun_tab;
  10456.   local void loadmem_aktualisiere (object* objptr);
  10457.   local void loadmem_aktualisiere(objptr)
  10458.     var reg3 object* objptr;
  10459.     { switch (mtypecode(*objptr))
  10460.         { case_symbol: # Symbol
  10461.             #ifndef SPVW_PURE_BLOCKS
  10462.             #if !defined(MULTIMAP_MEMORY)
  10463.             if (as_oint(*objptr) - old_symbol_tab_o
  10464.                 < ((oint)sizeof(symbol_tab)<<(oint_addr_shift-addr_shift))
  10465.                )
  10466.               # Symbol aus symbol_tab
  10467.               { *(oint*)objptr += offset_symbols_o; break; }
  10468.             #else
  10469.             if (as_oint(*objptr) - (oint)(&symbol_tab)
  10470.                 < (sizeof(symbol_tab)<<(oint_addr_shift-addr_shift))
  10471.                )
  10472.               # Symbol aus symbol_tab erfΣhrt keine Verschiebung
  10473.               { break; }
  10474.             #endif
  10475.             # sonstige Symbole sind Objekte variabler LΣnge.
  10476.             #endif
  10477.           case_array:
  10478.           case_record:
  10479.           case_bignum:
  10480.           #ifndef WIDE
  10481.           case_ffloat:
  10482.           #endif
  10483.           case_dfloat:
  10484.           case_lfloat:
  10485.             # Objekt variabler LΣnge
  10486.             #ifdef SPVW_MIXED_BLOCKS
  10487.             *(oint*)objptr += offset_objects_o; break;
  10488.             #endif
  10489.           case_cons: case_ratio: case_complex:
  10490.             # Zwei-Pointer-Objekt
  10491.             #ifdef SPVW_MIXED_BLOCKS
  10492.             *(oint*)objptr += offset_conses_o; break;
  10493.             #endif
  10494.             #ifdef SPVW_PAGES
  10495.             {var reg2 aint addr = upointer(*(object*)objptr); # Adresse
  10496.              # Da Pages eine minimale LΣnge haben, also die Anfangsadressen
  10497.              # unterschiedlicher Pages sich um mindestens min_page_size_brutto
  10498.              # unterscheiden, ist es ganz einfach, aus der Adresse auf die
  10499.              # Page zurⁿckzuschlie▀en:
  10500.              var reg1 uintL pagenr = pagenr_of(addr & addr_mask);
  10501.              if (addr < offset_pages[pagenr].old_page_start) { pagenr--; }
  10502.              *(oint*)objptr += offset_pages[pagenr].offset_page_o;
  10503.             }
  10504.             break;
  10505.             #endif
  10506.             #ifdef SPVW_PURE_BLOCKS # SINGLEMAP_MEMORY
  10507.             break; # Alles Bisherige erfΣhrt keine Verschiebung
  10508.             #endif
  10509.           case_subr: # SUBR
  10510.             {var reg2 oint addr = *(oint*)objptr;
  10511.              var reg3 offset_subrs_t* ptr = offset_subrs;
  10512.              var reg4 uintC count;
  10513.              dotimespC(count,offset_subrs_anz,
  10514.                { if ((ptr->low_o <= addr) && (addr < ptr->high_o))
  10515.                    { *(oint*)objptr += ptr->offset_o; goto found_subr; }
  10516.                  ptr++;
  10517.                });
  10518.             }
  10519.             # SUBR nicht gefunden -> #<UNBOUND>
  10520.             *objptr = unbound;
  10521.             found_subr:
  10522.             break;
  10523.           case_system: # Frame-Pointer oder Read-Label oder System-Konstante
  10524.             if ((*(oint*)objptr & wbit(0+oint_addr_shift)) ==0)
  10525.               # Frame-Pointer -> #<DISABLED>
  10526.               { *objptr = disabled; }
  10527.             break;
  10528.           case_machine: # Pseudo-Funktion/Fsubr-Funktion oder sonstiger Maschinenpointer
  10529.             # Umsetzung old_fsubr_tab -> fsubr_tab, old_pseudofun_tab -> pseudofun_tab :
  10530.             {
  10531.               #if (machine_type==0)
  10532.               var reg4 void* addr = (void*)ThePseudofun(*objptr);
  10533.               #else # mu▀ zum Vergleichen die Typinfo wegnehmen
  10534.               var reg4 void* addr = (void*)upointer(*objptr);
  10535.               #endif
  10536.               { var reg2 uintC i = fsubr_anz;
  10537.                 var reg1 fsubr_* ptr = &((fsubr_*)(&old_fsubr_tab))[fsubr_anz];
  10538.                 until (i==0)
  10539.                   { i--;
  10540.                     if ((void*) *--ptr == addr)
  10541.                       { # Fsubr-Funktion
  10542.                         *objptr = type_pointer_object(machine_type,((fsubr_*)(&fsubr_tab))[i]);
  10543.                         break;
  10544.               }   }   }
  10545.               { var reg2 uintC i = pseudofun_anz;
  10546.                 var reg1 Pseudofun* ptr = &((Pseudofun*)(&old_pseudofun_tab))[pseudofun_anz];
  10547.                 until (i==0)
  10548.                   { i--;
  10549.                     if ((void*) *--ptr == addr)
  10550.                       { # Pseudo-Funktion
  10551.                         *objptr = type_pointer_object(machine_type,((Pseudofun*)(&pseudofun_tab))[i]);
  10552.                         break;
  10553.               }   }   }
  10554.               # sonstiger Maschinenpointer
  10555.               break;
  10556.             }
  10557.           case_char:
  10558.           case_fixnum:
  10559.           case_sfloat:
  10560.           #ifdef WIDE
  10561.           case_ffloat:
  10562.           #endif
  10563.             break;
  10564.           default: /*NOTREACHED*/ abort();
  10565.     }   }
  10566.   local void loadmem(filename)
  10567.     char* filename;
  10568.     { # File zum Lesen ÷ffnen:
  10569.       begin_system_call();
  10570.      {
  10571.       #ifdef ATARI
  10572.       var reg4 WORD handle = GEMDOS_open(filename,0);
  10573.       if (handle<0)
  10574.         { if (!(handle==GEMDOS_open_NotFound)) goto abbruch1;
  10575.           # sanftere Behandlung des Fehlers, da▀ das lispinit.mem nicht da ist:
  10576.           end_system_call();
  10577.           asciz_out(DEUTSCH ? "** WARNUNG: ** Initialisierungsfile " :
  10578.                     ENGLISH ? "** WARNING: ** initialization file " :
  10579.                     FRANCAIS ? "** AVERTISSEMENT : ** Le fichier d'initialisation " :
  10580.                     ""
  10581.                    );
  10582.           asciz_out(filename);
  10583.           asciz_out(DEUTSCH ? " nicht gefunden." CRLFstring :
  10584.                     ENGLISH ? " not found" CRLFstring :
  10585.                     FRANCAIS ? " n'a pas ΘtΘ trouvΘ." CRLFstring :
  10586.                     ""
  10587.                    );
  10588.           initmem();
  10589.           return;
  10590.         }
  10591.       #endif
  10592.       #ifdef AMIGAOS
  10593.       var reg4 Handle handle = Open(filename,MODE_OLDFILE);
  10594.       if (handle==Handle_NULL) goto abbruch1;
  10595.       #endif
  10596.       #if defined(DJUNIX) || defined(EMUNIX) || defined(WATCOM)
  10597.       var reg4 int handle = open(filename,O_RDONLY);
  10598.       if (handle<0) goto abbruch1;
  10599.       setmode(handle,O_BINARY);
  10600.       #endif
  10601.       #if defined(UNIX) || defined(RISCOS)
  10602.       var reg4 int handle = OPEN(filename,O_RDONLY,my_open_mask);
  10603.       if (handle<0) goto abbruch1;
  10604.       #endif
  10605.       end_system_call();
  10606.   #ifdef UNIX
  10607.       loadmem_from_handle(handle);
  10608.       return;
  10609.       abbruch1:
  10610.         {var reg3 int abbruch_errno = errno;
  10611.          asciz_out(program_name); asciz_out(": ");
  10612.          asciz_out(
  10613.            DEUTSCH ? "Betriebssystem-Fehler beim Versuch, das Initialisierungsfile `" :
  10614.            ENGLISH ? "operating system error during load of initialisation file `" :
  10615.            FRANCAIS ? "Erreur systΦme pendant le chargement du fichier d'initialisation `" :
  10616.            ""
  10617.            );
  10618.          asciz_out(filename);
  10619.          asciz_out(
  10620.            DEUTSCH ? "' zu laden." CRLFstring :
  10621.            ENGLISH ? "'" CRLFstring :
  10622.            FRANCAIS ? "'." CRLFstring :
  10623.            ""
  10624.            );
  10625.          errno_out(abbruch_errno);
  10626.         }
  10627.         goto abbruch_quit;
  10628.       abbruch_quit:
  10629.         # Abbruch.
  10630.         quit_sofort(1);
  10631.     }}
  10632.   local void loadmem_from_handle(handle)
  10633.     var reg4 int handle;
  10634.     {{
  10635.   #endif
  10636.       {
  10637.        #if (defined(SPVW_PURE_BLOCKS) && defined(SINGLEMAP_MEMORY)) || defined(TRIVIALMAP_MEMORY)
  10638.          #if defined(HAVE_MMAP)
  10639.          local var boolean use_mmap = TRUE;
  10640.          #endif
  10641.          var reg9 uintL file_offset;
  10642.          #define set_file_offset(x)  file_offset = (x)
  10643.          #define inc_file_offset(x)  file_offset += (uintL)(x)
  10644.        #else
  10645.          #define set_file_offset(x)
  10646.          #define inc_file_offset(x)
  10647.        #endif
  10648.        #ifdef ATARI
  10649.          #define READ(buf,len)  \
  10650.            { begin_system_call();                                   \
  10651.             {var reg1 sintL ergebnis = GEMDOS_read(handle,len,buf); \
  10652.              end_system_call();                                     \
  10653.              if (ergebnis<0) goto abbruch1;                         \
  10654.              if (!(ergebnis==(len))) goto abbruch2;                 \
  10655.            }}
  10656.        #endif
  10657.        #ifdef AMIGAOS
  10658.          #define READ(buf,len)  \
  10659.            { begin_system_call();                                   \
  10660.             {var reg1 sintL ergebnis = Read(handle,(void*)buf,len); \
  10661.              end_system_call();                                     \
  10662.              if (ergebnis<0) goto abbruch1;                         \
  10663.              if (!(ergebnis==(len))) goto abbruch2;                 \
  10664.            }}
  10665.        #endif
  10666.        #if defined(UNIX) || defined(DJUNIX) || defined(EMUNIX) || defined(WATCOM) || defined(RISCOS)
  10667.          #define READ(buf,len)  \
  10668.            { begin_system_call();                                           \
  10669.             {var reg1 sintL ergebnis = full_read(handle,(RW_BUF_T)buf,len); \
  10670.              end_system_call();                                             \
  10671.              if (ergebnis<0) goto abbruch1;                                 \
  10672.              if (!(ergebnis==(len))) goto abbruch2;                         \
  10673.              inc_file_offset(len);                                          \
  10674.            }}
  10675.        #endif
  10676.        begin_read:
  10677.        set_file_offset(0);
  10678.        # Grundinformation lesen:
  10679.        {var memdump_header header;
  10680.         READ(&header,sizeof(header));
  10681.         if (!(header._magic == memdump_magic))
  10682.           {
  10683.             #ifdef UNIX
  10684.             # Versuche, das File on the fly mit GZIP zu dekomprimieren.
  10685.             var reg1 uintB* file_header = (uintB*)&header; # benutze sizeof(header) >= 2
  10686.             if (file_header[0] == '#' && file_header[1] == '!') # executable magic ?
  10687.               { # erste Textzeile ⁿberlesen
  10688.                 var char c;
  10689.                 begin_system_call();
  10690.                 if ( lseek(handle,-(long)sizeof(header),SEEK_CUR) <0) goto abbruch1; # im File zurⁿck an den Anfang
  10691.                 do { READ(&c,1); } until (c=='\n');
  10692.                 end_system_call();
  10693.                 #if ((defined(SPVW_PURE_BLOCKS) && defined(SINGLEMAP_MEMORY)) || defined(TRIVIALMAP_MEMORY)) && defined(HAVE_MMAP)
  10694.                 use_mmap = FALSE; # Die File-Offsets haben sich verschoben!
  10695.                 #endif
  10696.                 goto begin_read;
  10697.               }
  10698.             if (file_header[0] == 0x1F && file_header[1] == 0x8B) # gzip magic ?
  10699.               { # Pipe aufmachen, siehe make_pipe_input_stream in STREAM.D
  10700.                 var int handles[2];
  10701.                 var reg2 int child;
  10702.                 begin_system_call();
  10703.                 if ( lseek(handle,-(long)sizeof(header),SEEK_CUR) <0) goto abbruch1; # im File zurⁿck an den Anfang
  10704.                 if (!( pipe(handles) ==0)) goto abbruch1;
  10705.                 if ((child = vfork()) ==0)
  10706.                   { if ( dup2(handles[1],stdout_handle) >=0)
  10707.                       if ( CLOSE(handles[1]) ==0)
  10708.                         if ( CLOSE(handles[0]) ==0)
  10709.                           if ( dup2(handle,stdin_handle) >=0) # Das File sei der Input der Dekompression
  10710.                             # Dekompressor aufrufen. NB: "gzip -d" == "gunzip"
  10711.                             #if 0
  10712.                                execl("/bin/sh","/bin/sh","-c","gzip -d -c",NULL);
  10713.                             #else # so geht's auch ohne die Shell
  10714.                               execlp("gzip","gzip","-d","-c",NULL);
  10715.                             #endif
  10716.                     _exit(-1);
  10717.                   }
  10718.                 if (child==-1)
  10719.                   { CLOSE(handles[1]); CLOSE(handles[0]); goto abbruch1; }
  10720.                 if (!( CLOSE(handles[1]) ==0)) goto abbruch1;
  10721.                 if (!( CLOSE(handle) ==0)) goto abbruch1;
  10722.                 end_system_call();
  10723.                 #if ((defined(SPVW_PURE_BLOCKS) && defined(SINGLEMAP_MEMORY)) || defined(TRIVIALMAP_MEMORY)) && defined(HAVE_MMAP)
  10724.                 use_mmap = FALSE; # Von einer Pipe kann man kein mmap() machen!
  10725.                 #endif
  10726.                 loadmem_from_handle(handles[0]); # Wir lesen ab jetzt von der Pipe
  10727.                 begin_system_call();
  10728.                 wait2(child); # Zombie-Child entfernen
  10729.                 end_system_call();
  10730.                 return;
  10731.               }
  10732.             #endif
  10733.             goto abbruch2;
  10734.           }
  10735.         if (!(header._oint_type_mask == oint_type_mask)) goto abbruch2;
  10736.         if (!(header._oint_addr_mask == oint_addr_mask)) goto abbruch2;
  10737.         if (!(header._cons_type == cons_type)) goto abbruch2;
  10738.         if (!(header._complex_type == complex_type)) goto abbruch2;
  10739.         if (!(header._symbol_type == symbol_type)) goto abbruch2;
  10740.         if (!(header._system_type == system_type)) goto abbruch2;
  10741.         if (!(header._varobject_alignment == Varobject_alignment)) goto abbruch2;
  10742.         if (!(header._hashtable_length == hashtable_length)) goto abbruch2;
  10743.         if (!(header._fsubr_anz == fsubr_anz)) goto abbruch2;
  10744.         if (!(header._pseudofun_anz == pseudofun_anz)) goto abbruch2;
  10745.         if (!(header._symbol_anz == symbol_anz)) goto abbruch2;
  10746.         if (!(header._page_alignment == page_alignment)) goto abbruch2;
  10747.         #ifndef SPVW_MIXED_BLOCKS_OPPOSITE
  10748.         if (!(header._heapcount == heapcount)) goto abbruch2;
  10749.         #endif
  10750.         #ifdef SPVW_MIXED_BLOCKS_OPPOSITE
  10751.         # Offsets berechnen (Offset = neue Adresse - alte Adresse):
  10752.         {var reg5 sintL offset_objects = # Offset fⁿr Objekte variabler LΣnge
  10753.            mem.objects.start - header._mem_objects_start;
  10754.          var reg5 sintL offset_conses = # Offset fⁿr Zwei-Pointer-Objekte
  10755.            mem.conses.end - header._mem_conses_end;
  10756.          # neue Speicheraufteilung berechnen:
  10757.          mem.objects.end = header._mem_objects_end + offset_objects;
  10758.          mem.conses.start = header._mem_conses_start + offset_conses;
  10759.          # Feststellen, ob der Speicherplatz reicht:
  10760.          # Er reicht genau dann, wenn
  10761.          # geforderter Platz <= vorhandener Platz  <==>
  10762.          # header._mem_conses_end-header._mem_conses_start + header._mem_objects_end-header._mem_objects_start
  10763.          #   <= mem.conses.end - mem.objects.start  <==>
  10764.          # header._mem_objects_end + mem.objects.start-header._mem_objects_start
  10765.          #   <= header._mem_conses_start + mem.conses.end-header._mem_conses_end  <==>
  10766.          # mem.objects.end <= mem.conses.start
  10767.          if (!( (sintL)(mem.objects.end) <= (sintL)(mem.conses.start) )) goto abbruch3;
  10768.          # Aktualisierung vorbereiten:
  10769.          offset_objects_o = (oint)offset_objects << (oint_addr_shift-addr_shift);
  10770.          offset_conses_o = (oint)offset_conses << (oint_addr_shift-addr_shift);
  10771.         }
  10772.         #endif
  10773.         #ifdef SPVW_PURE_BLOCKS # SINGLEMAP_MEMORY
  10774.         if (!((aint)(&subr_tab) == header._subr_tab_addr)) goto abbruch2;
  10775.         if (!((aint)(&symbol_tab) == header._symbol_tab_addr)) goto abbruch2;
  10776.         #else
  10777.         offset_symbols_o = ((oint)(aint)(&symbol_tab) - (oint)header._symbol_tab_addr) << (oint_addr_shift-addr_shift);
  10778.         #ifdef MULTIMAP_MEMORY
  10779.         if (!(offset_symbols_o == 0)) goto abbruch2;
  10780.         #else
  10781.         old_symbol_tab_o = as_oint(type_pointer_object(symbol_type,header._symbol_tab_addr));
  10782.         #endif
  10783.         #endif
  10784.         # Offset-der-SUBRs-Tabelle initialisieren:
  10785.         offset_subrs_anz = 1+header._module_count;
  10786.         begin_system_call();
  10787.         offset_subrs = malloc(offset_subrs_anz*sizeof(*offset_subrs));
  10788.         end_system_call();
  10789.         if (offset_subrs==NULL) goto abbruch3;
  10790.         # Modulnamen lesen und mit den existierenden Modulen vergleichen:
  10791.         {var DYNAMIC_ARRAY(,old_modules,module_*,1+header._module_count);
  10792.          {var DYNAMIC_ARRAY(,module_names_buffer,char,header._module_names_size);
  10793.           READ(module_names_buffer,header._module_names_size);
  10794.           { var reg4 module_* * old_module = &old_modules[0];
  10795.             var reg3 char* old_name = &module_names_buffer[0];
  10796.             var reg2 uintC count;
  10797.             dotimespC(count,1+header._module_count,
  10798.               { var reg1 module_* module;
  10799.                 for_modules(all_modules,
  10800.                   { if (asciz_equal(old_name,module->name))
  10801.                       goto found_module;
  10802.                   });
  10803.                 # old_name nicht gefunden
  10804.                 goto abbruch2;
  10805.                 found_module:
  10806.                 # Das Lesen der Moduldaten vom File initialisiert das Modul.
  10807.                 module->initialized = TRUE;
  10808.                 *old_module++ = module;
  10809.                 old_name += asciz_length(old_name)+1;
  10810.               });
  10811.           }
  10812.           FREE_DYNAMIC_ARRAY(module_names_buffer);
  10813.          }
  10814.          # fsubr_tab, pseudofun_tab, symbol_tab lesen:
  10815.          READ(&old_fsubr_tab,sizeof(fsubr_tab));
  10816.          READ(&old_pseudofun_tab,sizeof(pseudofun_tab));
  10817.          READ(&symbol_tab,sizeof(symbol_tab));
  10818.          # Zu jedem Modul subr_addr, subr_anz, object_anz, subr_tab, object_tab lesen:
  10819.          {var reg4 module_* * old_module = &old_modules[0];
  10820.           var reg5 offset_subrs_t* offset_subrs_ptr = &offset_subrs[0];
  10821.           var reg6 uintC count;
  10822.           dotimespC(count,1+header._module_count,
  10823.             { var subr_* old_subr_addr;
  10824.               var uintC old_subr_anz;
  10825.               var uintC old_object_anz;
  10826.               READ(&old_subr_addr,sizeof(subr_*));
  10827.               READ(&old_subr_anz,sizeof(uintC));
  10828.               READ(&old_object_anz,sizeof(uintC));
  10829.               if (!(old_subr_anz == *(*old_module)->stab_size)) goto abbruch2;
  10830.               if (!(old_object_anz == *(*old_module)->otab_size)) goto abbruch2;
  10831.               offset_subrs_ptr->low_o = as_oint(subr_tab_ptr_as_object(old_subr_addr));
  10832.               offset_subrs_ptr->high_o = as_oint(subr_tab_ptr_as_object(old_subr_addr+old_subr_anz));
  10833.               offset_subrs_ptr->offset_o = as_oint(subr_tab_ptr_as_object((*old_module)->stab)) - offset_subrs_ptr->low_o;
  10834.               if (old_subr_anz > 0)
  10835.                 { var DYNAMIC_ARRAY(,old_subr_tab,subr_,old_subr_anz);
  10836.                   READ(old_subr_tab,old_subr_anz*sizeof(subr_));
  10837.                  {var reg2 subr_* ptr1 = old_subr_tab;
  10838.                   var reg1 subr_* ptr2 = (*old_module)->stab;
  10839.                   var reg3 uintC count;
  10840.                   dotimespC(count,old_subr_anz,
  10841.                     { if (!(   (ptr1->req_anz == ptr2->req_anz)
  10842.                             && (ptr1->opt_anz == ptr2->opt_anz)
  10843.                             && (ptr1->rest_flag == ptr2->rest_flag)
  10844.                             && (ptr1->key_flag == ptr2->key_flag)
  10845.                             && (ptr1->key_anz == ptr2->key_anz)
  10846.                          ) )
  10847.                         goto abbruch2;
  10848.                       ptr2->name = ptr1->name; ptr2->keywords = ptr1->keywords;
  10849.                       ptr2->argtype = ptr1->argtype;
  10850.                       ptr1++; ptr2++;
  10851.                     });
  10852.                   FREE_DYNAMIC_ARRAY(old_subr_tab);
  10853.                 }}
  10854.               if (old_object_anz > 0)
  10855.                 { READ((*old_module)->otab,old_object_anz*sizeof(object)); }
  10856.               old_module++; offset_subrs_ptr++;
  10857.             });
  10858.          }
  10859.          # subr_tab, object_tab der anderen Module vorinitialisieren:
  10860.          { var reg3 module_* module;
  10861.            for_modules(all_modules,
  10862.              { if (!module->initialized)
  10863.                  { { var reg1 subr_* ptr = module->stab; # subr_tab durchgehen
  10864.                      var reg2 uintC count;
  10865.                      dotimesC(count,*module->stab_size, { ptr->name = NIL; ptr->keywords = NIL; ptr++; });
  10866.                    }
  10867.                    { var reg1 object* ptr = module->otab; # object_tab durchgehen
  10868.                      var reg2 uintC count;
  10869.                      dotimesC(count,*module->otab_size, { *ptr++ = NIL; });
  10870.                  } }
  10871.              });
  10872.          }
  10873.          #ifdef SPVW_PURE_BLOCKS
  10874.          # Start- und Endadressen jedes Heaps gleich in mem.heaps[] ⁿbernehmen:
  10875.          {var reg6 uintL heapnr;
  10876.           for (heapnr=0; heapnr<heapcount; heapnr++)
  10877.             { map_heap(mem.heaps[heapnr],page,
  10878.                 { var memdump_page _page;
  10879.                   READ(&_page,sizeof(_page));
  10880.                   page->page_start = _page._page_start;
  10881.                   page->page_end = _page._page_end;
  10882.                 });
  10883.          }  }
  10884.          #endif
  10885.          #ifdef TRIVIALMAP_MEMORY
  10886.          # Start- und Endadressen jedes Heaps lesen und die Gr÷▀e in mem.heaps[]
  10887.          # auf dieselbe LΣnge bringen:
  10888.          {var reg6 uintL heapnr;
  10889.           for (heapnr=0; heapnr<heapcount; heapnr++)
  10890.             { map_heap(mem.heaps[heapnr],page,
  10891.                 { var memdump_page _page;
  10892.                   READ(&_page,sizeof(_page));
  10893.                   page->page_end = page->page_start + (_page._page_end - _page._page_start);
  10894.                   offset_heaps_o[heapnr] = (oint)(sintL)(page->page_start - _page._page_start) << (oint_addr_shift-addr_shift);
  10895.                 });
  10896.          }  }
  10897.          #endif
  10898.          #ifdef SPVW_PAGES
  10899.          {var reg8 uintC total_pagecount;
  10900.           #ifdef SPVW_BLOCKS
  10901.           total_pagecount = heapcount;
  10902.           #endif
  10903.           #ifdef SPVW_PAGES
  10904.           var uintC pagecounts[heapcount];
  10905.           # Pages-per-Heap-Tabelle initialisieren:
  10906.           READ(&pagecounts,sizeof(pagecounts));
  10907.           # total_pagecount berechnen:
  10908.           {var reg1 uintL heapnr;
  10909.            total_pagecount = 0;
  10910.            for (heapnr=0; heapnr<heapcount; heapnr++)
  10911.              { total_pagecount += pagecounts[heapnr]; }
  10912.           }
  10913.           #endif
  10914.           # Offset-per-Page-Tabelle initialisieren:
  10915.           begin_system_call();
  10916.           offset_pages = malloc(offset_pages_len*sizeof(*offset_pages));
  10917.           end_system_call();
  10918.           if (offset_pages==NULL) goto abbruch3;
  10919.           {var reg1 uintL pagenr;
  10920.            for (pagenr=0; pagenr<offset_pages_len; pagenr++)
  10921.              { offset_pages[pagenr].old_page_start = ~0L;
  10922.                offset_pages[pagenr].offset_page_o = 0;
  10923.           }  }
  10924.           # Adressen und Gr÷▀en der Pages lesen und Pages allozieren:
  10925.           { var DYNAMIC_ARRAY(reg10,old_pages,memdump_page,total_pagecount);
  10926.             READ(old_pages,total_pagecount*sizeof(memdump_page));
  10927.            {var DYNAMIC_ARRAY(reg10,new_pages,aint,total_pagecount);
  10928.             {var reg6 memdump_page* old_page_ptr = &old_pages[0];
  10929.              var reg6 aint* new_page_ptr = &new_pages[0];
  10930.              var reg6 uintL heapnr;
  10931.              for (heapnr=0; heapnr<heapcount; heapnr++)
  10932.                {var reg6 Pages* pages_ptr = &mem.heaps[heapnr].inuse;
  10933.                 #ifdef SPVW_PAGES
  10934.                 var reg5 uintC pagecount = pagecounts[heapnr];
  10935.                 until (pagecount==0)
  10936.                   {
  10937.                 #endif
  10938.                     var reg5 uintL need = old_page_ptr->_page_end - old_page_ptr->_page_start;
  10939.                     var reg5 uintL size1 = round_up(need,sizeof(cons_));
  10940.                     if (size1 < std_page_size) { size1 = std_page_size; }
  10941.                     { var reg7 uintL size2 = size1 + sizeof_NODE + (Varobject_alignment-1);
  10942.                       var reg6 aint addr = (aint)mymalloc(size2);
  10943.                       var reg1 Pages page;
  10944.                       if ((void*)addr == NULL) goto abbruch3;
  10945.                       #if !defined(AVL_SEPARATE)
  10946.                       page = (Pages)addr;
  10947.                       #else
  10948.                       begin_system_call();
  10949.                       page = (NODE*)malloc(sizeof(NODE));
  10950.                       end_system_call();
  10951.                       if (page == NULL) goto abbruch3;
  10952.                       #endif
  10953.                       # Page vom Betriebssystem bekommen.
  10954.                       page->m_start = addr; page->m_length = size2;
  10955.                       # Initialisieren:
  10956.                       page->page_start = page_start0(page);
  10957.                       page->page_end = page->page_start + need;
  10958.                       page->page_room = size1 - need;
  10959.                       # Diesem Heap zuschlagen:
  10960.                       *pages_ptr = AVL(AVLID,insert1)(page,*pages_ptr);
  10961.                       *new_page_ptr = page->page_start;
  10962.                       {var reg4 aint old_page_start = old_page_ptr->_page_start;
  10963.                        var reg4 aint old_page_end = old_page_ptr->_page_end;
  10964.                        var reg4 oint offset_page_o = ((oint)page->page_start - (oint)old_page_start) << (oint_addr_shift-addr_shift);
  10965.                        var reg1 uintL pagenr = pagenr_of(old_page_start & addr_mask);
  10966.                        do { if (!(offset_pages[pagenr].old_page_start == ~0L)) { abort(); }
  10967.                             offset_pages[pagenr].old_page_start = old_page_start;
  10968.                             offset_pages[pagenr].offset_page_o = offset_page_o;
  10969.                             pagenr++;
  10970.                           }
  10971.                           while (pagenr < pagenr_of(old_page_end & addr_mask));
  10972.                     } }
  10973.                     old_page_ptr++; new_page_ptr++;
  10974.                 #ifdef SPVW_PAGES
  10975.                     pagecount--;
  10976.                   }
  10977.                 #endif
  10978.             }  }
  10979.             # Inhalt der Pages lesen:
  10980.             {var reg6 memdump_page* old_page_ptr = &old_pages[0];
  10981.              var reg6 aint* new_page_ptr = &new_pages[0];
  10982.              until (total_pagecount == 0)
  10983.                { var reg2 uintL len = old_page_ptr->_page_end - old_page_ptr->_page_start;
  10984.                  READ(*new_page_ptr,len);
  10985.                  old_page_ptr++; new_page_ptr++;
  10986.                  total_pagecount--;
  10987.             }  }
  10988.             FREE_DYNAMIC_ARRAY(new_pages);
  10989.            }
  10990.            FREE_DYNAMIC_ARRAY(old_pages);
  10991.           }
  10992.          }
  10993.          #endif
  10994.          #if defined(SPVW_PURE_BLOCKS) || defined(TRIVIALMAP_MEMORY) # SINGLEMAP_MEMORY || TRIVIALMAP_MEMORY
  10995.          # Alignment verwirklichen:
  10996.          READ_page_alignment(file_offset);
  10997.          # Inhalt der Bl÷cke lesen:
  10998.          {var reg6 uintL heapnr;
  10999.           for (heapnr=0; heapnr<heapcount; heapnr++)
  11000.             { var reg2 Heap* heapptr = &mem.heaps[heapnr];
  11001.               var reg3 uintL len = heapptr->heap_end - heapptr->heap_start;
  11002.               var reg4 uintL map_len = round_up(len,map_pagesize);
  11003.               heapptr->heap_limit = heapptr->heap_start + map_len;
  11004.               if (map_len > 0)
  11005.                 {
  11006.                   #if defined(HAVE_MMAP)
  11007.                   # Wenn m÷glich, legen wir uns das Initialisierungsfile in den Speicher.
  11008.                   # Das sollte den Start beschleunigen und unn÷tiges Laden bis zur
  11009.                   # ersten GC verz÷gern.
  11010.                   # Hierzu ist das page_alignment n÷tig!
  11011.                   if (use_mmap)
  11012.                     { if (!( (void*) mmap((void*)(heapptr->heap_start),map_len,
  11013.                                           PROT_READ | PROT_WRITE,
  11014.                                           MAP_FIXED | MAP_PRIVATE,
  11015.                                           handle,file_offset
  11016.                                          )
  11017.                              == (void*)(-1)
  11018.                          ) )
  11019.                         { if ( lseek(handle,map_len,SEEK_CUR) <0) goto abbruch1;
  11020.                           inc_file_offset(map_len);
  11021.                           goto block_done;
  11022.                         }
  11023.                         else
  11024.                         { asciz_out(DEUTSCH ? "Kann das Initialisierungsfile nicht in den Speicher legen." :
  11025.                                     ENGLISH ? "Cannot map the initialisation file into memory." :
  11026.                                     FRANCAIS ? "Ne peux placer le fichier d'initialisation en mΘmoire." :
  11027.                                     ""
  11028.                                    );
  11029.                           errno_out(errno);
  11030.                           use_mmap = FALSE;
  11031.                         }
  11032.                     }
  11033.                   #endif
  11034.                   if (zeromap((void*)(heapptr->heap_start),map_len) <0) goto abbruch3;
  11035.                   READ(heapptr->heap_start,len);
  11036.                   READ_page_alignment(len);
  11037.                   block_done: ;
  11038.          }  }   }
  11039.          #endif
  11040.          #ifdef SPVW_MIXED_BLOCKS_OPPOSITE
  11041.          # Objekte variabler LΣnge lesen:
  11042.          {var reg2 uintL len = header._mem_objects_end - header._mem_objects_start;
  11043.           READ(mem.objects.start,len);
  11044.          }
  11045.          # Conses lesen:
  11046.          {var reg2 uintL len = header._mem_conses_end - header._mem_conses_start;
  11047.           READ(mem.conses.start,len);
  11048.          }
  11049.          #endif
  11050.          # File schlie▀en:
  11051.          #undef READ
  11052.          begin_system_call();
  11053.          #ifdef ATARI
  11054.          {var reg1 WORD ergebnis = GEMDOS_close(handle);
  11055.           if (ergebnis<0) goto abbruch1;
  11056.          }
  11057.          #endif
  11058.          #if defined(UNIX) || defined(DJUNIX) || defined(EMUNIX) || defined(WATCOM) || defined(AMIGAOS) || defined(RISCOS)
  11059.          if ( CLOSE(handle) <0) goto abbruch1;
  11060.          #endif
  11061.          end_system_call();
  11062.          # Durchlaufen durch alle LISP-Objekte und aktualisieren:
  11063.            #define aktualisiere  loadmem_aktualisiere
  11064.            # Programmkonstanten aktualisieren:
  11065.              aktualisiere_tab();
  11066.            # Pointer in den Cons-Zellen aktualisieren:
  11067.              aktualisiere_conses();
  11068.            # Pointer in den Objekten variabler LΣnge aktualisieren:
  11069.              #define aktualisiere_page  aktualisiere_page_normal
  11070.              aktualisiere_varobjects();
  11071.              #undef aktualisiere_page
  11072.            #undef aktualisiere
  11073.          #ifdef SPVW_PAGES
  11074.          begin_system_call(); free(offset_pages); end_system_call();
  11075.          recalc_space(FALSE);
  11076.          #endif
  11077.          #if defined(SPVW_PURE_BLOCKS) || defined(TRIVIALMAP_MEMORY) # SINGLEMAP_MEMORY || TRIVIALMAP_MEMORY
  11078.          #ifdef GENERATIONAL_GC
  11079.          { var reg6 uintL heapnr;
  11080.            for (heapnr=0; heapnr<heapcount; heapnr++)
  11081.              { var reg2 Heap* heapptr = &mem.heaps[heapnr];
  11082.                heapptr->heap_gen0_start = heapptr->heap_start;
  11083.                heapptr->heap_gen0_end = heapptr->heap_end;
  11084.                heapptr->heap_gen1_start = heapptr->heap_end = heapptr->heap_limit;
  11085.                heapptr->physpages = NULL;
  11086.                if (!is_unused_heap(heapnr))
  11087.                  { build_old_generation_cache(heapnr); }
  11088.          }   }
  11089.          # Ab jetzt brauchen wir den SIGSEGV-Handler.
  11090.          install_segv_handler();
  11091.          #endif
  11092.          { var reg2 uintL space = used_space();
  11093.            set_total_room(space); # bis zur nΣchsten GC haben wir viel Zeit
  11094.            #ifdef GENERATIONAL_GC
  11095.            mem.last_gcend_space0 = space;
  11096.            mem.last_gcend_space1 = 0;
  11097.            #endif
  11098.          }
  11099.          #endif
  11100.          FREE_DYNAMIC_ARRAY(old_modules);
  11101.         }
  11102.         begin_system_call(); free(offset_subrs); end_system_call();
  11103.       }}
  11104.       # offene Files fⁿr geschlossen erklΣren:
  11105.       closed_all_files();
  11106.       #ifdef GENERATIONAL_GC
  11107.       # bisher keine GCs:
  11108.       O(gc_count) = Fixnum_0;
  11109.       #endif
  11110.       #ifdef MACHINE_KNOWN
  11111.         # (MACHINE-TYPE), (MACHINE-VERSION), (MACHINE-INSTANCE)
  11112.         # wieder fⁿr unbekannt erklΣren:
  11113.         O(machine_type_string) = NIL;
  11114.         O(machine_version_string) = NIL;
  11115.         O(machine_instance_string) = NIL;
  11116.       #endif
  11117.       CHECK_AVL_CONSISTENCY();
  11118.       CHECK_GC_CONSISTENCY();
  11119.       CHECK_GC_UNMARKED(); CHECK_NULLOBJ(); CHECK_GC_CACHE(); CHECK_GC_GENERATIONAL(); SAVE_GC_DATA();
  11120.       CHECK_PACK_CONSISTENCY();
  11121.       return;
  11122.       abbruch1:
  11123.         #if defined(UNIX) || defined(DJUNIX) || defined(EMUNIX) || defined(WATCOM) || defined(RISCOS)
  11124.         {var reg3 int abbruch_errno = errno;
  11125.         #endif
  11126.          asciz_out(program_name); asciz_out(": ");
  11127.          asciz_out(
  11128.            DEUTSCH ? "Betriebssystem-Fehler beim Versuch, das Initialisierungsfile zu laden." CRLFstring :
  11129.            ENGLISH ? "operating system error during load of initialisation file" CRLFstring :
  11130.            FRANCAIS ? "Erreur systΦme pendant le chargement du fichier d'initialisation." CRLFstring :
  11131.            ""
  11132.            );
  11133.         #if defined(UNIX) || defined(DJUNIX) || defined(EMUNIX) || defined(WATCOM) || defined(RISCOS)
  11134.          errno_out(abbruch_errno);
  11135.         }
  11136.         #endif
  11137.         goto abbruch_quit;
  11138.       abbruch2:
  11139.         asciz_out(program_name); asciz_out(": ");
  11140.         asciz_out(
  11141.           DEUTSCH ? "Initialisierungsfile wurde nicht von dieser LISP-Version erzeugt." CRLFstring :
  11142.           ENGLISH ? "initialisation file was not created by this version of LISP" CRLFstring :
  11143.           FRANCAIS ? "Le fichier d'initialisation ne provient pas de cette version de LISP." CRLFstring :
  11144.           ""
  11145.           );
  11146.         goto abbruch_quit;
  11147.       abbruch3:
  11148.         asciz_out(program_name); asciz_out(": ");
  11149.         asciz_out(
  11150.           DEUTSCH ? "Speicherplatz reicht fⁿr Initialisierung nicht aus." CRLFstring :
  11151.           ENGLISH ? "not enough memory for initialisation" CRLFstring :
  11152.           FRANCAIS ? "Il n'y a pas assez de mΘmoire pour l'initialisation." CRLFstring :
  11153.           ""
  11154.           );
  11155.         goto abbruch_quit;
  11156.       abbruch_quit:
  11157.         # Abbruch.
  11158.         # Zuvor die Datei schlie▀en, falls sie erfolgreich ge÷ffnet worden war.
  11159.         # (Hierbei werden Fehler nun aber wirklich ignoriert!)
  11160.         #ifdef ATARI
  11161.         if (!(handle<0))
  11162.           { begin_system_call(); GEMDOS_close(handle); end_system_call(); }
  11163.         #endif
  11164.         #ifdef AMIGAOS
  11165.         if (!(handle==Handle_NULL))
  11166.           { begin_system_call(); CLOSE(handle); end_system_call(); }
  11167.         #endif
  11168.         #if defined(UNIX) || defined(DJUNIX) || defined(EMUNIX) || defined(WATCOM) || defined(RISCOS)
  11169.         if (!(handle<0))
  11170.           { begin_system_call(); CLOSE(handle); end_system_call(); }
  11171.         #endif
  11172.         quit_sofort(1);
  11173.     }}
  11174.  
  11175. # ------------------------------------------------------------------------------
  11176. #ifdef ATARI
  11177. #                       Fremdprogramm-Aufruf
  11178.  
  11179. # UP: Ruft ein Fremdprogramm auf.
  11180. # execute(memneed)
  11181. # > -(STACK): Filename des Fremdprogramms, ein Simple-ASCIZ-String
  11182. # > -(STACK): Argumente (Command Tail), ein Simple-String
  11183. # > uintL memneed: Fⁿrs Fremdprogramm zu reservierende Byte-Zahl (gerade)
  11184. # < sintL ergebnis : Falls negativ, Fehlernummer.
  11185. #                    Sonst Returncode des aufgerufenen Programms.
  11186. # STACK wird aufgerΣumt
  11187. # kann GC ausl÷sen
  11188.   global sintL execute (uintL memneed);
  11189.   local void move_MEMTOP (sintL delta);
  11190.   nonreturning_function(local, fehler_Malloc_failed, (void));
  11191.   global sintL execute(memneed)
  11192.     var reg4 uintL memneed;
  11193.     { var reg5 sintL ergebnis; # Returncode des aufgerufenen Programms
  11194.       make_space(memneed); # memneed Bytes Platz machen
  11195.       move_MEMTOP(-(sintL)memneed); # MEMTOP um memneed heruntersetzen
  11196.       # Programm aufrufen:
  11197.       { var reg2 object tail = popSTACK(); # Command-Tail
  11198.         if (TheSstring(tail)->length > 127) # LΣnge soll <=127 sein
  11199.           { pushSTACK(tail);
  11200.             fehler(error,
  11201.                    DEUTSCH ? "Zu langer Command-Tail: ~" :
  11202.                    ENGLISH ? "Command tail too long: ~" :
  11203.                    FRANCAIS ? "ParamΦtres de commande trop longs : ~" :
  11204.                    ""
  11205.                   );
  11206.           }
  11207.         set_break_sem_1(); # Break verbieten
  11208.         run_time_stop(); # Run-Time-Stoppuhr anhalten
  11209.         old_keyboard(); # Tastaturabfrage in Urzustand bringen
  11210.         LineA_MouseUnhide(); # Maus in Urzustand bringen
  11211.         ergebnis =
  11212.           GEMDOS_exec_0( &TheSstring(STACK_0)->data[0], # Filename: ab hier die Zeichen
  11213.                          &TheSstring(tail)->data[-1], # Tail: ab hier 1 Byte LΣnge und die Zeichen
  11214.                          basepage->EnvStrPtr # Environment: Parent-Environment
  11215.                        );
  11216.         LineA_MouseHide(); # Maus abschalten
  11217.         new_keyboard(); # Keyboard-Input-Stream wieder funktionsfΣhig machen
  11218.         run_time_restart(); # Run-Time-Stoppuhr weiterlaufen lassen
  11219.         clr_break_sem_1(); # Break wieder erm÷glichen
  11220.       }
  11221.       # ▄berprⁿfen, ob das Programm seinen Speicher freigegeben hat:
  11222.       { var reg1 LONG erg = GEMDOS_Malloc(memneed); # alten Platz wieder allozieren
  11223.         if ((erg<0) || !(erg==mem.MEMTOP)) # er mu▀ bei mem.MEMTOP anfangen
  11224.           { fehler(serious_condition, # Filename in STACK_0
  11225.                    DEUTSCH ? "Programm ~ hat seinen Speicher nicht zurⁿckgegeben." :
  11226.                    ENGLISH ? "Program ~ did not return its memory." :
  11227.                    FRANCAIS ? "Le programme ~ n'a pas rendu la mΘmoire allouΘe." :
  11228.                    ""
  11229.                   );
  11230.           }
  11231.         # alten Platz wieder freigeben (um Bl÷cke zu verschmelzen):
  11232.         if (GEMDOS_Mfree(erg)<0) fehler_Malloc_failed();
  11233.       }
  11234.       # Speicher wieder verlangen:
  11235.       move_MEMTOP((sintL)memneed);
  11236.       skipSTACK(1); # Filename vergessen
  11237.       return(ergebnis);
  11238.     }
  11239. # UP: vergr÷▀ert den freien Speicherplatz fⁿr LISP-Objekte um delta (gerade)
  11240. # Bytes, indem die Conses und MEMTOP um delta Bytes nach oben geschoben werden.
  11241.   local void move_MEMTOP(delta)
  11242.     var reg3 sintL delta;
  11243.     { var reg2 aint new_MEMTOP = mem.MEMTOP+delta; # neue obere Speichergrenze
  11244.       # gesamten Speicherblock freigeben:
  11245.       { var reg1 WORD erg = GEMDOS_Mfree(MEMBLOCK);
  11246.         if (erg<0) fehler_Malloc_failed();
  11247.       }
  11248.       # verkleinerten Speicherblock wieder allozieren:
  11249.       { var reg1 LONG erg = GEMDOS_Malloc(new_MEMTOP-MEMBLOCK);
  11250.         # Speicherblock sollte bei MEMBLOCK anfangen:
  11251.         if ((erg<0) || !(erg==MEMBLOCK)) fehler_Malloc_failed();
  11252.       }
  11253.       # Neuer Speicherblock liegt an derselben Stelle, ist jedoch
  11254.       # um delta Bytes lΣnger.
  11255.       move_conses(delta); # Conses um delta Bytes nach oben schieben
  11256.       mem.MEMTOP = new_MEMTOP; # und MEMTOP vergr÷▀ern
  11257.     }
  11258. # UP: Fehlermeldung, wenn Malloc oder Mfree Unvorhersehbares produzierte.
  11259. # fehler_Malloc_failed();
  11260.   local void fehler_Malloc_failed()
  11261.     { fehler(serious_condition,
  11262.              DEUTSCH ? "─rger mit der Speicherverwaltung des Betriebssystems." NLstring
  11263.                        "Sie sollten das LISP verlassen und neu starten." :
  11264.              ENGLISH ? "We have problems with the memory allocation practice of the operation system." NLstring
  11265.                        "Please leave LISP and restart again." :
  11266.              FRANCAIS ? "DifficultΘs avec le systΦme d'allocation mΘmoire de TOS." NLstring
  11267.                         "Vous devriez quitter LISP puis le relancer." :
  11268.              ""
  11269.             );
  11270.     }
  11271.  
  11272. # Environment-Variablen abfragen:
  11273.   global const char * getenv (const char * name); # siehe GETENV(3V)
  11274.   global const char * getenv(name)
  11275.     var reg4 const char * name;
  11276.     {
  11277.      #ifdef GNU
  11278.       # Wegen verschiedener Parameter-▄bergabekonventionen ist es besser,
  11279.       # auf basepage->EnvStrPtr nicht selber zuzugreifen, sondern die von
  11280.       # crt0.o bereitgestellte Variable environ zu benutzen.
  11281.       extern char** environ;
  11282.       var reg3 const char * * env = environ;
  11283.       loop # env durchlaufen
  11284.         { var reg1 const char * next = *env++;
  11285.           if (next == NULL) break;
  11286.           # vergleiche, ob next mit name und einem '='-Zeichen beginnt:
  11287.           { var reg2 const char * nameptr = name;
  11288.             while (*next == *nameptr) { next++; nameptr++; }
  11289.             if ((*next == '=') && (*nameptr == '\0')) # gefunden?
  11290.               { return next+1; }
  11291.         } }
  11292.       return NULL;
  11293.      #endif
  11294.      #ifdef ATARI_TURBO
  11295.       var reg1 const char * next = basepage->EnvStrPtr; # Environment: Parent-Environment
  11296.       loop # env durchlaufen
  11297.         { if (*next == '\0') break;
  11298.           # vergleiche, ob next mit name und einem '='-Zeichen beginnt:
  11299.           { var reg2 const char * nameptr = name;
  11300.             while (*next == *nameptr) { next++; nameptr++; }
  11301.             if ((*next == '=') && (*nameptr == '\0')) # gefunden?
  11302.               { return next+1; }
  11303.           }
  11304.           # weiterrⁿcken:
  11305.           while (!(*next++ == '\0')) { ; }
  11306.         }
  11307.       return NULL;
  11308.      #endif
  11309.     }
  11310.  
  11311. #endif
  11312.  
  11313. # ------------------------------------------------------------------------------
  11314.  
  11315.