1 /*
2  * (SPVW = Speicherverwaltung): Memory Management for CLISP
3  * Bruno Haible 1990-2011, 2016-2018
4  * Sam Steingold 1998-2013, 2016-2017
5  * German comments translated into English: Stefan Kain 2002-03-24
6 
7  Content:
8  module management
9  debug utilities
10  memory size
11  object size determination
12  Page Fault and Protection handling
13  Garbage Collection
14  memory provision functions
15  cycle test
16  memory walk
17  elementary string functions
18  other global auxiliary functions
19  initialization
20  loading and storing MEM-files
21  dynamic loading of modules
22  version */
23 #include "lispbibl.c"
24 
25 #include "c-strtod.h"
26 #include "sha1.h"
27 
28 #ifdef MULTITHREAD
29   #define bzero(ptr,len)  memset(ptr,0,len)
30   #define bcopy(source,dest,len)  memcpy(dest,source,len)
31 #endif
32 
33 /* libsigsegv >= 2.10 defines SIGSEGV_FAULT_ADDRESS_ALIGNMENT in <sigsegv.h>,
34    but older versions didn't define it. */
35 #ifndef SIGSEGV_FAULT_ADDRESS_ALIGNMENT
36 #define SIGSEGV_FAULT_ADDRESS_ALIGNMENT 1UL
37 #endif
38 
39 /* in this file, the table macros have a different utilization: */
40   #undef LISPSPECFORM
41   #undef LISPFUN
42   #undef LISPSYM
43   #undef LISPOBJ
44 
45 /* table of all SUBRs: out-sourced to SPVWTABF
46  size of this table: */
47 #define subr_count  ((sizeof(subr_tab)-varobjects_misaligned)/sizeof(subr_t))
48 
49 /* table of all FSUBRs: moved to CONTROL
50  size of this table: */
51 #define fsubr_count  (sizeof(fsubr_tab)/sizeof(fsubr_t))
52 
53 /* tables of all relocatable pointers: moved to STREAM
54  size of these tables: */
55 #define pseudocode_count  (sizeof(pseudocode_tab)/sizeof(Pseudofun))
56 #if defined(MICROSOFT) && !defined(ENABLE_UNICODE)
57   #define pseudodata_count 0
58 #else
59   #define pseudodata_count  (sizeof(pseudodata_tab)/sizeof(Pseudofun))
60 #endif
61 /* total table: */
62 #define pseudofun_count  (pseudocode_count+pseudodata_count)
63 local struct pseudofun_tab_ { object pointer[pseudofun_count]; } pseudofun_tab;
64 
65 /* table of all fixed symbols: moved to SPVWTABS
66  size of these tables: */
67 #define symbol_count  ((sizeof(symbol_tab)-varobjects_misaligned)/sizeof(symbol_))
68 
69 /* table of all other fixed objects: moved to SPVWTABO
70  size of these tables: */
71 #define object_count  (sizeof(object_tab)/sizeof(gcv_object_t))
72 
73 /* looping over subr_tab:
74  (NB: subr_tab_ptr_as_object(ptr) turns a traversing pointer
75  into a genuine lisp-object.) */
76 #ifdef MAP_MEMORY_TABLES
77   local uintC total_subr_count;
78   #define for_all_subrs(statement)                                   \
79     do {                                                             \
80       var subr_t* ptr = (subr_t*)((char*)&subr_tab+varobjects_misaligned); /* traverse subr_tab */  \
81       var uintC count;                                               \
82       dotimesC(count,total_subr_count, { statement; ptr++; } );      \
83     } while(0)
84 #else
85   #define for_all_subrs(statement)                   \
86     do {                                             \
87       var module_t* module; /* traverse modules */   \
88       for_modules(all_modules,{                      \
89         if (module->initialized)                     \
90           if (*module->stab_size > 0) {              \
91             var subr_t* ptr = module->stab;          \
92             var uintC count;                         \
93             dotimespC(count,*module->stab_size,      \
94                       { statement; ptr++; } );       \
95           }                                          \
96       });                                            \
97     } while(0)
98 #endif
99 
100 /* On traversal of symbol_tab:
101  turns a traversing pointer into a genuine lisp-object. */
102 #ifdef MAP_MEMORY_TABLES
103   #define symbol_tab_ptr_as_object(ptr)  as_object((oint)(ptr))
104 #else
105   #ifdef TYPECODES
106     #define symbol_tab_ptr_as_object(ptr) type_pointer_object(symbol_type,ptr)
107   #else
108     #define symbol_tab_ptr_as_object(ptr) as_object((oint)(ptr)+varobject_bias)
109   #endif
110 #endif
111 /* traversal of symbol_tab: */
112 #define for_all_constsyms(statement)                                    \
113   do { var symbol_* ptr = (symbol_*)((char*)&symbol_tab+varobjects_misaligned); /* pass through symbol_tab */ \
114     var uintC count;                                                    \
115     dotimesC(count,symbol_count, { statement; ptr++; } );               \
116   } while(0)
117 
118 /* Traverse object_tab: */
119 #define for_all_constobjs(statement)                                    \
120   do { module_t* module;                   /* loop over modules */      \
121        for_modules(all_modules,{                                        \
122          if (module->initialized)                                       \
123            if (*module->otab_size > 0) {                                \
124              gcv_object_t* objptr = module->otab; /* loop over object_tab */ \
125              uintC count;                                               \
126              dotimespC(count,*module->otab_size,                        \
127                        { statement; objptr++; } );                      \
128        }});                                                             \
129   } while(0)
130 
131 /* Semaphores: decide, if a break is effectless (/=0) or
132  effectual (all = 0) .
133  Are set with set_break_sem_x and deleted with clr_break_sem_x again. */
134 #if !defined(MULTITHREAD)
135 /* in MT these semaphores are per thread */
136 global break_sems_ break_sems;
137 #endif
138 /* break_sem_0 == break_sems.einzeln[0]
139      set, as long as a page-fault-handling is in progress
140    break_sem_1 == break_sems.einzeln[1]
141      set, as long as the memory management forbids a break
142      (so that empty memory cannot be traversed by the GC)
143    break_sem_2 == break_sems.einzeln[2]
144      for package-management on lower level and hashtable-management
145    break_sem_3 == break_sems.einzeln[3]
146      for package-management on higher level
147    break_sem_4 == break_sems.einzeln[4]
148      set, as long as external functions are being called.
149    break_sem_5 == break_sems.einzeln[5]
150      set, as long as (UNIX) a signal-handler is being called. */
151 
152 /* --------------------------------------------------------------------------
153                           module management */
154 
155 #include "spvw_module.c"
156 
157 /* --------------------------------------------------------------------------
158                             debug-helper */
159 
160 #include "spvw_debug.c"
161 
162 /* --------------------------------------------------------------------------
163                           our own alloca() */
164 
165 #include "spvw_alloca.c"
166 
167 /* --------------------------------------------------------------------------
168                          fast program-exit */
169 
170 local _Noreturn void quit_instantly (int);
171 /* --------------------------------------------------------------------------
172                         bit mask computation */
173 
174 /* Compute the set of bits used by the interval [start,end]. */
bits_used_by_range(uintP start,uintP end)175 local uintP bits_used_by_range (uintP start, uintP end) {
176   /* If start < end, it goes like this:
177      Split start and end (as bit sequences) into a common part
178      (the longest common sequence of bits) and the first bit that differs.
179      Then the result is
180        the common part, OR that different bit, OR all lower bits.
181      For example:
182              start = 0001001 011000000
183              end   = 0001001 101011111
184      => range_mask = 0001001 111111111
185      because    x1 = 0001001 011111111
186      and        x2 = 0001001 100000000
187      are consecutive numbers in the range (start <= x1 < x2 <= end)
188      with x1 | x2 = range_mask.
189      The resulting code is symmetric in start <--> end, therefore works
190      also when start > end. */
191   var uintP diff = start ^ end;
192   diff |= diff >> 1;
193   diff |= diff >> 2;
194   diff |= diff >> 4;
195   diff |= diff >> 8;
196   diff |= diff >> 16;
197   #if (pointer_bitsize > 32)
198   diff |= diff >> 32;
199   #endif
200   var uintP range_bits = start | diff;
201   ASSERT(range_bits == (end | diff));
202   return range_bits;
203 }
204 
205 /* --------------------------------------------------------------------------
206                          memory management, common part */
207 
208 /* method of the memory management: */
209 #if defined(SPVW_BLOCKS) && defined(SPVW_MIXED) /* e.g. ATARI */
210   #define SPVW_MIXED_BLOCKS
211   #if !defined(TRIVIALMAP_MEMORY)
212     /* Blocks grow like this:         |******-->     <--****| */
213     #define SPVW_MIXED_BLOCKS_OPPOSITE
214   #else  /* defined(TRIVIALMAP_MEMORY) */
215     #if (!defined(WIDE_SOFT) || defined(CONS_HEAP_GROWS_DOWN)) && !defined(CONS_HEAP_GROWS_UP)
216       /* Blocks grow like this:       |******-->     <--****| */
217       #define SPVW_MIXED_BLOCKS_OPPOSITE
218     #else
219       /* Blocks grow like this:       |******-->      |***--> */
220       #define SPVW_MIXED_BLOCKS_STAGGERED
221     #endif
222   #endif
223 #endif
224 #if defined(SPVW_BLOCKS) && defined(SPVW_PURE) /* e.g. UNIX_LINUX, Linux 0.99.7 */
225   #define SPVW_PURE_BLOCKS
226 #endif
227 #if defined(SPVW_PAGES) && defined(SPVW_MIXED) /* e.g. HP9000_800 */
228   #define SPVW_MIXED_PAGES
229 #endif
230 #if defined(SPVW_PAGES) && defined(SPVW_PURE) /* e.g. SUN4 */
231   #define SPVW_PURE_PAGES
232 #endif
233 
234 /* --------------------------------------------------------------------------
235                           Memory map facility */
236 
237 #include "vma-iter.h"
238 
239 #if VMA_ITERATE_SUPPORTED
240 
dump_process_memory_map_callback(void * data,uintptr_t start,uintptr_t end,unsigned int flags)241 local int dump_process_memory_map_callback (void *data,
242                                             uintptr_t start, uintptr_t end,
243                                             unsigned int flags)
244 {
245   unused(flags);
246   fprintf((FILE*)data,"  0x%lx - 0x%lx\n",
247           (unsigned long)start, (unsigned long)(end-1));
248   return 0; /* continue */
249 }
250 
251 /* Print out the memory map of the process. */
dump_process_memory_map(FILE * out)252 local void dump_process_memory_map (FILE* out)
253 {
254   fprint(out,"Memory dump:\n");
255   vma_iterate (&dump_process_memory_map_callback, out);
256 }
257 
258 #endif
259 
260 /* --------------------------------------------------------------------------
261                           Page-Allocation */
262 
263 #include "spvw_mmap.c"
264 
265 /* Check the MAPPABLE_ADDRESS_RANGE_* values.
266    Return an exit code. */
mappable_address_range_check(void)267 local int mappable_address_range_check (void)
268 {
269   var int exitcode = 0;
270 #if defined(HAVE_MMAP_ANON) || defined(HAVE_MMAP_DEVZERO) || defined(HAVE_MACH_VM) || defined(HAVE_WIN32_VM)
271  #if defined(MAPPABLE_ADDRESS_RANGE_START) && defined(MAPPABLE_ADDRESS_RANGE_END)
272   var const uintL count = 256;
273   var uintL i;
274   mmap_init_pagesize();
275   mmap_init();
276   #if VMA_ITERATE_SUPPORTED
277   dump_process_memory_map(stdout);
278   #endif
279   fprint(stdout,"Starting check...\n");
280   for (i = 0; i <= count; i++) {
281     var uintP addr = MAPPABLE_ADDRESS_RANGE_START + ((MAPPABLE_ADDRESS_RANGE_END - MAPPABLE_ADDRESS_RANGE_START) / count) * i;
282     addr = addr & ~(mmap_pagesize-1);
283     var uintP endaddr = addr + mmap_pagesize;
284     if (mmap_prepare(&addr,&endaddr,false) < 0
285         || mmap_zeromap((void*)addr,endaddr-addr) < 0) {
286       fprintf(stdout,"  %p FAILED\n",(void*)addr);
287       exitcode = 1;
288     } else {
289       fprintf(stdout,"  %p OK\n",(void*)addr);
290     }
291   }
292   #if VMA_ITERATE_SUPPORTED
293   dump_process_memory_map(stdout);
294   #endif
295  #else
296   fprint(stdout,"Nothing to check: MAPPABLE_ADDRESS_RANGE_START and MAPPABLE_ADDRESS_RANGE_END are not defined.\n");
297  #endif
298 #else
299   fprint(stdout,"Nothing to check: The OS does not provide memory mapping facilities.\n");
300 #endif
301   return exitcode;
302 }
303 
304 #if defined(SINGLEMAP_MEMORY) || defined(TRIVIALMAP_MEMORY)
305 
306 #include "spvw_singlemap.c"
307 
308 #if defined(SINGLEMAP_MEMORY) && defined(HAVE_WIN32_VM)
309   /* Despite SINGLEMAP_MEMORY, a relocation may be necessary
310    at loadmem() time. */
311   #define SINGLEMAP_MEMORY_RELOCATE
312 #endif
313 
314 #endif  /* SINGLEMAP_MEMORY || TRIVIALMAP_MEMORY */
315 
316 /* Global variables. */
317 
318 #ifndef MULTITHREAD
319 
320 /* the STACK: */
321 #if !defined(STACK_register)
322 modexp gcv_object_t* STACK;
323 #endif
324 #ifdef HAVE_SAVED_STACK
325 modexp gcv_object_t* saved_STACK;
326 #endif
327 
328 /* MULTIPLE-VALUE-SPACE: */
329 #if !defined(mv_count_register)
330 modexp uintC mv_count;
331 #endif
332 #ifdef NEED_temp_mv_count
333 global uintC temp_mv_count;
334 #endif
335 #ifdef HAVE_SAVED_mv_count
336 modexp uintC saved_mv_count;
337 #endif
338 modexp object mv_space [mv_limit-1];
339 #ifdef NEED_temp_value1
340 global object temp_value1;
341 #endif
342 #ifdef HAVE_SAVED_value1
343 modexp object saved_value1;
344 #endif
345 
346 /* During the execution of a SUBR, FSUBR: the current SUBR resp. FSUBR */
347 #if !defined(back_trace_register)
348 modexp p_backtrace_t back_trace = NULL;
349 #endif
350 #ifdef HAVE_SAVED_back_trace
351 modexp p_backtrace_t saved_back_trace;
352 #endif
353 
354 /* during callbacks, the saved registers: */
355 #if defined(HAVE_SAVED_REGISTERS)
356 global struct registers * callback_saved_registers = NULL;
357 #endif
358 
359 /* stack-limits: */
360 #ifndef NO_SP_CHECK
361 global void* SP_bound;          /* SP-growth-limit */
362 #endif
363 modexp void* STACK_bound;       /* STACK-growth-limit */
364 global void* STACK_start;       /* STACK initial value */
365 
366 /* the lexical environment: */
367 global gcv_environment_t aktenv;
368 
369 global unwind_protect_caller_t unwind_protect_to_save;
370 
371 /* variables for passing of information to the top of the handler: */
372 global handler_args_t handler_args;
373 
374 /* As only whole regions of handlers are deactivated and activated again,
375  we treat the handlers on deactivation separately, but we maintain
376  a list of the STACK-regions, in which the handlers are deactivated.
377  A handler counts as inactive if and only if:
378  low_limit <= handler < high_limit
379  is true for one of the regions listed in inactive_handlers */
380 global stack_range_t* inactive_handlers = NULL;
381 
382 #endif /* !MULTITHREAD */
383 
384 /* --------------------------------------------------------------------------
385                            Multithreading */
386 
387 #ifndef MULTITHREAD
388 
389 #define for_all_threadobjs(statement)                                   \
390   do { var gcv_object_t* objptr = (gcv_object_t*)&aktenv;               \
391     var uintC count;                                                    \
392     dotimespC(count,sizeof(gcv_environment_t)/sizeof(gcv_object_t),     \
393               { statement; objptr++; });                                \
394   } while(0)
395 
396 #define for_all_STACKs(statement)             \
397   do { var gcv_object_t* objptr = &STACK_0;   \
398     { statement; }                            \
399   } while(0)
400 
401 #define for_all_back_traces(statement)      \
402   do { var p_backtrace_t bt = back_trace;   \
403     { statement;  }                         \
404   } while(0)
405 
406 #else
407 
408 /* forward decalration of MT signal handler */
409 local void install_async_signal_handlers();
410 local void *signal_handler_thread(void *arg);
411 
412 /* Mutex protecting the set of threads. */
413 global xmutex_t allthreads_lock;
414 /* double linked list with all threads */
415 local struct {
416   /* new threads are appended to the tail (when CTRL-C usually the first
417      thread is interrupted - probably "main thread").*/
418   clisp_thread_t *head, *tail;
419   /* how many active threads we have. can be used to limit the number of
420      threads without scanning the list */
421   uintC count;
422 } allthreads = { NULL, NULL, 0 };
423 
424 /* per thread symvalues of special variables are allocated on "pages" of
425    1024 gcv_object_t each. Freshly new build clisp image contains less
426    than 900 special symbols. */
427 #define THREAD_SYMVALUES_ALLOCATION_SIZE (1024*sizeof(gcv_object_t))
428 #define SYMVALUES_PER_PAGE (THREAD_SYMVALUES_ALLOCATION_SIZE/sizeof(gcv_object_t))
429 /* Set of threads. */
430 local xthread_t thr_signal_handler; /* the id of the signal handling thread */
431 
432 /* the first index in _ptr_symvalues used for per thread symbol bindings */
433 #define FIRST_SYMVALUE_INDEX 1
434 /* Number of symbol values currently in use in every thread. */
435 /* The first symvalue in thread is dummy - for faster Symbol_value*/
436 local uintL num_symvalues = FIRST_SYMVALUE_INDEX;
437 /* Maximum number of symbol values in every thread before new thread-local
438  storage must be added.
439  = THREAD_SYMVALUES_ALLOCATION_SIZE/sizeof(gcv_object_t) */
440 global uintL maxnum_symvalues;
441 /* lock guarding the addition of new per thread special variables. */
442 local xmutex_t thread_symvalues_lock;
443 
444 /* UP: checks that the calling thread is the only one running.
445    used only from savemem(). defined here in order not to expose the
446    threads array.
447    no locking is performed. if returns true - the caller may be sure that
448    there is no other running thread (only the caller) */
449 global bool single_running_threadp();
single_running_threadp()450 global bool single_running_threadp()
451 {
452   return allthreads.head->thr_next == NULL;
453 }
454 
455 #ifdef DEBUG_GCSAFETY
456 /* used during static initialization (before main() is called)
457    at that time the multithreading has not been initialized and
458    there is no current thread. */
459 local uintL dummy_alloccount=0;
460 local bool use_dummy_alloccount=true;
current_thread_alloccount()461 modexp uintL* current_thread_alloccount()
462 {
463   /* if MT is initialized - return the real alloccount.
464      otherwise (during subr_tab static initialization and signal handling) -
465      the dummy one - simple there is no current lisp thread */
466   return !use_dummy_alloccount ? &current_thread()->_alloccount : &dummy_alloccount;
467 }
468 #endif
469 
470 #ifdef per_thread
471  modexp per_thread clisp_thread_t *_current_thread;
472 #else
473  #if USE_CUSTOM_TLS == 1
474   modexp xthread_key_t current_thread_tls_key;
475  #elif USE_CUSTOM_TLS == 2
476 
477   modexp tsd threads_tls;
478 
479   /* A thread-specific data entry which will never    */
480   /* appear valid to a reader.  Used to fill in empty */
481   /* cache entries to avoid a check for 0.          */
482   local tse invalid_tse = {INVALID_QTID, 0, 0, 0};
483 
tsd_initialize()484   local void tsd_initialize()
485   {
486     var int i;
487     spinlock_init(&(threads_tls.lock));
488     for (i = 0; i < TS_CACHE_SIZE; ++i) {
489       threads_tls.cache[i] = &invalid_tse;
490     }
491     memset(threads_tls.hash,0,sizeof(threads_tls.hash));
492   }
493 
494   /* entry should be allocated by the caller (or reside on
495      the stack at a location that will survive the thread
496      lifespan) */
tsd_setspecific(tse * entry,void * value)497   modexp void tsd_setspecific(tse *entry, void *value)
498   {
499     var xthread_t self = xthread_self();
500     var int hash_val = TSD_HASH(self);
501     entry -> thread = self;
502     entry -> value = value;
503     entry -> qtid = INVALID_QTID;
504     spinlock_acquire(&(threads_tls.lock));
505     entry -> next = threads_tls.hash[hash_val];
506     *(threads_tls.hash + hash_val)=entry;
507     spinlock_release(&(threads_tls.lock));
508   }
509 
510   /* UP: Remove thread-specific data for current thread. Should be called on
511      thread exit */
tsd_remove_specific()512   global void tsd_remove_specific()
513   {
514     var xthread_t self = xthread_self();
515     var unsigned hash_val = TSD_HASH(self);
516     var tse *entry;
517     spinlock_acquire(&(threads_tls.lock));
518     var tse **link = threads_tls.hash + hash_val;
519     entry = *link;
520     while (entry != NULL && entry->thread != self) {
521       link = &(entry->next);
522       entry = *link;
523     }
524     *link = entry->next; /* remove the entry from the list */
525     entry->qtid = INVALID_QTID;
526     spinlock_release(&(threads_tls.lock));
527     /* now remove it from the cache as well. it is important since the entry
528        is on the C stack of dying thread and soon the memory will be reclaimed.
529        NB: this may cause cache misses in worst case (from other threads)*/
530     var int i;
531     for (i = 0; i < TS_CACHE_SIZE; ++i) {
532       if (threads_tls.cache[i] == entry)
533         threads_tls.cache[i] = &invalid_tse;
534     }
535   }
536 
537   /* slow path locks - but uses spinlock for very short time and it is
538      not likely to cause contention */
tsd_slow_getspecific(unsigned long qtid,tse * volatile * cache_ptr)539   modexp void* tsd_slow_getspecific(unsigned long qtid,
540                                     tse * volatile *cache_ptr)
541   {
542     ASSERT(qtid != INVALID_QTID);
543     var xthread_t self = xthread_self();
544     var unsigned hash_val = TSD_HASH(self);
545     /* lock the hash table */
546     spinlock_acquire(&(threads_tls.lock));
547     var tse *entry = threads_tls.hash[hash_val];
548     while (entry != NULL && entry->thread != self) {
549       entry = entry->next;
550     }
551 #if defined(UNIX_MACOSX) && defined(GENERATIONAL_GC)
552     /* needed since we may get called from SIGPIPE handler in
553        libsigsegv thread where there is no lisp thread associated*/
554     if (!entry) { spinlock_release(&(threads_tls.lock)); return NULL; }
555 #endif
556     /* Set cache_entry.         */
557     entry->qtid = qtid;
558     /* It's safe to do this asynchronously.  Either value       */
559     /* is safe, though may produce spurious misses.             */
560     /* We're replacing one qtid with another one for the        */
561     /* same thread.                                             */
562     *cache_ptr = entry;
563     /* Again this is safe since pointer assignments are         */
564     /* presumed atomic, and either pointer is valid.    */
565     spinlock_release(&(threads_tls.lock));
566     return entry->value;
567   }
568  #elif USE_CUSTOM_TLS == 3
569   #if defined(POSIX_THREADS)
570   /* UP: return the base address and size of current thread stack
571    > base: base address (top of the stack if SP_DOWN)
572    > size: stack size */
get_stack_region(aint * base,size_t * size)573   local bool get_stack_region(aint *base, size_t *size)
574   {
575     #ifdef UNIX_MACOSX
576      var pthread_t self_id;
577      self_id = pthread_self();
578      *base = (aint)pthread_get_stackaddr_np(self_id);
579      *size = pthread_get_stacksize_np(self_id);
580      *base -= *size; /* always SP_DOWN but *base is bottom of the stack */
581      return true;
582     #else /* assume fairly recent pthreads implementation */
583      var pthread_attr_t attr;
584      if (0 == pthread_getattr_np(pthread_self(), &attr)) {
585        var bool ret = (0 == pthread_attr_getstack(&attr, (void **)base, size));
586        pthread_attr_destroy(&attr);
587        return ret;
588      }
589     #endif
590     return false;
591   }
592   #endif /* POSIX_THREADS */
593   #ifdef WIN32_THREADS
get_stack_region(aint * base,size_t * size)594   local bool get_stack_region(aint *base, size_t *size)
595   {
596     MEMORY_BASIC_INFORMATION minfo;
597     aint stack_bottom;
598     size_t stack_size;
599     VirtualQuery(&minfo, &minfo, sizeof(minfo));
600     stack_bottom =  (aint)minfo.AllocationBase;
601     stack_size = minfo.RegionSize;
602     /* Add up the sizes of all the regions with the same */
603     /* AllocationBase. */
604     while( 1 ) {
605       VirtualQuery((void *)(stack_bottom+stack_size), &minfo, sizeof(minfo));
606       if ( stack_bottom == (aint)minfo.AllocationBase )
607         stack_size += minfo.RegionSize;
608       else
609         break;
610     }
611     *base = stack_bottom;
612     *size = stack_size;
613     return true;
614   }
615   #endif /* WIN32_THREADS */
616 
617   modexp clisp_thread_t *threads_map[1UL << (32 - TLS_SP_SHIFT)]={0};
set_current_thread(clisp_thread_t * thr)618   global void set_current_thread(clisp_thread_t *thr)
619   {
620     /* we should initialize the threads_map items in the
621      stack range of the current thread to point to thr. */
622     var aint stack_base, p;
623     var size_t stack_size, mapped=0;
624     if (!get_stack_region(&stack_base,&stack_size)) {
625       /* this either works or not. so on first (main) thread created
626        it will barf if not supported. */
627       fprint(stderr,"FATAL: get_stack_region() failed.");
628       abort();
629     }
630     for (p=stack_base, mapped=0;
631          mapped < stack_size;
632          p+=TLS_PAGE_SIZE, mapped+=TLS_PAGE_SIZE) {
633       threads_map[(unsigned long)p >> TLS_SP_SHIFT] = thr;
634     }
635   }
636  #else /* bad value for USE_CUSTOM_TLS */
637   #error "USE_CUSTOM_TLS should be defined as 1,2 or 3."
638  #endif
639 #endif /* !per_thread */
640 
641 /* forward definition */
642 extern void initialize_circ_detection();
643 
644 /* UP: Initialization of multithreading. Called at the beginning of main().*/
init_multithread(void)645 local void init_multithread (void) {
646   xthread_init();
647   /* TODO: put all global locks in some table. Soon we will have too many
648      of them and the things will become unmanageble. */
649   xmutex_init(&allthreads_lock); /* threads lock */
650   xmutex_init(&thread_symvalues_lock); /* for adding new thread symvalues */
651   xmutex_init(&open_files_lock); /* open files lock i.e. O(open_files) */
652   xmutex_init(&all_finalizers_lock); /* finalizer lock */
653   xmutex_init(&all_mutexes_lock); /* O(all_mutexes) lock */
654   xmutex_init(&all_exemptions_lock); /* O(all_exemptions) lock */
655   xmutex_init(&all_weakpointers_lock); /* O(all_weakpointers) lock */
656   xmutex_init(&all_packages_lock); /* O(all_packages) lock */
657   xmutex_init(&gensym_lock); /* GENSYM lock */
658   xmutex_init(&gentemp_lock); /* internal GENTEMP counter lock */
659 
660   initialize_circ_detection(); /* initialize the circ detection */
661   spinlock_init(&timeout_call_chain_lock);
662   maxnum_symvalues = SYMVALUES_PER_PAGE;
663   #if !defined(per_thread)
664    #if USE_CUSTOM_TLS == 1
665     xthread_key_create(&current_thread_tls_key);
666    #elif USE_CUSTOM_TLS == 2
667     tsd_initialize();
668    #elif USE_CUSTOM_TLS == 3
669    #endif
670   #endif
671 }
672 
673 /* UP: Makes per thread bindings (symvalues) for all standard special
674    variables. Called after the LISP heap and symbols are initialized.
675  < num_symvalues: modified.
676  < allthreads: _ptr_symvalues up to num_symvalues initialized.
677  < symbol_tab: tls_index of all special symbols initialized.*/
init_multithread_special_symbols()678 local void init_multithread_special_symbols()
679 {
680   /* currently there is just a single thread. get it.*/
681   var clisp_thread_t *thr=current_thread();
682   for_all_constsyms({
683     if (special_var_p(ptr)) {
684       /* Also we do not care about possibility to exceed the already allocated
685          space for _symvalues - we have enough space for standard symbols.*/
686       thr->_ptr_symvalues[num_symvalues]=SYMVALUE_EMPTY;
687       ptr->tls_index=num_symvalues++;
688     }
689   });
690   /* symbol_tab is initialized. it's safe to enable interrupts in main thread */
691   thr->_ptr_symvalues[TheSymbol(S(defer_interrupts))->tls_index] = NIL;
692   thr->_ptr_symvalues[TheSymbol(S(deferred_interrupts))->tls_index] = NIL;
693 }
694 
695 /* UP: allocates a LISP stack for new thread (except for the main one)
696  > thread: the CLISP thread object for which we are allocating STACK
697  > stack_size: the number of gcv_object_t that the STACK will be able to hold
698  Always called with main thread lock - so we are not going to call
699  begin/end_system_call. */
allocate_lisp_thread_stack(clisp_thread_t * thread,uintM stack_size)700 local void* allocate_lisp_thread_stack(clisp_thread_t* thread, uintM stack_size)
701 {
702   var uintM low,high,byte_size = stack_size*sizeof(gcv_object_t)+0x40;
703   begin_system_call();
704   low = (uintM)malloc(byte_size);
705   end_system_call();
706   if (!low) return NULL;
707   high = low + byte_size;
708   #ifdef STACK_DOWN
709    thread->_STACK_bound = (gcv_object_t *)(low + 0x40);
710    thread->_STACK = (gcv_object_t *)high;
711   #endif
712   #ifdef STACK_UP
713    thread->_STACK_bound = (gcv_object_t *)(high - 0x40);
714    thread->_STACK = (gcv_object_t *)low;
715   #endif
716   thread->_STACK_start=thread->_STACK;
717   return thread->_STACK;
718 }
719 
720 /* UP: creates new cisp_thread_t structure and allocates LISP stack.
721  > lisp_stack_size: the size of Lisp STACK to allocate (in gcv_object_t)
722       when 0 - this is the very first thread, so we may(should not)
723       perform some initializations
724  < clisp thread object
725  It is always called with the main thread mutex locked. */
create_thread(uintM lisp_stack_size)726 global clisp_thread_t* create_thread(uintM lisp_stack_size)
727 {
728   /* TBD: may be limit the number of active threads? */
729   var clisp_thread_t* thread;
730   begin_system_call();
731   thread=(clisp_thread_t *)malloc(sizeof(clisp_thread_t));
732   end_system_call();
733   if (!thread) return NULL;
734   begin_system_call();
735   memset(thread,0,sizeof(clisp_thread_t)); /* zero-up everything */
736   /* init _symvalues "proxy" */
737   thread->_ptr_symvalues = (gcv_object_t *)malloc(sizeof(gcv_object_t)*
738                                                   maxnum_symvalues);
739   if (!thread->_ptr_symvalues) {
740     free(thread);
741     end_system_call();
742     return NULL;
743   }
744   end_system_call();
745   { /* initialize the per thread special vars bindings to be "empty" */
746     var gcv_object_t* objptr = thread->_ptr_symvalues;
747     var uintC count;
748     dotimespC(count,maxnum_symvalues,{ *objptr++ = SYMVALUE_EMPTY; });
749     /* fill thread _object_tab with NIL-s in case GC is triggered before
750        they are really initialized.*/
751     objptr=(gcv_object_t*)&(thread->_object_tab);
752     dotimespC(count,sizeof(thread->_object_tab)/sizeof(gcv_object_t),
753               { *objptr++=NIL; });
754     /* allow interrupts in the new, not yet spawned thread, unless this is the
755        main one which will be handled in init_multithread_special_symbols() */
756     var gcv_object_t *symvals = thread->_ptr_symvalues;
757     if (num_symvalues != FIRST_SYMVALUE_INDEX) {
758       symvals[TheSymbol(S(defer_interrupts))->tls_index] = NIL;
759       symvals[TheSymbol(S(deferred_interrupts))->tls_index] = NIL;
760     }
761   }
762   if (lisp_stack_size) {
763     /* allocate the LISP stack */
764     if (!allocate_lisp_thread_stack(thread,lisp_stack_size)) {
765       begin_system_call();
766       free(thread->_ptr_symvalues);
767       free(thread);
768       end_system_call();
769       return NULL;
770     }
771     /* we own the stack and should free it on return */
772     thread->_own_stack=true;
773   }
774   spinlock_init(&thread->_gc_suspend_request); spinlock_acquire(&thread->_gc_suspend_request);
775   spinlock_init(&thread->_gc_suspend_ack); spinlock_acquire(&thread->_gc_suspend_ack);
776   xmutex_raw_init(&thread->_gc_suspend_lock);
777   spinlock_init(&thread->_signal_reenter_ok);
778   /* initialize the environment*/
779   thread->_aktenv.var_env   = NIL;
780   thread->_aktenv.fun_env   = NIL;
781   thread->_aktenv.block_env = NIL;
782   thread->_aktenv.go_env    = NIL;
783   thread->_aktenv.decl_env  = O(top_decl_env);
784   /* VTZ:TODO. get the right SP_bound (pthreads and win32 can provide it ??).
785    in USE_CUSTOM_TLS we have the functions. */
786 #ifndef NO_SP_CHECK
787   thread->_SP_bound=0;
788 #endif
789   /* add to allthreads list (at the end) */
790   if (allthreads.tail) {
791     allthreads.tail->thr_next = thread;
792     thread->thr_prev = allthreads.tail;
793     allthreads.tail = thread;
794   } else {
795     allthreads.head = allthreads.tail = thread;
796   }
797   allthreads.count++;
798   return thread;
799 }
800 
801 /* UP: removes the current_thread from the list (array) of threads.
802    Also frees any allocated resource.
803  > thread: thread to be removed */
delete_thread(clisp_thread_t * thread)804 global void delete_thread (clisp_thread_t *thread) {
805   /* lock the threads mutex. we are going to change allthreads[].
806    NB: we are called here in 2 cases:
807    1. thread is exiting - we do not hold allthreads_lock, but interrupts
808    are disabled.
809    2. thread has failed to start - in this case we already hold allthreads_lock */
810   var bool threads_locked = false;
811   if (thread == current_thread()) {
812     begin_blocking_system_call();
813     xmutex_lock(&allthreads_lock);
814     end_blocking_system_call();
815     threads_locked = true;
816   }
817   /* destroy OS mutex */
818   begin_system_call();
819   xmutex_raw_destroy(&thread->_gc_suspend_lock);
820   end_system_call();
821 
822   #ifdef WIN32_NATIVE
823   /* deinitialize COM library */
824   begin_system_call();
825   CoUninitialize();
826   end_system_call();
827   #endif
828 
829   /* remove from threads list */
830   if (thread->thr_prev) { /* ! first threads */
831     thread->thr_prev->thr_next = thread->thr_next;
832   } else {
833     allthreads.head = thread->thr_next;
834   }
835   if (thread->thr_next) { /* ! last_thread */
836     thread->thr_next->thr_prev = thread->thr_prev;
837   } else {
838     allthreads.tail = thread->thr_prev;
839   }
840   allthreads.count--;
841 
842   if (!allthreads.head) { /* this was the last thread ?*/
843     begin_system_call();
844     xmutex_unlock(&allthreads_lock);
845     end_system_call();
846     quit();
847     return; /* quit will unwind the stack and call hooks */
848   }
849   /* no globals for this thread record anymore */
850   TheThread(thread->_lthread)->xth_globals = NULL;
851   /* DO NOT remove from global list of all threads - i.e.
852      O(all_threads) = deleteq(O(all_threads), thread->_lthread); */
853 
854   /* The LISP stack should be unwound so no
855      interesting stuff on it. Let's deallocate it.*/
856   begin_system_call();
857   if (thread->_own_stack) {
858    #ifdef STACK_DOWN
859     free((char *)thread->_STACK_bound - 0x40);
860    #else /* STACK_UP */
861     free(thread->_STACK_start);
862    #endif
863   }
864   free(thread->_ptr_symvalues); /* free per trread special var bindings */
865   free(thread);
866   end_system_call();
867  #if USE_CUSTOM_TLS == 2
868   /* cleanup the cache - the memory on the C stack will become invalid */
869   if (thread == current_thread())
870     tsd_remove_specific();
871  #endif
872   if (threads_locked) { /* here we may not have current_thread() anymore*/
873     begin_system_call();
874     xmutex_unlock(&allthreads_lock);
875     end_system_call();
876   }
877 }
878 
879   #define for_all_threads(statement)                                    \
880     do { var clisp_thread_t *_cthread = allthreads.head;                \
881       while (_cthread) {                                                \
882         var clisp_thread_t *thread = _cthread;                          \
883         _cthread=_cthread->thr_next; statement; }                       \
884     } while(0)
885 
886 /* UP: reallocates _ptr_symvalues in all threads - so there is a place for
887    nsyms per thread symbol values.
888  > nsyms: number od symvalues to be available.
889  < true if reallocation succeeded.
890 should be called with allthreads_lock locked */
realloc_threads_symvalues(uintL nsyms)891 local bool realloc_threads_symvalues(uintL nsyms)
892 {
893   if (nsyms <= maxnum_symvalues) /* we already have enough place */
894     return true;
895   for_all_threads({
896     var gcv_object_t *p=(gcv_object_t *)realloc(thread->_ptr_symvalues,
897                                                 nsyms*sizeof(gcv_object_t));
898     /* in case of allocation error - abort immediately */
899     if (p) thread->_ptr_symvalues=p; else return false;
900     /* initialize all newly allocated cells to SYMVALUE_EMPTY (otherwise
901        we will have to lock threads when we add new per thread variable) */
902     var gcv_object_t* objptr = thread->_ptr_symvalues + num_symvalues;
903     var uintC count;
904     for (count = num_symvalues; count<nsyms; count++)
905       *objptr++ = SYMVALUE_EMPTY;
906   });
907   return true;
908 }
909 
910 #define for_all_threadobjs(statement)                                   \
911   for_all_threads({                                                     \
912     var gcv_object_t* objptr = (gcv_object_t*)(&thread->_aktenv);       \
913     var uintC count;                                                    \
914     dotimespC(count,sizeof(thread->_aktenv)/sizeof(gcv_object_t),       \
915               { statement; objptr++; });                                \
916     objptr=thread->_ptr_symvalues;                                      \
917     dotimespC(count,num_symvalues,{ statement; objptr++; });            \
918     objptr=(gcv_object_t*)&(thread->_object_tab);                       \
919     dotimespC(count,sizeof(thread->_object_tab)/sizeof(gcv_object_t),   \
920               { statement; objptr++; });                                \
921   })
922 
923 #define for_all_STACKs(statement)                                \
924   for_all_threads({                                              \
925     var gcv_object_t* objptr = STACKpointable(thread->_STACK);   \
926     { statement; }                                               \
927   })
928 
929 #define for_all_back_traces(statement)                            \
930   for_all_threads({ var p_backtrace_t bt = thread->_back_trace;   \
931     { statement; }                                                \
932   })
933 
934 #endif
935 
936 /* --------------------------------------------------------------------------
937                            Page-Management */
938 
939 #include "spvw_page.c"
940 #if !defined(OLD_GC)
941   #include "spvw_heap.c"
942 #else
943   #include "spvw_heap_old.c"
944 #endif
945 #if !defined(OLD_GC)
946   #include "spvw_global.c"
947 #else
948   #include "spvw_global_old.c"
949 #endif
950 
951 #ifdef SPVW_PAGES
952 
953 /* A dummy-page for lastused: */
954   local NODE dummy_NODE;
955   #define dummy_lastused  (&dummy_NODE)
956 
957 #endif
958 
959 /* ------------------------------------------------------------------------ */
960 
961 #if defined(NOCOST_SP_CHECK) && !defined(WIN32_NATIVE)
962 /* Check for near stack overflow. */
near_SP_overflow(void)963 global bool near_SP_overflow (void) {
964   /* Force a stack overflow if there is not a minimum of room available. */
965   var uintB dummy[0x1001];
966   dummy[0] = 0; dummy[0x800] = 0; dummy[0x1000] = 0;
967  #ifdef GNU
968   alloca(1);                    /* Makes this function non-inlinable. */
969  #endif
970   return false;
971 }
972 #endif
973 
974 /* At overflow of one of the stacks: */
SP_ueber(void)975 global _Noreturn void SP_ueber (void) {
976   var bool interactive_p = interactive_stream_p(Symbol_value(S(debug_io)));
977   begin_system_call();
978   fprint(stderr,"\n");
979   fprint(stderr,GETTEXTL("*** - " "Program stack overflow. RESET"));
980   fprint(stderr,"\n");
981   fflush(stderr);
982   end_system_call();
983   if (interactive_p)
984     reset(1);
985   else {
986     /* non-interactive session: quit */
987     final_exitcode = 1; quit();
988   }
989 }
STACK_ueber(void)990 modexp _Noreturn void STACK_ueber (void) {
991   var bool interactive_p = interactive_stream_p(Symbol_value(S(debug_io)));
992   begin_system_call();
993   fprint(stderr,"\n");
994   fprint(stderr,GETTEXTL("*** - " "Lisp stack overflow. RESET"));
995   fprint(stderr,"\n");
996   fflush(stderr);
997   end_system_call();
998   if (interactive_p)
999     reset(1);
1000   else {
1001     /* non-interactive session: quit */
1002     final_exitcode = 1; quit();
1003   }
1004 }
1005 
1006 /* -------------------------------------------------------------------------
1007                        GC-Statistics */
1008 
1009 #include "spvw_gcstat.c"
1010 
1011 /* --------------------------------------------------------------------------
1012                        Memory-Size */
1013 
1014 #include "spvw_space.c"
1015 
1016 /* --------------------------------------------------------------------------
1017                        Marks */
1018 
1019 #include "spvw_mark.c"
1020 
1021 /* --------------------------------------------------------------------------
1022                    object size determination */
1023 
1024 #include "spvw_objsize.c"
1025 
1026 /* --------------------------------------------------------------------------
1027                     Memory Update */
1028 
1029 #include "spvw_update.c"
1030 
1031 /* --------------------------------------------------------------------------
1032                       Page Fault and Protection Handling */
1033 
1034 #if defined(GENERATIONAL_GC)
1035 
1036 #if !defined(OLD_GC)
1037   #include "spvw_fault.c"
1038 #else
1039   #include "spvw_fault_old.c"
1040 #endif
1041 
1042 #endif  /* GENERATIONAL_GC */
1043 
1044 /* --------------------------------------------------------------------------
1045                       Signal handlers */
1046 
1047 #include "spvw_sigsegv.c"
1048 #include "spvw_sigcld.c"
1049 #include "spvw_sigpipe.c"
1050 #include "spvw_sigint.c"
1051 #include "spvw_sigwinch.c"
1052 #include "spvw_sigterm.c"
1053 
1054 /* --------------------------------------------------------------------------
1055                        Garbage-Collector */
1056 
1057 /* defines memory region in the varobject heap page.
1058  used during sweep phase and holes filling. */
1059 typedef struct varobj_mem_region {
1060 #if defined(SPVW_PURE)
1061   uintL heapnr; /* heap where region is located - for faster checking */
1062 #endif
1063   aint start; /* start address */
1064   aint size; /* region size */
1065 } varobj_mem_region;
1066 
1067 #if !defined(OLD_GC)
1068   #include "spvw_garcol.c"
1069 #else
1070   #include "spvw_garcol_old.c"
1071 #endif
1072 
1073 /* --------------------------------------------------------------------------
1074                  Memory Allocation Functions */
1075 
1076 #if !defined(OLD_GC)
1077   #include "spvw_allocate.c"
1078 #else
1079   #include "spvw_allocate_old.c"
1080 #endif
1081 #include "spvw_typealloc.c"
1082 
1083 /* --------------------------------------------------------------------------
1084                    Circularity Test */
1085 
1086 #if !defined(OLD_GC)
1087   #include "spvw_circ.c"
1088 #else
1089   #include "spvw_circ_old.c"
1090 #endif
1091 
1092 /* --------------------------------------------------------------------------
1093                      Memory Walk */
1094 
1095 #include "spvw_walk.c"
1096 
1097 /* --------------------------------------------------------------------------
1098                   Elementary String Functions */
1099 
1100 #ifndef asciz_length
1101 /* UP: Returns the length of an ASCIZ-string.
1102  asciz_length(asciz)
1103  > char* asciz: ASCIZ-string
1104        (address of a character sequence terminated by a nullbyte)
1105  < result: length of the character sequence (without nullbyte) */
asciz_length(const char * asciz)1106 modexp uintL asciz_length (const char * asciz) {
1107   var const char* ptr = asciz;
1108   var uintL len = 0;
1109   /* search nullbyte and increment length: */
1110   while (*ptr++ != 0) { len++; }
1111   return len;
1112 }
1113 #endif
1114 
1115 /* UP: compares two ASCIZ-strings.
1116  asciz_equal(asciz1,asciz2)
1117  > char* asciz1: first ASCIZ-string
1118  > char* asciz2: second ASCIZ-string
1119  < result: true if both sequences are equal */
asciz_equal(const char * asciz1,const char * asciz2)1120 modexp bool asciz_equal (const char * asciz1, const char * asciz2) {
1121   /* compare bytes until the first nullbyte: */
1122   while (1) {
1123     var char ch1 = *asciz1++;
1124     if (ch1 != *asciz2++) goto no;
1125     if (ch1 == '\0') goto yes;
1126   }
1127  yes: return true;
1128  no: return false;
1129 }
1130 
1131 /* UP: check that the first ASCIZ-string starts with the second one.
1132  asciz_startswith(asciz,prefix) === (strncmp(asciz,prefix,strlen(prefix))==0)
1133  > char* asciz: first ASCIZ-string
1134  > char* prefix: second ASCIZ-string
1135  < result: true if both sequences are equal up to the length of the second */
asciz_startswith(const char * asciz,const char * prefix)1136 modexp bool asciz_startswith (const char *asciz, const char *prefix) {
1137   /* compare bytes until the first nullbyte: */
1138   while (1) {
1139     var char ch = *prefix++;
1140     if (ch == '\0') return true;
1141     if (ch != *asciz++) return false;
1142   }
1143 }
1144 
1145 
1146 
1147 /* --------------------------------------------------------------------------
1148                   Other Global Helper Functions */
1149 
1150 /* malloc() with error check. */
clisp_malloc(size_t size)1151 modexp void* clisp_malloc (size_t size)
1152 {
1153   begin_system_call();
1154   var void* ptr = malloc(size);
1155   end_system_call();
1156   if (ptr)
1157     return ptr;
1158   pushSTACK(TheSubr(subr_self)->name);
1159   error(storage_condition,GETTEXT("~S: malloc() failed"));
1160 }
1161 /* realloc() with error check. */
clisp_realloc(void * ptr,size_t size)1162 modexp void* clisp_realloc (void* ptr, size_t size)
1163 {
1164   begin_system_call();
1165   ptr = realloc(ptr,size);
1166   end_system_call();
1167   if (ptr)
1168     return ptr;
1169   pushSTACK(TheSubr(subr_self)->name);
1170   error(storage_condition,GETTEXT("~S: realloc() failed"));
1171 }
1172 
1173 #if (int_bitsize < long_bitsize) && !defined(MULTITHREAD)
1174 /* passing value from longjmpl() to setjmpl()  : */
1175 #if DYNAMIC_TABLES && defined(export_unwind_protect_macros)
1176 modexp
1177 #endif
1178 long jmpl_value;
1179 #endif
1180 
1181 #ifdef NEED_OWN_GETSP
1182 /* determine (an approximation) of the SP-stackpointer. */
getSP(void)1183 global void* getSP (void) {
1184   var long dummy;
1185   return &dummy;
1186 }
1187 #endif
1188 
1189 /* VTZ: moved SP_anchor to clisp_thread_t. in MT it is part of the thread
1190  Seems it is used only for debugging/checking purposes. */
1191 #if !defined(MULTITHREAD)
1192 /* The initial value of SP() during main(). */
1193 global void* SP_anchor;
1194 #endif
1195 
1196 /* error-message when a location of the program is reached that is (should be)
1197  unreachable. Does not return.
1198  error_notreached(file,line);
1199  > file: filename (with quotation marks) as constant ASCIZ-string
1200  > line: line number */
error_notreached(const char * file,uintL line)1201 modexp _Noreturn void error_notreached (const char* file, uintL line) {
1202   end_system_call();            /* just in case */
1203   pushSTACK(fixnum(line));
1204   pushSTACK(ascii_to_string(file));
1205   error(serious_condition,
1206         GETTEXT("Internal error: statement in file ~S, line ~S has been reached!!\n"
1207                 "Please see <http://clisp.org/impnotes/faq.html#faq-bugs> for bug reporting instructions."));
1208 }
1209 
1210 #include "spvw_ctype.c"
1211 
1212 #include "spvw_language.c"
1213 
1214 /* --------------------------------------------------------------------------
1215                         Initialization */
1216 
1217 /* name of the program (for error reporting) */
1218 local const char* program_name;
1219 
1220 extern char *get_executable_name (void);
1221 
1222 /* Flag, if SYS::READ-FORM should behave ILISP-compatible: */
1223 global bool ilisp_mode = false;
1224 
1225 /* Flag, whether libreadline should be avoided */
1226 global bool disable_readline = false;
1227 
fsubr_argtype(uintW req_count,uintW opt_count,fsubr_body_t body_flag)1228 local fsubr_argtype_t fsubr_argtype (uintW req_count, uintW opt_count,
1229                                      fsubr_body_t body_flag)
1230 { /* conversion of the argument types of a FSUBR into a code: */
1231   switch (body_flag) {
1232     case fsubr_nobody:
1233       switch (opt_count) {
1234         case 0:
1235           switch (req_count) {
1236             case 1: return(fsubr_argtype_1_0_nobody);
1237             case 2: return(fsubr_argtype_2_0_nobody);
1238             default: goto illegal;
1239           }
1240         case 1:
1241           switch (req_count) {
1242             case 1: return(fsubr_argtype_1_1_nobody);
1243             case 2: return(fsubr_argtype_2_1_nobody);
1244             default: goto illegal;
1245           }
1246         default: goto illegal;
1247       }
1248     case fsubr_body:
1249       switch (opt_count) {
1250         case 0:
1251           switch (req_count) {
1252             case 0: return(fsubr_argtype_0_body);
1253             case 1: return(fsubr_argtype_1_body);
1254             case 2: return(fsubr_argtype_2_body);
1255             default: goto illegal;
1256           }
1257         default: goto illegal;
1258       }
1259     default: goto illegal;
1260   }
1261  illegal:
1262   fprintf(stderr,GETTEXTL("Unknown FSUBR signature: %d %d %d\n"),
1263           req_count,opt_count,body_flag);
1264   quit_instantly(1);
1265 }
1266 
subr_argtype(uintW req_count,uintW opt_count,subr_rest_t rest_flag,subr_key_t key_flag,const subr_initdata_t * sid)1267 local subr_argtype_t subr_argtype (uintW req_count, uintW opt_count,
1268                                    subr_rest_t rest_flag, subr_key_t key_flag,
1269                                    const subr_initdata_t *sid)
1270 { /* conversion of the argument types of a FSUBR into a code: */
1271   switch (key_flag) {
1272     case subr_nokey:
1273       switch (rest_flag) {
1274         case subr_norest:
1275           switch (opt_count) {
1276             case 0:
1277               switch (req_count) {
1278                 case 0: return(subr_argtype_0_0);
1279                 case 1: return(subr_argtype_1_0);
1280                 case 2: return(subr_argtype_2_0);
1281                 case 3: return(subr_argtype_3_0);
1282                 case 4: return(subr_argtype_4_0);
1283                 case 5: return(subr_argtype_5_0);
1284                 case 6: return(subr_argtype_6_0);
1285                 default: goto illegal;
1286               }
1287             case 1:
1288               switch (req_count) {
1289                 case 0: return(subr_argtype_0_1);
1290                 case 1: return(subr_argtype_1_1);
1291                 case 2: return(subr_argtype_2_1);
1292                 case 3: return(subr_argtype_3_1);
1293                 case 4: return(subr_argtype_4_1);
1294                 default: goto illegal;
1295               }
1296             case 2:
1297               switch (req_count) {
1298                 case 0: return(subr_argtype_0_2);
1299                 case 1: return(subr_argtype_1_2);
1300                 case 2: return(subr_argtype_2_2);
1301                 case 3: return(subr_argtype_3_2);
1302                 default: goto illegal;
1303               }
1304             case 3:
1305               switch (req_count) {
1306                 case 0: return(subr_argtype_0_3);
1307                 case 1: return(subr_argtype_1_3);
1308                 case 2: return(subr_argtype_2_3);
1309                 default: goto illegal;
1310               }
1311             case 4:
1312               switch (req_count) {
1313                 case 0: return(subr_argtype_0_4);
1314                 default: goto illegal;
1315               }
1316             case 5:
1317               switch (req_count) {
1318                 case 0: return(subr_argtype_0_5);
1319                 default: goto illegal;
1320               }
1321             default: goto illegal;
1322           }
1323         case subr_rest:
1324           switch (opt_count) {
1325             case 0:
1326               switch (req_count) {
1327                 case 0: return(subr_argtype_0_0_rest);
1328                 case 1: return(subr_argtype_1_0_rest);
1329                 case 2: return(subr_argtype_2_0_rest);
1330                 case 3: return(subr_argtype_3_0_rest);
1331                 default: goto illegal;
1332               }
1333             default: goto illegal;
1334           }
1335         default: goto illegal;
1336       }
1337     case subr_key:
1338       switch (rest_flag) {
1339         case subr_norest:
1340           switch (opt_count) {
1341             case 0:
1342               switch (req_count) {
1343                 case 0: return(subr_argtype_0_0_key);
1344                 case 1: return(subr_argtype_1_0_key);
1345                 case 2: return(subr_argtype_2_0_key);
1346                 case 3: return(subr_argtype_3_0_key);
1347                 case 4: return(subr_argtype_4_0_key);
1348                 default: goto illegal;
1349               }
1350             case 1:
1351               switch (req_count) {
1352                 case 0: return(subr_argtype_0_1_key);
1353                 case 1: return(subr_argtype_1_1_key);
1354                 default: goto illegal;
1355               }
1356             case 2:
1357               switch (req_count) {
1358                 case 1: return(subr_argtype_1_2_key);
1359                 default: goto illegal;
1360               }
1361             default: goto illegal;
1362           }
1363         case subr_rest:
1364         default: goto illegal;
1365       }
1366     case subr_key_allow: goto illegal;
1367     default: goto illegal;
1368   }
1369  illegal:
1370   fprintf(stderr,GETTEXTL("Unknown SUBR signature: %d %d %d %d"),
1371           req_count,opt_count,rest_flag,key_flag);
1372   if (sid)
1373     fprintf(stderr," (%s::%s)\n",sid->packname,sid->symname);
1374   else
1375     fprint(stderr,"\n");
1376   quit_instantly(1);
1377 }
1378 /* set the argtype of a subr_t *ptr */
1379 #define SUBR_SET_ARGTYPE(ptr,sid)                                       \
1380   ptr->argtype = (uintW)subr_argtype(ptr->req_count,ptr->opt_count,     \
1381                                      (subr_rest_t)(ptr->rest_flag),     \
1382                                      (subr_key_t)(ptr->key_flag),sid)
1383 
module_set_argtypes(module_t * module)1384 local inline void module_set_argtypes (module_t *module)
1385 { /* set artype for all SUBRs in the module */
1386   var subr_t* stab_ptr = module->stab; /* traverse subr_tab */
1387   var const subr_initdata_t *stab_init_ptr = module->stab_initdata;
1388   var uintC count = *module->stab_size;
1389   do { SUBR_SET_ARGTYPE(stab_ptr,stab_init_ptr);
1390     stab_ptr++; stab_init_ptr++;
1391   } while (--count);
1392 }
1393 
1394 /* Verify that an address has the PSEUDODATA_ALIGNMENT.
1395  This is important for calling make_machine. */
1396 #if PSEUDODATA_ALIGNMENT==1
1397   #define verify_pseudodata_alignment(ptr,name) /* not needed */
1398 #else
1399   #define verify_pseudodata_alignment(ptr,name)  \
1400     if ((uintP)(void*)(ptr) & (PSEUDODATA_ALIGNMENT-1))     \
1401       error_pseudodata_alignment((uintP)(void*)(ptr),name)
error_pseudodata_alignment(uintP address,const char * name)1402 local _Noreturn void error_pseudodata_alignment (uintP address, const char* name) {
1403   fprintf(stderr,"PSEUDODATA_ALIGNMENT is not fulfilled. &%s = 0x%lx.\n",
1404           name, (unsigned long)address);
1405   fprintf(stderr,"Use <stdalign.h> and alignas(%d) to its declaration.\n",
1406           PSEUDODATA_ALIGNMENT);
1407   abort();
1408 }
1409 #endif
1410 
1411 /* Verify that a code address has the PSEUDOCODE_ALIGNMENT.
1412  This is important for calling make_machine_code. */
1413 #if PSEUDOCODE_ALIGNMENT==1
1414   #define verify_pseudocode_alignment(ptr,name) /* not needed */
1415 #else
1416   #define verify_pseudocode_alignment(ptr,name)  \
1417     if (((uintP)(void*)(ptr)-C_FUNCTION_POINTER_BIAS) & (PSEUDOCODE_ALIGNMENT-1)) \
1418       error_pseudocode_alignment((uintP)(void*)(ptr),"&",name)
error_pseudocode_alignment(uintP address,const char * prefix,const char * name)1419 global _Noreturn void error_pseudocode_alignment (uintP address, const char* prefix, const char* name) {
1420   fprintf(stderr,"PSEUDOCODE_ALIGNMENT is not fulfilled. %s%s = 0x%lx.\n",
1421           prefix, name, (unsigned long)address);
1422  #if (__GNUC__ >= 3)
1423   fprintf(stderr,"Add -falign-functions=%d to FALIGNFLAGS in the Makefile.\n",
1424           PSEUDOCODE_ALIGNMENT);
1425  #endif
1426   abort();
1427 }
1428 #endif
1429 
1430 /* Initialization-routines for the tables
1431  during the first part of the initialization phase:
1432  initialize subr_tab: */
init_subr_tab_1(void)1433 local void init_subr_tab_1 (void) {
1434  #if defined(HEAPCODES)
1435   /* lispbibl.d normally takes care of this, using a gcc __attribute__.
1436    But __attribute__((aligned(4))) is ignored for some GCC targets,
1437    so we check it here for safety. */
1438   if (alignof(subr_t) < 4) {
1439     fprintf(stderr,"Alignment of SUBRs is %d. HEAPCODES requires it to be at least 4.\nRecompile CLISP with -DTYPECODES.\n",(int)alignof(subr_t));
1440     abort();
1441   }
1442  #endif
1443  #if defined(INIT_SUBR_TAB)
1444   #ifdef MAP_MEMORY_TABLES
1445   /* copy table into the designated region: */
1446   subr_tab = subr_tab_data;
1447   #endif
1448   #if !NIL_IS_CONSTANT
1449   {                             /* initialize the name-slot first: */
1450     var subr_t* ptr = (subr_t*)((char*)&subr_tab+varobjects_misaligned); /* traverse subr_tab */
1451      #define LISPFUN  LISPFUN_E
1452        #include "subr.c"
1453      #undef LISPFUN
1454   }
1455   {       /* and initialize the GCself and keywords-slot temporarily: */
1456     var subr_t* ptr = (subr_t*)((char*)&subr_tab+varobjects_misaligned); /* traverse subr_tab */
1457     var uintC count = subr_count;
1458     while (count--) {
1459       ptr->GCself = subr_tab_ptr_as_object(ptr);
1460       ptr->keywords = NIL;
1461       ptr++;
1462     }
1463   }
1464   #endif
1465   /* Because of SPVWTABF all slots except keywords and argtype
1466    are already initialized. */
1467   {                          /* now initialize the argtype-slot: */
1468     var subr_t* ptr = (subr_t*)((char*)&subr_tab+varobjects_misaligned); /* traverse subr_tab */
1469     var uintC count = subr_count;
1470     while (count--) { SUBR_SET_ARGTYPE(ptr,NULL); ptr++; }
1471   }
1472  #else
1473   {                          /* initialize all slots except keywords: */
1474     var subr_t* ptr = (subr_t*)((char*)&subr_tab+varobjects_misaligned); /* traverse subr_tab */
1475     #define LISPFUN  LISPFUN_D
1476       #include "subr.c"
1477     #undef LISPFUN
1478   }
1479  #endif
1480   {
1481     var module_t* module;
1482     for_modules(all_other_modules,{
1483       if (*module->stab_size > 0) module_set_argtypes(module);
1484     });
1485   }
1486  #ifdef MAP_MEMORY_TABLES
1487   {               /* ditto, copy other tables into the mapped region: */
1488     var subr_t* newptr = (subr_t*)((char*)&subr_tab+varobjects_misaligned);
1489     var module_t* module;
1490     main_module.stab = newptr; newptr += subr_count;
1491     for_modules(all_other_modules,{
1492       var subr_t* oldptr = module->stab;
1493       var uintC count = *module->stab_size;
1494       module->stab = newptr;
1495       if (count > 0) {
1496         do { *newptr++ = *oldptr++; } while (--count);
1497       }
1498     });
1499     ASSERT(newptr == (subr_t*)((char*)&subr_tab+varobjects_misaligned) + total_subr_count);
1500   }
1501  #endif
1502 }
1503 /* initialize symbol_tab: */
init_symbol_tab_1(void)1504 local void init_symbol_tab_1 (void) {
1505  #if defined(INIT_SYMBOL_TAB) && NIL_IS_CONSTANT
1506   #ifdef MAP_MEMORY_TABLES
1507   /* copy table into the designated region: */
1508   symbol_tab = symbol_tab_data;
1509   #endif
1510  #else
1511   {                             /* traverse symbol_tab */
1512     var symbol_* ptr = (symbol_*)((char*)&symbol_tab+varobjects_misaligned);
1513     var uintC count;
1514     for (count = symbol_count; count > 0; count--) {
1515       ptr->GCself = symbol_tab_ptr_as_object(ptr);
1516      #ifndef TYPECODES
1517       ptr->tfl = xrecord_tfl(Rectype_Symbol,0,5,0);
1518      #endif
1519       ptr->symvalue = unbound;
1520       ptr->symfunction = unbound;
1521       ptr->hashcode = unbound;
1522       ptr->proplist = NIL;
1523       ptr->pname = NIL;
1524       ptr->homepackage = NIL;
1525       ptr++;
1526     }
1527   }
1528  #endif
1529 }
1530 /* initialize object_tab: */
init_object_tab_1(void)1531 local void init_object_tab_1 (void) {
1532   var module_t* module;
1533  #if defined(INIT_OBJECT_TAB) && NIL_IS_CONSTANT /* object_tab already pre-initialized? */
1534   for_modules(all_other_modules,{
1535     if (*module->otab_size > 0) {
1536       var gcv_object_t* ptr = module->otab; /* traverse object_tab */
1537       var uintC count;
1538       dotimespC(count,*module->otab_size, { *ptr++ = NIL; });
1539     }
1540   });
1541  #else
1542   for_modules(all_modules,{
1543     if (*module->otab_size > 0) {
1544       var gcv_object_t* ptr = module->otab; /* traverse object_tab */
1545       var uintC count;
1546       dotimespC(count,*module->otab_size, { *ptr++ = NIL; });
1547     }
1548   });
1549  #endif
1550   O(all_weakpointers) = Fixnum_0;
1551   O(all_finalizers) = Fixnum_0; O(pending_finalizers) = Fixnum_0;
1552 }
1553 /* initialize other modules coarsely: */
init_other_modules_1(void)1554 local void init_other_modules_1 (void) {
1555   var module_t* module;
1556   for_modules(all_other_modules, {
1557     /* fill pointer in the subr-table with NIL, for GC to become possible: */
1558     if (*module->stab_size > 0) {
1559       var subr_t* ptr = module->stab;
1560       var uintC count;
1561       dotimespC(count,*module->stab_size, {
1562         ptr->GCself = subr_tab_ptr_as_object(ptr);
1563         ptr->name = NIL; ptr->keywords = NIL;
1564         ptr++;
1565       });
1566     }
1567     /* the pointers in the object-table have already been inizialized
1568      by init_object_tab_1(). */
1569   });
1570 }
1571 
1572 /* Initialization-routines for the tables
1573  during the second part of the initialization phase:
1574  finish initialization of subr_tab: enter keyword-vectors. */
init_subr_tab_2(void)1575 local void init_subr_tab_2 (void) {
1576  #define LISPFUN  LISPFUN_H
1577   #define kw(name)  *vecptr++ = S(K##name)
1578   #include "subr.c"
1579   #undef LISPFUN
1580  #undef kw
1581 }
1582 /* finish initialization of symbol_tab: enter printnames and home-package. */
init_symbol_tab_2(void)1583 local void init_symbol_tab_2 (void) {
1584   /* table of printnames: */
1585   local const char * const pname_table[symbol_count] = {
1586     #define LISPSYM  LISPSYM_C
1587     #include "constsym.c"
1588     #undef LISPSYM
1589   };
1590   /* table of packages: */
1591   enum {                     /* the values in this enum are 0,1,2,... */
1592     enum_lisp_index,
1593     enum_user_index,
1594     enum_system_index,
1595     enum_keyword_index,
1596     enum_charset_index,
1597     enum_cs_lisp_index,
1598     enum_cs_user_index,
1599     #define LISPPACK  LISPPACK_A
1600     #include "constpack.c"
1601     #undef LISPPACK
1602     enum_dummy_index
1603   };
1604   #define package_count  ((uintL)enum_dummy_index)
1605   local const uintB package_index_table[symbol_count] = {
1606     #define LISPSYM  LISPSYM_D
1607     #include "constsym.c"
1608     #undef LISPSYM
1609   };
1610   {
1611     var object list = O(all_packages); /* list of packages */
1612     /* shortly after the initialization:
1613      (#<PACKAGE LISP> #<PACKAGE SYSTEM> #<PACKAGE KEYWORD> #<PACKAGE CHARSET> ...) */
1614     var uintC count = package_count;
1615     do { pushSTACK(Car(list)); list = Cdr(list); } while (--count);
1616   }
1617   {                             /* traverse symbol_tab */
1618     var symbol_* ptr = (symbol_*)((char*)&symbol_tab+varobjects_misaligned);
1619     var const char * const * pname_ptr = &pname_table[0]; /* traverse pname_table */
1620     var const uintB* index_ptr = &package_index_table[0]; /* traverse package_index_table */
1621     var uintC count = symbol_count;
1622     do {
1623       ptr->pname =
1624         coerce_imm_ss(' ' == **pname_ptr              /* non-ASCII */
1625                       ? asciz_to_string(*pname_ptr+1, /* skip ' ' */
1626                                         Symbol_value(S(utf_8)))
1627                       : ascii_to_string(*pname_ptr));
1628       pname_ptr++;
1629       var uintB this_index = *index_ptr++;
1630       var gcv_object_t* package_ = /* pointer to the package */
1631         &STACK_(package_count-1) STACKop -(uintP)this_index;
1632       pushSTACK(symbol_tab_ptr_as_object(ptr)); /* Symbol */
1633       import(&STACK_0,package_);                /* import normally */
1634       switch (this_index) {
1635         case enum_lisp_index:    /* in #<PACKAGE COMMON-LISP>? */
1636         case enum_charset_index: /* in #<PACKAGE CHARSET>? */
1637         case enum_cs_lisp_index: /* in #<PACKAGE CS-COMMON-LISP>? */
1638         case enum_socket_index:
1639         case enum_custom_index:
1640           export(&STACK_0,package_); /* also export */
1641       }
1642       Symbol_package(popSTACK()) = *package_; /* set the home-package */
1643       ptr++;
1644     } while (--count != 0);
1645     skipSTACK(package_count);
1646   }
1647 }
1648 /* enter FSUBRs/SUBRs into their symbols: */
init_symbol_functions(void)1649 local void init_symbol_functions (void) {
1650   {                             /* enter FSUBRs: */
1651     typedef struct {
1652       #if defined(INIT_SUBR_TAB) && NIL_IS_CONSTANT
1653         #define LISPSPECFORM LISPSPECFORM_F
1654         gcv_object_t name;
1655         #define fsubr_name(p)  (p)->name
1656       #else
1657         #define LISPSPECFORM LISPSPECFORM_E
1658         uintL name_offset;
1659         #define fsubr_name(p)  symbol_tab_ptr_as_object((char*)&symbol_tab+(p)->name_offset)
1660       #endif
1661       uintW req_count;
1662       uintW opt_count;
1663       uintW body_flag;
1664     } fsubr_data_t;
1665     local const fsubr_data_t fsubr_data_tab[] = {
1666       #include "fsubr.c"
1667     };
1668     #undef LISPSPECFORM
1669     var const fsubr_t* ptr1 = (const fsubr_t *)&fsubr_tab; /* traverse fsubr_tab */
1670     var const fsubr_data_t * ptr2 = &fsubr_data_tab[0]; /* traverse fsubr_data_tab */
1671     var uintC count = fsubr_count;
1672     while (count--) {
1673       var object sym = fsubr_name(ptr2);
1674       var object obj = allocate_fsubr();
1675       TheFsubr(obj)->name = sym;
1676       TheFsubr(obj)->argtype =
1677         fixnum((uintW)fsubr_argtype(ptr2->req_count,ptr2->opt_count,
1678                                     (fsubr_body_t)(ptr2->body_flag)));
1679       TheFsubr(obj)->function = (void*)(*ptr1);
1680       Symbol_function(sym) = obj;
1681       ptr1++; ptr2++;
1682     }
1683   }
1684   {                             /* enter SUBRs: */
1685     var subr_t* ptr = (subr_t*)((char*)&subr_tab+varobjects_misaligned); /* traverse subr_tab */
1686     var uintC count = subr_count;
1687     while (count--) {
1688       Symbol_function(ptr->name) = subr_tab_ptr_as_object(ptr);
1689       ptr++;
1690     }
1691   }
1692 }
1693 /* assign values to constants/variables: */
init_symbol_values(void)1694 local void init_symbol_values (void) {
1695   /* helper macro: constant := value+1 */
1696   #define define_constant_UL1(symbol,value)                    \
1697     do { var object x =            /* value+1 as integer */    \
1698            (((uintV)(value) < (uintV)(vbitm(oint_data_len)-1)) \
1699             ? fixnum(value+1)                                  \
1700             : I_1_plus_I(UV_to_I(value))                       \
1701            );                                                  \
1702           define_constant(symbol,x);                           \
1703     } while(0)
1704   /* common: */
1705   define_constant(S(nil),S(nil)); /* NIL := NIL */
1706   define_constant(S(t),S(t));     /* T := T */
1707   define_variable(S(gc_statistics_star),Fixnum_minus1); /* SYS::*GC-STATISTICS* := -1 */
1708   /* for EVAL/CONTROL: */
1709   define_constant_UL1(S(lambda_parameters_limit),lp_limit_1); /* LAMBDA-PARAMETERS-LIMIT := lp_limit_1 + 1 */
1710   define_constant_UL1(S(call_arguments_limit),ca_limit_1); /* CALL-ARGUMENTS-LIMIT := ca_limit_1 + 1 */
1711   define_constant(S(multiple_values_limit),fixnum(mv_limit)); /* MULTIPLE-VALUES-LIMIT := mv_limit */
1712   define_constant(S(jmpbuf_size),fixnum(jmpbufsize)); /* SYS::*JMPBUF-SIZE* := size of a jmp_buf */
1713   define_constant(S(big_endian),(BIG_ENDIAN_P ? T : NIL)); /* SYS::*BIG-ENDIAN* := NIL resp. T */
1714   define_variable(S(macroexpand_hook),L(funcall)); /* *MACROEXPAND-HOOK* := #'FUNCALL */
1715   define_variable(S(evalhookstar),NIL);            /* *EVALHOOK* */
1716   define_variable(S(applyhookstar),NIL);           /* *APPLYHOOK* */
1717   /* for HASHTABL: */
1718   define_variable(S(eq_hashfunction),S(fasthash_eq)); /* EXT:*EQ-HASHFUNCTION* := 'EXT:FASTHASH-EQ */
1719   define_variable(S(eql_hashfunction),S(fasthash_eql)); /* EXT:*EQL-HASHFUNCTION* := 'EXT:FASTHASH-EQL */
1720   define_variable(S(equal_hashfunction),S(fasthash_equal)); /* EXT:*EQUAL-HASHFUNCTION* := 'EXT:FASTHASH-EQUAL */
1721   define_variable(S(warn_on_hashtable_needing_rehash_after_gc),NIL); /* CUSTOM:*WARN-ON-HASHTABLE-NEEDING-REHASH-AFTER-GC* := NIL */
1722   /* for PACKAGE: */
1723   define_variable(S(packagestar),Car(O(all_packages))); /* *PACKAGE* := '#<PACKAGE LISP> */
1724   /* for SYMBOL: */
1725   define_variable(S(gensym_counter),Fixnum_1); /* *GENSYM-COUNTER* := 1 */
1726   /* for PATHNAME: */
1727   define_variable(S(merge_pathnames_ansi),NIL); /* *MERGE-PATHNAMES-ANSI* */
1728   /* for LISPARIT: */
1729   init_arith();     /* defines the following: */
1730   /* define_variable(S(pi),);                      - PI
1731    define_constant(S(most_positive_fixnum),);    - MOST-POSITIVE-FIXNUM
1732    define_constant(S(most_negative_fixnum),);    - MOST-NEGATIVE-FIXNUM
1733    define_constant(S(most_positive_short_float),); - MOST-POSITIVE-SHORT-FLOAT
1734    define_constant(S(least_positive_short_float),); - LEAST-POSITIVE-SHORT-FLOAT
1735    define_constant(S(least_negative_short_float),); - LEAST-NEGATIVE-SHORT-FLOAT
1736    define_constant(S(most_negative_short_float),); - MOST-NEGATIVE-SHORT-FLOAT
1737    define_constant(S(most_positive_single_float),); - MOST-POSITIVE-SINGLE-FLOAT
1738    define_constant(S(least_positive_single_float),); - LEAST-POSITIVE-SINGLE-FLOAT
1739    define_constant(S(least_negative_single_float),); - LEAST-NEGATIVE-SINGLE-FLOAT
1740    define_constant(S(most_negative_single_float),); - MOST-NEGATIVE-SINGLE-FLOAT
1741    define_constant(S(most_positive_double_float),); - MOST-POSITIVE-DOUBLE-FLOAT
1742    define_constant(S(least_positive_double_float),); - LEAST-POSITIVE-DOUBLE-FLOAT
1743    define_constant(S(least_negative_double_float),); - LEAST-NEGATIVE-DOUBLE-FLOAT
1744    define_constant(S(most_negative_double_float),); - MOST-NEGATIVE-DOUBLE-FLOAT
1745    define_variable(S(most_positive_long_float),); - MOST-POSITIVE-LONG-FLOAT
1746    define_variable(S(least_positive_long_float),); - LEAST-POSITIVE-LONG-FLOAT
1747    define_variable(S(least_negative_long_float),); - LEAST-NEGATIVE-LONG-FLOAT
1748    define_variable(S(most_negative_long_float),); - MOST-NEGATIVE-LONG-FLOAT
1749    define_variable(S(least_positive_normalized_long_float),); - LEAST-POSITIVE-NORMALIZED-LONG-FLOAT
1750    define_variable(S(least_negative_normalized_long_float),); - LEAST-NEGATIVE-NORMALIZED-LONG-FLOAT
1751    define_constant(S(short_float_epsilon),);     - SHORT-FLOAT-EPSILON
1752    define_constant(S(single_float_epsilon),);    - SINGLE-FLOAT-EPSILON
1753    define_constant(S(double_float_epsilon),);    - DOUBLE-FLOAT-EPSILON
1754    define_variable(S(long_float_epsilon),);      - LONG-FLOAT-EPSILON
1755    define_constant(S(short_float_negative_epsilon),); - SHORT-FLOAT-NEGATIVE-EPSILON
1756    define_constant(S(single_float_negative_epsilon),); - SINGLE-FLOAT-NEGATIVE-EPSILON
1757    define_constant(S(double_float_negative_epsilon),); - DOUBLE-FLOAT-NEGATIVE-EPSILON
1758    define_variable(S(long_float_negative_epsilon),); - LONG-FLOAT-NEGATIVE-EPSILON
1759    define_variable(S(read_default_float_format),); - *READ-DEFAULT-FLOAT-FORMAT*
1760    define_variable(S(random_state),);            - *RANDOM-STATE*
1761    for ARRAY: */
1762   define_constant(S(array_total_size_limit),fixnum(arraysize_limit_1+1)); /* ARRAY-TOTAL-SIZE-LIMIT := arraysize_limit_1 + 1 */
1763   define_constant(S(array_dimension_limit),fixnum(arraysize_limit_1+1)); /* ARRAY-DIMENSION-LIMIT := arraysize_limit_1 + 1 */
1764   define_constant_UL1(S(string_dimension_limit),stringsize_limit_1); /* SYSTEM::STRING-DIMENSION-LIMIT := stringsize_limit_1 + 1 */
1765   define_constant(S(array_rank_limit),fixnum(arrayrank_limit_1+1)); /* ARRAY-RANK-LIMIT := arrayrank_limit_1 + 1 */
1766   /* for CHARSTRG: */
1767   define_constant(S(char_cod_limit),fixnum(char_code_limit)); /* CHAR-CODE-LIMIT */
1768   define_constant(S(base_char_cod_limit),fixnum(base_char_code_limit)); /* BASE-CHAR-CODE-LIMIT */
1769   define_variable(S(coerce_fixnum_char_ansi),NIL); /* LISP:*COERCE-FIXNUM-CHAR-ANSI* */
1770   /* for SEQUENCE: */
1771   define_variable(S(sequence_count_ansi),NIL); /* LISP:*SEQUENCE-COUNT-ANSI* */
1772   /* for DEBUG: */
1773   define_variable(S(plus),NIL);             /* + */
1774   define_variable(S(plus2),NIL);            /* ++ */
1775   define_variable(S(plus3),NIL);            /* +++ */
1776   define_variable(S(minus),NIL);            /* - */
1777   define_variable(S(star),NIL);             /* * */
1778   define_variable(S(star2),NIL);            /* ** */
1779   define_variable(S(star3),NIL);            /* *** */
1780   define_variable(S(slash),NIL);            /* / */
1781   define_variable(S(slash2),NIL);           /* // */
1782   define_variable(S(slash3),NIL);           /* /// */
1783   define_variable(S(driverstar),NIL);       /* *DRIVER* := NIL */
1784   define_variable(S(break_driver),NIL);     /* *BREAK-DRIVER* := NIL */
1785   define_variable(S(break_count),Fixnum_0); /* SYS::*BREAK-COUNT* := 0 */
1786   define_variable(S(recurse_count_standard_output),Fixnum_0); /* SYS::*RECURSE-COUNT-STANDARD-OUTPUT* := 0 */
1787   define_variable(S(recurse_count_debug_io),Fixnum_0); /* SYS::*RECURSE-COUNT-DEBUG-IO* := 0 */
1788   /* for STREAM:
1789    later: init_streamvars(); - defines the following:
1790    define_variable(S(standard_input),);          - *STANDARD-INPUT*
1791    define_variable(S(standard_output),);         - *STANDARD-OUTPUT*
1792    define_variable(S(error_output),);            - *ERROR-OUTPUT*
1793    define_variable(S(query_io),);                - *QUERY-IO*
1794    define_variable(S(debug_io),);                - *DEBUG-IO*
1795    define_variable(S(terminal_io),);             - *TERMINAL-IO*
1796    define_variable(S(trace_output),);            - *TRACE-OUTPUT*
1797    define_variable(S(keyboard_input),);          - *KEYBOARD-INPUT* */
1798   define_variable(S(default_pathname_defaults),unbound); /* *DEFAULT-PATHNAME-DEFAULTS* */
1799   /* for IO: */
1800   define_variable(S(completion),NIL); /* CUSTOM:*COMPLETION* */
1801   init_reader();                /* defines the following:
1802    define_variable(S(read_base),);               - *READ-BASE* := 10
1803    define_variable(S(read_suppress),);           - *READ-SUPPRESS* := NIL
1804    define_variable(S(read_eval),);               - *READ-EVAL* := T
1805    define_variable(S(readtablestar),);           - *READTABLE* */
1806   define_variable(S(read_preserve_whitespace),unbound); /* SYS::*READ-PRESERVE-WHITESPACE* */
1807   define_variable(S(read_recursive_p),unbound); /* SYS::*READ-RECURSIVE-P* */
1808   define_variable(S(read_reference_table),unbound); /* SYS::*READ-REFERENCE-TABLE* */
1809   define_variable(S(backquote_level),unbound); /* SYS::*BACKQUOTE-LEVEL* */
1810   define_variable(S(compiling),NIL); /* SYS::*COMPILING* ;= NIL */
1811   define_variable(S(print_case),S(Kupcase)); /* *PRINT-CASE* := :UPCASE */
1812   define_variable(S(print_level),NIL);       /* *PRINT-LEVEL* := NIL */
1813   define_variable(S(print_length),NIL);      /* *PRINT-LENGTH* := NIL */
1814   define_variable(S(print_gensym),T);        /* *PRINT-GENSYM* := T */
1815   define_variable(S(print_escape),T);        /* *PRINT-ESCAPE* := T */
1816   define_variable(S(print_radix),NIL);       /* *PRINT-RADIX* := NIL */
1817   define_variable(S(print_base),fixnum(10)); /* *PRINT-BASE* := 10 */
1818   define_variable(S(print_array),T);         /* *PRINT-ARRAY* := T */
1819   define_variable(S(print_circle),NIL);      /* *PRINT-CIRCLE* := NIL */
1820   define_variable(S(print_pretty),NIL);      /* *PRINT-PRETTY* := NIL */
1821   define_variable(S(print_closure),NIL);  /* *PRINT-CLOSURE* := NIL */
1822   define_variable(S(print_readably),NIL); /* *PRINT-READABLY* := NIL */
1823   define_variable(S(print_lines),NIL);    /* *PRINT-LINES* := NIL */
1824   define_variable(S(print_miser_width),NIL); /* *PRINT-MISER-WIDTH* := NIL */
1825   define_variable(S(prin_line_prefix),unbound); /* *PRIN-LINE-PREFIX* */
1826   define_variable(S(prin_miserp),unbound);      /* *PRIN-MISERP* */
1827   define_variable(S(prin_pprinter),unbound);    /* *PRIN-PPRINTER* */
1828   define_variable(S(prin_indentation),unbound); /* *PRIN-INDENTATION* */
1829   define_variable(S(print_pprint_dispatch),NIL); /* *PRINT-PPRINT-DISPATCH* := NIL */
1830   define_variable(S(print_right_margin),NIL); /* *PRINT-RIGHT-MARGIN* := NIL */
1831   define_variable(S(print_rpars),NIL);        /* *PRINT-RPARS* := NIL */
1832   define_variable(S(print_indent_lists),fixnum(1)); /* *PRINT-INDENT-LISTS* := 1 */
1833   define_variable(S(print_pretty_fill),NIL); /* *PRINT-PRETTY-FILL* := NIL */
1834   define_variable(S(print_circle_table),unbound); /* SYS::*PRINT-CIRCLE-TABLE* */
1835   define_variable(S(print_symbol_package_prefix_shortest),NIL); /* CUSTOM:*PRINT-SYMBOL-PACKAGE-PREFIX-SHORTEST* */
1836   define_variable(S(prin_level),unbound);  /* SYS::*PRIN-LEVEL* */
1837   define_variable(S(prin_lines),unbound);  /* SYS::*PRIN-LINES* */
1838   define_variable(S(prin_stream),unbound); /* SYS::*PRIN-STREAM* */
1839   define_variable(S(prin_linelength),fixnum(79)); /* SYS::*PRIN-LINELENGTH* := 79 (preliminarily) */
1840   define_variable(S(prin_l1),unbound);            /* SYS::*PRIN-L1* */
1841   define_variable(S(prin_lm),unbound);            /* SYS::*PRIN-LM* */
1842   define_variable(S(prin_rpar),unbound);          /* SYS::*PRIN-RPAR* */
1843   define_variable(S(prin_traillength),unbound); /* SYS::*PRIN-TRAILLENGTH* */
1844   define_variable(S(prin_prev_traillength),unbound); /* SYS::*PRIN-PREV-TRAILLENGTH* */
1845   define_variable(S(prin_jblocks),unbound);   /* SYS::*PRIN-JBLOCKS* */
1846   define_variable(S(prin_jbstrings),unbound); /* SYS::*PRIN-JBSTRINGS* */
1847   define_variable(S(prin_jbmodus),unbound);   /* SYS::*PRIN-JBMODUS* */
1848   define_variable(S(prin_jblpos),unbound);    /* SYS::*PRIN-JBLPOS* */
1849   define_variable(S(load_forms),NIL); /* SYS::*LOAD-FORMS* */
1850   define_variable(S(terminal_read_open_object),unbound); /* SYS::*TERMINAL-READ-OPEN-OBJECT* */
1851   define_variable(S(terminal_read_stream),unbound); /* SYS::*TERMINAL-READ-STREAM* */
1852   define_variable(S(pprint_first_newline),T); /* CUSTOM:*PPRINT-FIRST-NEWLINE* */
1853   define_variable(S(print_pathnames_ansi),NIL); /* CUSTOM:*PRINT-PATHNAMES-ANSI* */
1854   define_variable(S(print_space_char_ansi),NIL); /* CUSTOM:*PRINT-SPACE-CHAR-ANSI* */
1855   define_variable(S(print_empty_arrays_ansi),NIL); /* CUSTOM:*PRINT-EMPTY-ARRAYS-ANSI* */
1856   define_variable(S(print_unreadable_ansi),NIL); /* CUSTOM:*PRINT-UNREADABLE-ANSI* */
1857   define_variable(S(parse_namestring_ansi),NIL); /* CUSTOM:*PARSE-NAMESTRING-ANSI* */
1858   define_variable(S(reopen_open_file),S(error)); /* CUSTOM:*REOPEN-OPEN-FILE* */
1859  #ifdef PATHNAME_NOEXT
1860   define_variable(S(parse_namestring_dot_file),S(Ktype)); /* CUSTOM:*PARSE-NAMESTRING-DOT-FILE* */
1861  #endif
1862   define_variable(S(deftype_depth_limit),NIL); /* CUSTOM:*DEFTYPE-DEPTH-LIMIT* */
1863  #if defined(WIN32_NATIVE) || defined(UNIX_CYGWIN)
1864   define_variable(S(device_prefix),NIL); /* CUSTOM:*DEVICE-PREFIX* */
1865  #endif
1866   /* for EVAL: */
1867   define_variable(S(evalhookstar),NIL);  /* *EVALHOOK* := NIL */
1868   define_variable(S(applyhookstar),NIL); /* *APPLYHOOK* := NIL */
1869   /* for MISC: */
1870   define_constant(S(internal_time_units_per_second), /* INTERNAL-TIME-UNITS-PER-SECOND */
1871                   fixnum(ticks_per_second) ); /* := 200 resp. 1000000 */
1872   /* for PREDTYPE: */
1873   define_variable(S(recurse_count_gc_statistics),Fixnum_0); /* SYS::*RECURSE-COUNT-GC-STATISTICS* := 0 */
1874   /* for ERROR: */
1875   define_variable(S(use_clcs),NIL); /* SYS::*USE-CLCS* := NIL */
1876   define_variable(S(recursive_error_count),Fixnum_0); /* SYS::*RECURSIVE-ERROR-COUNT* := 0 */
1877   define_variable(S(error_handler),NIL);  /* *ERROR-HANDLER* := NIL */
1878   /* for SPVW: */
1879   define_variable(S(init_hooks),NIL); /* CUSTOM::*INIT-HOOKS* := NIL */
1880   define_variable(S(fini_hooks),NIL); /* CUSTOM::*FINI-HOOKS* := NIL */
1881   define_variable(S(quiet),NIL);      /* SYS::*QUIET* := NIL */
1882   define_variable(S(norc),NIL);       /* SYS::*NORC* := NIL */
1883   define_variable(S(script),T);       /* SYS::*SCRIPT* := T */
1884   define_variable(S(image_doc),NIL);  /* SYS::*IMAGE-DOC* := NIL */
1885   define_variable(S(args),NIL);       /* EXT:*ARGS* := NIL */
1886   define_variable(S(load_compiling),NIL); /* *LOAD-COMPILING* := NIL */
1887   define_variable(S(load_verbose),T); /* *LOAD-VERBOSE* := T */
1888   define_variable(S(load_print),NIL); /* *LOAD-PRINT* := NIL */
1889   define_variable(S(load_echo),NIL); /* *LOAD-ECHO* := NIL */
1890   define_variable(S(load_paths),NIL); /* *LOAD-PATHS* := NIL */
1891   define_variable(S(compile_print),NIL); /* *COMPILE-PRINT* := NIL */
1892   define_variable(S(compile_verbose),T); /* *COMPILE-VERBOSE* := T */
1893   define_variable(S(saveinitmem_verbose),T); /* *SAVEINITMEM-VERBOSE* := T */
1894   define_variable(S(report_error_print_backtrace),NIL); /* *REPORT-ERROR-PRINT-BACKTRACE* := NIL */
1895   define_variable(S(loop_ansi),NIL); /* CUSTOM:*LOOP-ANSI* := NIL */
1896   define_variable(S(defun_accept_specialized_lambda_list),NIL); /* CUSTOM:*DEFUN-ACCEPT-SPECIALIZED-LAMBDA-LIST* := NIL */
1897   /* for FOREIGN: */
1898  #ifdef DYNAMIC_FFI
1899   define_constant(S(fv_flag_readonly),fixnum(fv_readonly)); /* FFI::FV-FLAG-READONLY */
1900   define_constant(S(fv_flag_malloc_free),fixnum(fv_malloc)); /* FFI::FV-FLAG-MALLOC-FREE */
1901   define_constant(S(ff_flag_alloca),fixnum(ff_alloca)); /* FFI::FF-FLAG-ALLOCA */
1902   define_constant(S(ff_flag_malloc_free),fixnum(ff_malloc)); /* FFI::FF-FLAG-MALLOC-FREE */
1903   define_constant(S(ff_flag_out),fixnum(ff_out)); /* FFI::FF-FLAG-OUT */
1904   define_constant(S(ff_flag_in_out),fixnum(ff_inout)); /* FFI::FF-FLAG-IN-OUT */
1905   define_constant(S(ff_language_asm),fixnum(ff_lang_asm)); /* FFI::FF-LANGUAGE-ASM */
1906   define_constant(S(ff_language_c),fixnum(ff_lang_c)); /* FFI::FF-LANGUAGE-C */
1907   define_constant(S(ff_language_ansi_c),fixnum(ff_lang_ansi_c)); /* FFI::FF-LANGUAGE-ANSI-C */
1908   define_constant(S(ff_language_stdcall),fixnum(ff_lang_stdcall)); /* FFI::FF-LANGUAGE-STDCALL */
1909  #endif
1910   /* for DISASSEM.LISP: */
1911  #ifdef UNIX
1912   /* SYS::*DISASSEMBLE-USE-LIVE-PROCESS* is system dependent:
1913    We use it where possible, because it allows peeking into dynamically
1914    loaded shared libraries.
1915    On FreeBSD 4.0, if set to T, gdb stops the clisp process.
1916    On Linux ppc64 & MacOSX, if set to T, clisp hangs until C-c.
1917    On Woe32, the debugging APIs are flawed, the Cygwin developers say. */
1918  #if defined(UNIX_FREEBSD) || defined(UNIX_MACOSX) || defined(UNIX_CYGWIN) || (defined(UNIX_LINUX) && defined(POWERPC))
1919   define_variable(S(disassemble_use_live_process),NIL);
1920   #else
1921   define_variable(S(disassemble_use_live_process),T);
1922   #endif
1923  #endif
1924   /* for PATHNAME: */
1925   { /* SYS::*LOGICAL-PATHNAME-TRANSLATIONS* :=
1926       (MAKE-HASH-TABLE :KEY-TYPE 'STRING :VALUE-TYPE 'LIST :TEST #'EQUALP) */
1927     pushSTACK(S(Ktest)); pushSTACK(L(equalp)); funcall(L(make_hash_table),2);
1928     define_variable(S(logpathname_translations),value1);
1929   }
1930   O(empty_logical_pathname) = allocate_logpathname();
1931   /* initialize *DEFAULT-PATHNAME-DEFAULTS* preliminarily: */
1932   define_variable(S(default_pathname_defaults),allocate_pathname());
1933   define_variable(S(user_lib_directory),NIL);
1934  #undef define_constant_UL1
1935 }
1936 /* create other objects and fill object table: */
init_object_tab(void)1937 local void init_object_tab (void) {
1938   /* table with initialization strings: */
1939   local var const char * const object_initstring_tab [] = {
1940     #define LISPOBJ LISPOBJ_C
1941     #include "constobj.c"
1942     #undef LISPOBJ
1943   };
1944   {                             /* initialize *FEATURES* : */
1945     var const char * features_initstring =
1946       "(:CLISP :ANSI-CL :COMMON-LISP :LISP=CL :INTERPRETER :LOGICAL-PATHNAMES"
1947      #ifdef DEBUG_COMPILER
1948       " :CLISP-DEBUG"
1949      #endif
1950      #ifdef MULTITHREAD
1951       " :MT"
1952      #endif
1953      #ifdef SOCKET_STREAMS
1954       " :SOCKETS"
1955      #endif
1956      #ifdef GENERIC_STREAMS
1957       " :GENERIC-STREAMS"
1958      #endif
1959      #ifdef SCREEN
1960       " :SCREEN"
1961      #endif
1962      #ifdef DYNAMIC_FFI
1963       " :FFI"
1964      #endif
1965      #ifdef GNU_GETTEXT
1966       " :GETTEXT"
1967      #endif
1968      #ifdef ENABLE_UNICODE
1969       " :UNICODE"
1970      #endif
1971      #if (base_char_code_limit == char_code_limit)
1972       " :BASE-CHAR=CHARACTER"
1973      #endif
1974      #ifdef WIDE_HARD
1975       " :WORD-SIZE=64"
1976      #endif
1977      #ifdef PC386
1978       " :PC386"
1979      #endif
1980      #ifdef UNIX
1981       " :UNIX"
1982      #endif
1983      #ifdef UNIX_MACOSX
1984       " :MACOS"
1985      #endif
1986      #ifdef UNIX_CYGWIN
1987       " :CYGWIN"
1988      #endif
1989      #ifdef UNIX_BEOS
1990       " :BEOS"
1991      #endif
1992      #ifdef UNIX_HAIKU
1993       " :HAIKU"
1994      #endif
1995      #ifdef WIN32
1996       " :WIN32"
1997      #endif
1998       ")";
1999     pushSTACK(ascii_to_string(features_initstring));
2000     var object list = (funcall(L(read_from_string),1), value1);
2001     define_variable(S(features),list); /* *FEATURES* */
2002   }
2003   {                             /* read objects from the strings: */
2004     var gcv_object_t* objptr = (gcv_object_t*)&object_tab; /* traverse object_tab */
2005     var const char * const * stringptr = &object_initstring_tab[0]; /* traverse string table */
2006     var uintC count = object_count;
2007     while (count--) {
2008       var const char * string = *stringptr++;
2009       if (*string == '@') {
2010         /* no READ-FROM-STRING for LISPOBJ_L && GNU_GETTEXT */
2011         *objptr = asciz_to_string(&string[1],O(internal_encoding));
2012       } else if (!(string[0] == '.' && string[1] == 0)) {
2013         pushSTACK(asciz_to_string(string,O(internal_encoding))); /* string */
2014         funcall(L(make_string_input_stream),1); /* pack into stream */
2015         pushSTACK(value1);
2016         var object obj = stream_read(&STACK_0,NIL,NIL); /* read object */
2017         skipSTACK(1);
2018         *objptr = obj; /* store (except ".") */
2019       }
2020       objptr++;
2021     }
2022   }
2023   /* initialize software_type */
2024   O(software_type) = built_flags();
2025   /* build toplevel-declaration-environment */
2026   Car(O(top_decl_env)) = O(declaration_types);
2027   /* Initialize compiled closures. */
2028   init_cclosures();
2029 }
2030 /* manual initialization of all LISP-data: */
initmem(void)2031 local void initmem (void) {
2032   init_symbol_tab_1();          /* initialize symbol_tab */
2033   init_object_tab_1();          /* initialize object_tab */
2034   init_other_modules_1();       /* initialize other modules coarsely */
2035   {
2036     aktenv.var_env = NIL; aktenv.fun_env = NIL; aktenv.block_env = NIL;
2037     aktenv.go_env = NIL; aktenv.decl_env = NIL;
2038   }
2039   /* Now the tables are coarsely initialized,
2040    nothing can happen at GC.
2041    finish initialization of subr_tab: */
2042   init_subr_tab_2();
2043   /* initialize packages: */
2044 #ifdef MULTITHREAD
2045   /* initialize O(all_mutexes) since every packages creates ones that
2046      is added to it */
2047   O(all_mutexes) = NIL;
2048 #endif
2049   init_packages();
2050   init_encodings_1(); /* init some encodings (utf_8 for init_symbol_tab_2) */
2051   /* finish initialization of symbol_tab: */
2052   init_symbol_tab_2();
2053   init_encodings_2();           /* init the rest of encodings */
2054   /* enter SUBRs/FSUBRs into their symbols: */
2055   init_symbol_functions();
2056   /* constants/variables: enter value into the symbols: */
2057   init_symbol_values();
2058   /* create other objects: */
2059   init_object_tab();
2060 }
2061 /* initialization of the other, not yet initialized modules: */
2062 local void init_other_modules_2 (void);
init_module_2(module_t * module)2063 local void init_module_2 (module_t* module) {
2064   /* pre-initialize subr_tab, object_tab, so that GC becomes possible: */
2065   if (*module->stab_size > 0) {
2066     var subr_t* ptr = module->stab; /* traverse subr_tab */
2067     var uintC count = *module->stab_size;
2068     do {
2069       ptr->GCself = subr_tab_ptr_as_object(ptr);
2070       ptr->name = NIL; ptr->keywords = NIL;
2071       ptr++;
2072     } while (--count);
2073   }
2074   if (*module->otab_size > 0) {
2075     var gcv_object_t* ptr = module->otab; /* traverse object_tab */
2076     var uintC count = *module->otab_size;
2077     do { *ptr++ = NIL; } while(--count);
2078   }
2079   module->initialized = true; /* GC can see this subr_tab, object_tab */
2080   /* enter Subr-symbols: */
2081   if (*module->stab_size > 0) {
2082     var subr_t* subr_ptr = module->stab;
2083     var const subr_initdata_t* init_ptr = module->stab_initdata;
2084     var uintC count = *module->stab_size;
2085     do {
2086       var const char* packname = init_ptr->packname;
2087       var object symname = asciz_to_string(init_ptr->symname,O(internal_encoding));
2088       var object symbol;
2089       if (packname==NULL) {
2090         symbol = make_symbol(symname);
2091       } else {
2092         pushSTACK(symname);
2093         var object pack =
2094           find_package(asciz_to_string(packname,O(internal_encoding)));
2095         if (nullp(pack)) {      /* package not found? */
2096           fprintf(stderr,GETTEXTL("module '%s' requires package %s.\n"),
2097                   module->name, packname);
2098           quit_instantly(1);
2099         }
2100         symname = popSTACK();
2101         intern(symname,false,pack,&symbol);
2102       }
2103       subr_ptr->name = symbol;  /* complete Subr */
2104       if (pack_locked_p(Symbol_package(symbol))
2105           && !nullp(Symbol_function(symbol))) { /* package lock error */
2106         fprintf(stderr,GETTEXTL("module '%s' redefines symbol "),module->name);
2107         nobject_out(stderr,symbol);
2108         fprint(stderr,GETTEXTL(" in the locked package "));
2109         nobject_out(stderr,Symbol_package(symbol));
2110         fprint(stderr,GETTEXTL("\nold definition: "));
2111         nobject_out(stderr,Symbol_function(symbol));
2112         fprint(stderr,"\n");
2113         quit_instantly(1);
2114       }
2115       Symbol_function(symbol) = subr_tab_ptr_as_object(subr_ptr); /* define function */
2116       init_ptr++; subr_ptr++;
2117     } while (--count);
2118   }
2119   /* enter objects: */
2120   if (*module->otab_size > 0) {
2121     var gcv_object_t* object_ptr = module->otab;
2122     var const object_initdata_t* init_ptr = module->otab_initdata;
2123     var uintC count = *module->otab_size;
2124     do {
2125       pushSTACK(asciz_to_string(init_ptr->initstring,O(internal_encoding))); /* string */
2126       funcall(L(make_string_input_stream),1); /* pack into stream */
2127       pushSTACK(value1);
2128       *object_ptr = stream_read(&STACK_0,NIL,NIL); /* read object */
2129       skipSTACK(1);
2130       object_ptr++; init_ptr++;
2131     } while (--count);
2132   }
2133   /* call initialization function: */
2134   (*module->initfunction1)(module);
2135 }
init_other_modules_2(void)2136 local void init_other_modules_2 (void) {
2137   var module_t* module;         /* traverse modules */
2138   for_modules(all_other_modules,{
2139     if (!module->initialized)
2140       init_module_2(module);
2141   });
2142 }
2143 
2144 /* print usage */
usage(bool delegating)2145 local void usage (bool delegating) {
2146   printf(PACKAGE_NAME " (" PACKAGE_BUGREPORT ") ");
2147   puts(GETTEXTL("is an ANSI Common Lisp implementation."));
2148   if (delegating) {
2149     printf(GETTEXTL("This image does not process the usual command line arguments.\n"
2150                     "To create a normal image \"myclisp\", please do\n"
2151                     "%s --clisp-x '(ext:saveinitmem \"myclisp\" :executable t :init-function nil)'\n"),program_name);
2152     return;
2153   }
2154   printf(GETTEXTL("Usage:  %s [options] [lispfile [argument ...]]\n"
2155                   " When 'lispfile' is given, it is loaded and '*ARGS*' is set\n"
2156                   " to the list of argument strings. Otherwise, an interactive\n"
2157                   " read-eval-print loop is entered.\n"),program_name);
2158   puts(GETTEXTL("Informative output:"));
2159   puts(GETTEXTL(" -h, --help    - print this help and exit"));
2160   puts(GETTEXTL(" --version     - print the version information"));
2161   puts(GETTEXTL(" --license     - print the licensing information"));
2162   puts(GETTEXTL(" -help-image   - print image-specific help and exit"));
2163   puts(GETTEXTL("Memory image selection:"));
2164   puts(GETTEXTL(" -B lisplibdir - set the installation directory"));
2165  #if defined(UNIX) || defined(WIN32_NATIVE)
2166   puts(GETTEXTL(" -K linkingset - use this executable and memory image"));
2167  #endif
2168   puts(GETTEXTL(" -M memfile    - use this memory image"));
2169   puts(GETTEXTL(" -m size       - memory size (size = nB or nKB or nMB)"));
2170   puts(GETTEXTL("Internationalization:"));
2171   puts(GETTEXTL(" -L language   - set user language"));
2172   puts(GETTEXTL(" -N nlsdir     - NLS catalog directory"));
2173   puts(GETTEXTL(" -Edomain encoding - set encoding"));
2174   puts(GETTEXTL("Interoperability:"));
2175   puts(GETTEXTL(" -q, --quiet, --silent, -v, --verbose - verbosity level:\n"
2176                 "     affects banner, *LOAD-VERBOSE*/*COMPILE-VERBOSE*,\n"
2177                 "     and *LOAD-PRINT*/*COMPILE-PRINT*"));;
2178   puts(GETTEXTL(" -w            - wait for a keypress after program termination"));
2179   puts(GETTEXTL(" -I            - be ILISP-friendly"));
2180   puts(GETTEXTL(" -disable-readline - do not use the gnu readline library"));
2181   puts(GETTEXTL("Startup actions:"));
2182   puts(GETTEXTL(" -ansi         - more ANSI CL compliance"));
2183   puts(GETTEXTL(" -traditional  - traditional (undoes -ansi)"));
2184   puts(GETTEXTL(" -modern       - start in a case-sensitive lowercase-preferring package"));
2185   puts(GETTEXTL(" -p package    - start in the package"));
2186   puts(GETTEXTL(" -C            - set *LOAD-COMPILING* to T"));
2187   puts(GETTEXTL(" -norc         - do not load the user ~/.clisprc file"));
2188   puts(GETTEXTL(" -lp dir       - add dir to *LOAD-PATHS* (can be repeated)"));
2189   puts(GETTEXTL(" -i file       - load initfile (can be repeated)"));
2190   puts(GETTEXTL("Actions:"));
2191   puts(GETTEXTL(" -c [-l] lispfile [-o outputfile] - compile lispfile"));
2192   puts(GETTEXTL(" -x expressions - execute the expressions, then exit"));
2193   puts(GETTEXTL(" Depending on the image, positional arguments can mean:"));
2194   puts(GETTEXTL("   lispscript [argument ...] - load script, then exit"));
2195   puts(GETTEXTL("   [argument ...]            - run the init-function"));
2196   puts(GETTEXTL("  arguments are placed in EXT:*ARGS* as strings."));
2197   puts(GETTEXTL("These actions put CLISP into a batch mode, which is overridden by"));
2198   puts(GETTEXTL(" -on-error action - action can be one of debug, exit, abort, appease"));
2199   puts(GETTEXTL(" -repl            - enter the interactive read-eval-print loop when done"));
2200   puts(GETTEXTL("Default action is an interactive read-eval-print loop."));
2201 }
2202 
2203 /* argument diagnostics */
arg_error(const char * error_message,const char * arg)2204 local void arg_error (const char *error_message, const char *arg) {
2205   if (arg)
2206     fprintf(stderr,"%s: %s: '%s'\n",PACKAGE_NAME,error_message,arg);
2207   else
2208     fprintf(stderr,"%s: %s\n",PACKAGE_NAME,error_message);
2209   fprintf(stderr,GETTEXTL("%s: use '-h' for help"),PACKAGE_NAME);
2210   fprint(stderr,"\n");
2211 }
2212 #define INVALID_ARG(a)    do {                                          \
2213   arg_error(GETTEXTL("invalid argument"),a);                            \
2214   return 1;                                                             \
2215 } while (0)
2216 
2217 /* print license */
print_license(void)2218 local _Noreturn void print_license (void) {
2219   local const char * const license [] = {
2220     PACKAGE_NAME " is free software; you can redistribute and/or modify it\n",
2221     "under the terms of the GNU General Public License as published by\n",
2222     "the Free Software Foundation; either version 2, or (at your option)\n",
2223     "any later version.\n",
2224     "\n",
2225     PACKAGE_NAME " is distributed in the hope that it will be useful,\n",
2226     "but WITHOUT ANY WARRANTY; without even the implied warranty of\n",
2227     "MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.\n",
2228     "See the GNU General Public License for more details.\n",
2229     "\n",
2230     "You should have received a copy of the GNU General Public License\n",
2231     "along with " PACKAGE_NAME ", see file GNU-GPL.\n",
2232     "If not, write to the Free Software Foundation, Inc.,\n",
2233     "51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.\n",
2234     "\n",
2235     "Distribution of Lisp programs meant to run in " PACKAGE_NAME "\n",
2236     "without sources is possible under certain conditions.\n",
2237     "See file COPYRIGHT that came with " PACKAGE_NAME " for details.\n",
2238     "\n",
2239   };
2240   var const char * const * ptr = license;
2241   var uintC count = sizeof(license)/sizeof(license[0]);
2242   pushSTACK(var_stream(S(standard_output),strmflags_wr_ch_B));
2243   fresh_line(&STACK_0); /* The *INIT-HOOKS* might have done output. */
2244   while (count--)
2245     write_sstring(&STACK_0,asciz_to_string(*ptr++,O(internal_encoding)));
2246   skipSTACK(1);
2247   quit_instantly(0);
2248 }
2249 
2250 #include "spvw_calendar.c"
2251 
2252 /* print the banner */
print_banner(void)2253 local void print_banner (void)
2254 { const char * const banner0[] = { /* some lines above 66 characters */
2255   /*|Column 0           |Column 20                                    |Col 66
2256    "012345678901234567890123456789012345678901234567890123456789012345678901"*/
2257     "  i i i i i i i       ooooo    o        ooooooo   ooooo   ooooo\n",
2258     "  I I I I I I I      8     8   8           8     8     o  8    8\n",
2259    "  I  \\ `+' /  I      8         8           8     8        8    8\n",
2260    "   \\  `-+-'  /       8         8           8      ooooo   8oooo\n",
2261     "    `-__|__-'        8         8           8           8  8\n",
2262     "        |            8     o   8           8     o     8  8\n",
2263     "  ------+------       ooooo    8oooooo  ooo8ooo   ooooo   8\n",
2264    };
2265   const char * banner0_hanukka[] = { /* some lines above 66 characters */
2266  /*|Column 0           |Column 20                                    |Col 66
2267   "012345678901234567890123456789012345678901234567890123456789012345678901" */
2268    "        .\n",
2269    ". . . . I . . . .     ooooo    o        ooooooo   ooooo   ooooo\n",
2270    "I I I I I I I I I    8     8   8           8     8     o  8    8\n",
2271   "I I  \\ `+' /  I I    8         8           8     8        8    8\n",
2272   "I  \\  `-+-'  /  I    8         8           8      ooooo   8oooo\n",
2273   " \\  `-__|__-'  /     8         8           8           8  8\n",
2274    "  `--___|___--'      8     o   8           8     o     8  8\n",
2275    "        |             ooooo    8oooooo  ooo8ooo   ooooo   8\n",
2276    "--------+--------\n",
2277   };
2278   char banner0_line0[100];
2279   char banner0_line1[100];
2280   const char * const banner1[] = {
2281    "Copyright (c) Bruno Haible, Michael Stoll 1992-1993\n",
2282    "Copyright (c) Bruno Haible, Marcus Daniels 1994-1997\n",
2283    "Copyright (c) Bruno Haible, Pierpaolo Bernardi, Sam Steingold 1998\n",
2284    "Copyright (c) Bruno Haible, Sam Steingold 1999-2000\n",
2285    "Copyright (c) Sam Steingold, Bruno Haible 2001-2018\n",
2286   };
2287   var int candles = 0;
2288   var uintL offset = (posfixnum_to_V(Symbol_value(S(prin_linelength))) >= 65 ? 0 : 20);
2289   if (offset == 0) {
2290     begin_system_call();
2291     strcpy(banner0_line0,banner0_hanukka[0]);
2292     strcpy(banner0_line1,banner0_hanukka[1]);
2293     var time_t now = time(NULL);
2294     var struct tm now_local;
2295     var struct tm now_gm;
2296     now_local = *(localtime(&now));
2297     now_gm = *(gmtime(&now));
2298     end_system_call();
2299     var sintL dayswest = /* Tage-Differenz, kann als 0,1,-1 angenommen werden */
2300       (now_gm.tm_year < now_local.tm_year ? -1 :
2301        now_gm.tm_year > now_local.tm_year ? 1 :
2302        (now_gm.tm_mon < now_local.tm_mon ? -1 :
2303         now_gm.tm_mon > now_local.tm_mon ? 1 :
2304         (now_gm.tm_mday < now_local.tm_mday ? -1 :
2305          now_gm.tm_mday > now_local.tm_mday ? 1 :
2306          0)));
2307     var sintL hourswest = 24*dayswest
2308       + (sintL)(now_gm.tm_hour - now_local.tm_hour);
2309     var uintL hours_since_1900 = ((unsigned long)now / 3600) - hourswest + 613608;
2310     /* Add 6 because Hebrew days begin in the evening. */
2311     var uintL days_since_1900 = (hours_since_1900 + 6) / 24;
2312     candles = hebrew_calendar_hanukka_candles(days_since_1900);
2313     if (candles > 0) {
2314       banner0_line0[8] = 'i';
2315       if (candles >= 1) {
2316         banner0_line1[16] = 'i';
2317         if (candles >= 2) {
2318           banner0_line1[14] = 'i';
2319           if (candles >= 3) {
2320             banner0_line1[12] = 'i';
2321             if (candles >= 4) {
2322               banner0_line1[10] = 'i';
2323               if (candles >= 5) {
2324                 banner0_line1[6] = 'i';
2325                 if (candles >= 6) {
2326                   banner0_line1[4] = 'i';
2327                   if (candles >= 7) {
2328                     banner0_line1[2] = 'i';
2329                     if (candles >= 8) {
2330                       banner0_line1[0] = 'i';
2331                     }
2332                   }
2333                 }
2334               }
2335             }
2336           }
2337         }
2338       }
2339     }
2340     banner0_hanukka[0] = banner0_line0;
2341     banner0_hanukka[1] = banner0_line1;
2342   }
2343   var const char * const * ptr;
2344   var uintC count;
2345   pushSTACK(var_stream(S(standard_output),strmflags_wr_ch_B)); /* to *STANDARD-OUTPUT* */
2346   fresh_line(&STACK_0); /* The *INIT-HOOKS* might have done output. */
2347   if (candles > 0) {
2348     ptr = banner0_hanukka; count = sizeof(banner0_hanukka)/sizeof(banner0_hanukka[0]);
2349   } else {
2350     ptr = banner0; count = sizeof(banner0)/sizeof(banner0[0]);
2351   }
2352   while (count--)
2353     write_sstring(&STACK_0,asciz_to_string((*ptr++)+offset,O(internal_encoding)));
2354   terpri(&STACK_0);
2355   write_sstring(&STACK_0,asciz_to_string(GETTEXT("Welcome to"),O(internal_encoding)));
2356   write_sstring(&STACK_0,asciz_to_string(" " PACKAGE_STRING " <" PACKAGE_BUGREPORT ">\n\n",O(internal_encoding)));
2357   ptr = banner1; count = sizeof(banner1)/sizeof(banner1[0]);
2358   while (count--)
2359     write_sstring(&STACK_0,asciz_to_string(*ptr++,O(internal_encoding)));
2360   terpri(&STACK_0);
2361   write_sstring(&STACK_0,asciz_to_string(GETTEXT("Type :h and hit Enter for context help."),O(internal_encoding)));
2362   terpri(&STACK_0); terpri(&STACK_0);
2363   finish_output(STACK_0);
2364   skipSTACK(1);
2365 }
2366 
2367 typedef enum {
2368   ON_ERROR_DEFAULT,
2369   ON_ERROR_DEBUG,
2370   ON_ERROR_ABORT,
2371   ON_ERROR_APPEASE,
2372   ON_ERROR_EXIT
2373 } on_error_t;
2374 
2375 /* install the appropriate global handglers
2376  can trigger GC */
install_global_handlers(on_error_t on_error)2377 local maygc void install_global_handlers (on_error_t on_error)
2378 {
2379   /* do nothing if there is no memory image */
2380   if (!boundp(Symbol_function(S(set_global_handler)))) return;
2381   switch (on_error) {
2382     case ON_ERROR_EXIT: {
2383       pushSTACK(S(interrupt_condition));
2384       pushSTACK(Symbol_function(S(exitunconditionally)));
2385       funcall(S(set_global_handler),2);
2386       pushSTACK(S(serious_condition));
2387       pushSTACK(Symbol_function(S(exitonerror)));
2388       funcall(S(set_global_handler),2);
2389     } goto appease;
2390     case ON_ERROR_ABORT: {
2391       pushSTACK(S(serious_condition));
2392       pushSTACK(Symbol_function(S(abortonerror)));
2393       funcall(S(set_global_handler),2);
2394     } /*FALLTHROUGH*/
2395     case ON_ERROR_APPEASE: appease: {
2396       pushSTACK(S(error)); pushSTACK(Symbol_function(S(appease_cerror)));
2397       funcall(S(set_global_handler),2); return;
2398     }
2399     case ON_ERROR_DEBUG: return;
2400     default: NOTREACHED;
2401   }
2402 }
2403 
2404 /* Very early initializations. */
init_lowest_level(char * argv[])2405 local inline void init_lowest_level (char* argv[]) {
2406  #ifdef WIN32_NATIVE
2407   init_win32();
2408  #endif
2409   begin_system_call();
2410   find_executable(argv[0]);
2411   end_system_call();
2412 }
2413 
2414 #if defined(GNU_READLINE) && HAVE_DECL_RL_DEPREP_TERM_FUNCTION
2415  #include <readline/readline.h>
2416 #endif
2417 
2418 /* Very late de-initializations, */
fini_lowest_level(void)2419 local inline void fini_lowest_level (void) {
2420  #ifdef WIN32_NATIVE
2421   done_win32();
2422  #endif
2423  #if defined(UNIX)
2424   terminal_sane();            /* switch terminal again in normal mode */
2425  #endif
2426  #if defined(GNU_READLINE) && HAVE_DECL_RL_DEPREP_TERM_FUNCTION
2427   if (rl_deprep_term_function)
2428     (*rl_deprep_term_function) ();
2429  #endif
2430 }
2431 
2432 /* There are three type of command-line options:
2433  - Those which set global variables,
2434  - Those which set parameters needed to initialize C I/O.
2435  - Those which set parameters needed to initialize Lisp memory,
2436  - Those which set parameters that determine the actions to be executed. */
2437 
2438 /* Global variables. */
2439 global const char* locale_encoding = NULL; /* GNU canonical name of locale encoding */
2440 global const char* argv_encoding_misc = NULL; /* override for *misc-encoding* */
2441 global const char* argv_encoding_file = NULL; /* ... for *default-file-encoding* */
2442 #ifndef CONSTANT_PATHNAME_ENCODING
2443 global const char* argv_encoding_pathname = NULL; /* ... for *pathname-encoding* */
2444 #endif
2445 global const char* argv_encoding_terminal = NULL; /* ... for *terminal-encoding* */
2446 global const char* argv_encoding_foreign = NULL; /* ... for *foreign-encoding* */
2447 
2448 /* Parameters needed to initialize C I/O. */
2449 struct argv_init_c {
2450   const char* argv_language;
2451   const char* argv_localedir;
2452 };
2453 
2454 /* Parameters needed to initialize Lisp memory. */
2455 struct argv_initparams {
2456   uintM argv_memneed;
2457   double argv_nextgc_factor;
2458   const char* argv_memfile;
2459 };
2460 
2461 /* Parameters that determine the actions to be executed. */
2462 typedef enum {
2463   action_normal,     /* normal processing: load mem-file etc. */
2464   action_mfihash,    /* option -memfile-hash */
2465   action_mfihash_of, /* option -memfile-hash-of */
2466   action_mfcompat    /* option -memfile-compatible */
2467 } main_action_t;
2468 typedef struct { const char* input_file; const char* output_file; } argv_compile_file_t;
2469 struct argv_actions {
2470   main_action_t argv_main_action;
2471   const char* argv_memfile;
2472   int argv_verbose; /* verbosity level */
2473   const char* argv_lisplibdir;
2474   bool argv_developer;
2475   bool argv_load_compiling;
2476   uintL argv_load_paths_count;
2477   argv_compile_file_t* argv_load_paths; /* share space with -c args */
2478   uintL argv_init_filecount;
2479   const char **argv_init_files;
2480   bool argv_compile;
2481   bool argv_compile_listing;
2482   bool argv_norc;
2483   on_error_t argv_on_error;
2484   uintL argv_compile_filecount;
2485   argv_compile_file_t* argv_compile_files;
2486   const char* argv_package;
2487   int argv_ansi;               /* 0: default; 1: ANSI; 2: traditional */
2488   bool argv_modern;
2489   bool argv_repl;
2490   uintL argv_expr_count;
2491   const char **argv_exprs;      /* stored backwards! */
2492   const char* argv_execute_file;
2493   const char* const* argv_execute_args;
2494   uintL argv_execute_arg_count;
2495   bool argv_batchmode_p;
2496   bool argv_license;
2497   bool argv_wait_keypress;
2498   bool argv_help_image;
2499 };
2500 
2501 /* parses the rest of an option, that specifies a byte-size.
2502    also checks, if certain boundaries are obeyed. */
size_arg(const char * arg,const char * docstring,uintM * ret,uintM limit_low,uintM limit_high)2503 local inline int size_arg (const char *arg, const char *docstring, uintM *ret,
2504                            uintM limit_low, uintM limit_high) {
2505   /* arg should consist of a few decimal places, then
2506      maybe K/M/G/T/P, then maybe B or W: [0-9]+[KMGTP]?[BW]? */
2507   uintM val = 0;
2508   while ((*arg >= '0') && (*arg <= '9'))
2509     val = 10*val + (uintM)(*arg++ - '0');
2510   switch (*arg) {
2511     case 'k': case 'K':         /* in kilobytes */
2512       val <<= 10; arg++; break; /* *= 1024 */
2513     case 'm': case 'M':         /* in megabytes */
2514       val <<= 20; arg++; break; /* *= 1024*1024 */
2515     case 'g': case 'G':         /* in gigabytes */
2516       val <<= 30; arg++; break; /* *= 1024*1024*1024 */
2517    #if intMsize > 32            /* 64-bit platforms only */
2518     case 't': case 'T':         /* in terabytes */
2519       val <<= 40; arg++; break; /* *= 1024*1024*1024*1024 */
2520     case 'p': case 'P':         /* in petabytes */
2521       val <<= 50; arg++; break; /* *= 1024*1024*1024*1024*1024 */
2522    #endif
2523   }
2524   switch (*arg) {
2525     case 'w': case 'W':            /* in words */
2526       val *= sizeof(gcv_object_t); /*FALLTHROUGH*/
2527     case 'b': case 'B':            /* in bytes */
2528       arg++; break;
2529   }
2530   if (*arg != '\0') {           /* argument finished? */
2531     fprintf(stderr,GETTEXTL("Syntax for %s: nnnnnnn or nnnnKB or nMB"),
2532             docstring);
2533     fprint(stderr,"\n");
2534     return 1;
2535   }
2536   if (val < limit_low) {
2537     fprintf(stderr,GETTEXTL("warning: %s %lu too small, using %lu instead"),
2538             docstring, val, limit_low);
2539     fprint(stderr,"\n");
2540     val = limit_low;
2541   }
2542   if (val > limit_high) {
2543     fprintf(stderr,GETTEXTL("warning: %s %lu too large, using %lu instead"),
2544             docstring, val, limit_high);
2545     fprint(stderr,"\n");
2546     val = limit_high;
2547   }
2548   /* For multiple -m arguments, only the last counts. */
2549   *ret = val;
2550   return 0;
2551 }
2552 
2553 local const char* delegating_cookie =
2554   "should clisp delegate non --clisp args? N";
2555 local int delegating_cookie_length = -1;
delegating_p(void)2556 local bool delegating_p (void) {
2557   if (delegating_cookie_length == -1)
2558     delegating_cookie_length = asciz_length(delegating_cookie);
2559   return delegating_cookie[delegating_cookie_length-1] == 'Y';
2560 }
2561 
2562 #if defined(UNIX)
2563  #define DROP_PRIVILEGES drop_privileges()
2564 #else
2565  #define DROP_PRIVILEGES do { /*noop*/ } while(0)
2566 #endif
2567 
2568 /* Parse the command-line options.
2569  Returns -1 on normal termination, or an exit code >= 0 for immediate exit. */
parse_options(int argc,const char * const * argv,struct argv_init_c * p0,struct argv_initparams * p1,struct argv_actions * p2)2570 local inline int parse_options (int argc, const char* const* argv,
2571                                 struct argv_init_c* p0,
2572                                 struct argv_initparams* p1,
2573                                 struct argv_actions* p2) {
2574   var const bool delegating = delegating_p();
2575   p0->argv_language = NULL;
2576   p0->argv_localedir = NULL;
2577   p1->argv_memneed = 0;
2578   p1->argv_nextgc_factor = 1.0;
2579   p1->argv_memfile = NULL;
2580   p2->argv_main_action = action_normal;
2581   p2->argv_memfile = NULL;
2582   p2->argv_verbose = 2;
2583   p2->argv_lisplibdir = NULL;
2584   p2->argv_developer = false;
2585   p2->argv_load_compiling = false;
2586   p2->argv_init_filecount = 0;
2587   p2->argv_init_files = (const char**) malloc((uintL)argc*sizeof(const char*)); /* max argc -x/-i options */
2588   p2->argv_compile = false;
2589   p2->argv_compile_listing = false;
2590   p2->argv_norc = delegating; /* application should have its own RC file */
2591   p2->argv_on_error = ON_ERROR_DEFAULT;
2592   p2->argv_compile_filecount = 0;
2593   p2->argv_compile_files = (argv_compile_file_t*) malloc((uintL)argc*sizeof(argv_compile_file_t)); /* max argc file-arguments + -lp arguments */
2594   p2->argv_load_paths_count = 0;
2595   p2->argv_load_paths = p2->argv_compile_files + argc; /* share space with -c */
2596   p2->argv_package = NULL;
2597   p2->argv_ansi = 0;
2598   p2->argv_modern = false;
2599   p2->argv_repl = false;
2600   p2->argv_expr_count = 0;
2601   p2->argv_exprs = p2->argv_init_files + argc; /* put -x and -i arguments into the same array */
2602   p2->argv_execute_file = NULL;
2603   p2->argv_execute_args = NULL;
2604   p2->argv_execute_arg_count = 0;
2605   p2->argv_batchmode_p = false;
2606   p2->argv_license = false;
2607   p2->argv_wait_keypress = false;
2608   p2->argv_help_image = false;
2609 
2610   /* process arguments argv[0..argc-1] :
2611      -h              Help
2612      -m size         Memory size (size = nB or nKB or nMB)
2613      -t directory    temporary directory
2614      -B directory    set lisplibdir
2615      -K linkingset   specify executable and mem file
2616      -M file         load MEM-file
2617      -L language     set the user language
2618      -N directory    NLS catalog directory
2619      -Edomain encoding  set encoding
2620      -q/-v           verbosity level:
2621         3:   banner, VERBOSE=T, PRINT=T
2622       * 2:   banner, VERBOSE=T, PRINT=NIL  ======= default
2623         1:   no banner, VERBOSE=T, PRINT=NIL
2624         0:   no banner, VERBOSE=NIL, PRINT=NIL
2625      -norc           do not load the user ~/.clisprc file
2626      -I              ILISP-friendly
2627      -C              set *LOAD-COMPILING* to T
2628      -i file ...     load LISP-file for initialization
2629      -c file ...     compile LISP-files, then leave LISP
2630      -l              At compilation: create listings
2631      -p package      set *PACKAGE*
2632      -ansi           more ANSI CL Compliance
2633      -traditional    traditional (undoes -ansi)
2634      -modern         modern (set *PACKAGE* and *PRINT-CASE*)
2635      -x expr         execute LISP-expressions, then leave LISP
2636      -on-error debug override batch-mode for -c, -x and file
2637      -repl           enter REPL after -c, -x and file
2638      -w              wait for keypress after termination
2639      -memfile-hash   Print the hash code of the mem file binary interface
2640      -memfile-hash-of mem-file  Print the hash code of the mem file binary
2641                                 interface that was used to create this mem-file
2642      -memfile-compatible mem-file  Return 0 or 1, depending whether this mem-file is
2643                                    compatible with this executable
2644      --help          print usage and exit (should be the only option)
2645      --version       print version and exit (should be the only option)
2646      file [arg ...]  load LISP-file in batch-mode and execute, then leave LISP
2647                      or put all positional arguments into *ARGS* and run DRIVER
2648      -help-image     print what this image does
2649    -d -- developer mode -- undocumented, unsupported &c
2650       - unlock all packages.
2651 
2652    Newly added options have to be listed:
2653    - in the above table,
2654    - in the usage-message here,
2655    - in the options parser,
2656    - in the options parser in _clisp.c,
2657    - in the manual page doc/clisp.xml.in. */
2658 
2659   program_name = argv[0];       /* argv[0] is the program name */
2660   {
2661     var const char* const* argptr = &argv[1];
2662     var const char* const* argptr_limit = &argv[argc];
2663     var enum { for_exec, for_init, for_compile, for_expr, for_load_path }
2664       argv_for = for_exec;
2665     var bool clisp_superarg_used = false;
2666     /* loop and process options, replace processed options with NULL: */
2667     while (argptr < argptr_limit) {
2668       var const char* arg = *argptr++; /* next argument */
2669       if (0 == strncmp(arg,"--clisp",7)) {
2670         arg += 7; clisp_superarg_used = true;
2671       } else if (delegating) goto non_option;
2672       if ((arg[0] == '-') && !(arg[1] == '\0')) {
2673         switch (arg[1]) {
2674           case 'h':             /* help */
2675             if (asciz_equal(arg,"-help-image")) {
2676               p2->argv_help_image = true;
2677               break;
2678             } else if (arg[2] != 0)
2679               INVALID_ARG(arg);
2680             else {
2681               usage(delegating);
2682               return 0;
2683             }
2684             /* returns after a one-character token the rest of the
2685              option in arg. poss. space is skipped. */
2686             #define OPTION_ARG                  \
2687               if (arg[2] == '\0') {             \
2688                 if (argptr < argptr_limit)      \
2689                   arg = *argptr++;              \
2690                 else INVALID_ARG(arg);          \
2691               } else arg += 2
2692           case 'm':             /* memory size  */
2693             if (arg[2]=='m' && arg[3]=='\0') { /* "-mm" -> print a memory map */
2694               #if defined(WIN32_NATIVE)
2695                 DumpProcessMemoryMap(stdout);
2696               #elif VMA_ITERATE_SUPPORTED
2697                 dump_process_memory_map(stdout);
2698               #endif
2699               return 1;
2700             }
2701             if (asciz_equal(arg,"-marc")) { /* "-marc" -> MAPPABLE_ADDRESS_RANGE_* check */
2702               return mappable_address_range_check();
2703             }
2704             if (asciz_equal(arg,"-memfile-hash")) {
2705               p2->argv_main_action = action_mfihash;
2706             } else if (asciz_equal(arg,"-memfile-hash-of")) {
2707               if (argptr < argptr_limit)
2708                 arg = *argptr++;
2709               else
2710                 INVALID_ARG(arg);
2711               p2->argv_main_action = action_mfihash_of;
2712               p2->argv_memfile = arg;
2713             } else if (asciz_equal(arg,"-memfile-compatible")) {
2714               if (argptr < argptr_limit)
2715                 arg = *argptr++;
2716               else
2717                 INVALID_ARG(arg);
2718               p2->argv_main_action = action_mfcompat;
2719               p2->argv_memfile = arg;
2720             } else if (asciz_equal(arg,"-modern")) {
2721               p2->argv_modern = true;
2722             } else {
2723               OPTION_ARG;
2724               if (size_arg(arg,GETTEXTL("memory size"),&(p1->argv_memneed),
2725                            (MINIMUM_SPACE + RESERVE) * 8 /*teile/teile_STACK*/,
2726                            (oint_addr_len+addr_shift < intLsize-1
2727                             /* address space in oint_addr_len+addr_shift bits */
2728                             ? vbitm(oint_addr_len+addr_shift)
2729                             /* (resp. big dummy-limit) */
2730                             : vbitm(oint_addr_len+addr_shift)-1)))
2731                 return 1;
2732             } break;
2733           case 't':             /* traditional, temporary directory */
2734             if (asciz_equal(arg,"-traditional"))
2735               p2->argv_ansi = 2; /* traditional */
2736             else
2737               INVALID_ARG(arg);
2738             break;
2739           case 'd': /* -d (developer mode) or -disable-readline */
2740             if (asciz_equal(arg,"-disable-readline"))
2741               disable_readline = true;
2742             else if (arg[2] == '\0')
2743               p2->argv_developer = true;
2744             else
2745               INVALID_ARG(arg);
2746             break;
2747           case 'B':             /* lisplibdir */
2748             OPTION_ARG;
2749             if (!(p2->argv_lisplibdir == NULL)) {
2750               arg_error(GETTEXTL("multiple -B"),arg);
2751               return 1;
2752             }
2753             p2->argv_lisplibdir = arg;
2754             break;
2755           case 'n':
2756             if (asciz_equal(arg,"-nextgc-factor")) {
2757               if (!(argptr < argptr_limit)) {
2758                 arg_error(GETTEXTL("This option requires an argument"),arg);
2759                 return 1;
2760               }
2761               arg = *argptr++;
2762               var char* arg_endptr;
2763               var double arg_value = c_strtod(arg,&arg_endptr);
2764               if (arg_value > 0.0 && arg_value < 1.0e10)
2765                 p1->argv_nextgc_factor = arg_value;
2766               else
2767                 arg_error("invalid 'nextgc-factor' value",arg);
2768             } else if (asciz_equal(arg,"-norc"))
2769               p2->argv_norc = true;
2770             else
2771               INVALID_ARG(arg);
2772             break;
2773          #if defined(UNIX) || defined(WIN32_NATIVE)
2774           case 'K':             /* linKing set */
2775             OPTION_ARG;
2776             /* This option has already been digested by clisp.c.
2777              We can ignore it. */
2778             break;
2779          #endif
2780           case 'M': /* MEM-file: when repeated, only the last one counts. */
2781             OPTION_ARG;
2782             p1->argv_memfile = arg;
2783             p2->argv_memfile = arg;
2784             break;
2785           case 'L': /* Language: when repeated, only the last one counts. */
2786             OPTION_ARG;
2787             p0->argv_language = arg;
2788             break;
2789           case 'N': /* NLS-directory: when repeated, only the last one counts. */
2790             OPTION_ARG;
2791             p0->argv_localedir = arg;
2792             break;
2793           case 'E':             /* encoding */
2794             if (!(argptr < argptr_limit)) {
2795               arg_error(GETTEXTL("-E requires an argument"),arg);
2796               return 1;
2797             }
2798             if (asciz_equal(&arg[2],"file"))
2799               argv_encoding_file = *argptr++;
2800            #ifndef CONSTANT_PATHNAME_ENCODING
2801             else if (asciz_equal(&arg[2],"pathname"))
2802               argv_encoding_pathname = *argptr++;
2803            #endif
2804             else if (asciz_equal(&arg[2],"terminal"))
2805               argv_encoding_terminal = *argptr++;
2806             else if (asciz_equal(&arg[2],"foreign"))
2807               argv_encoding_foreign = *argptr++;
2808             else if (asciz_equal(&arg[2],"misc"))
2809               argv_encoding_misc = *argptr++;
2810             else if (arg[2] == '\0') /* unspecified => all */
2811              #ifndef CONSTANT_PATHNAME_ENCODING
2812               argv_encoding_pathname =
2813              #endif
2814               argv_encoding_file = argv_encoding_terminal =
2815                 argv_encoding_foreign = argv_encoding_misc = *argptr++;
2816             else
2817               INVALID_ARG(arg);
2818             break;
2819           case 'q':             /* verbosity level */
2820             p2->argv_verbose--;
2821             if (arg[2] != '\0')
2822               INVALID_ARG(arg);
2823             break;
2824           case 'v':             /* verbosity level */
2825             p2->argv_verbose++;
2826             if (arg[2] != '\0')
2827               INVALID_ARG(arg);
2828             break;
2829           case 'I':             /* ILISP-friendly */
2830             ilisp_mode = true;
2831             if (arg[2] != '\0')
2832               INVALID_ARG(arg);
2833             break;
2834           case 'C':             /* set *LOAD-COMPILING* */
2835             p2->argv_load_compiling = true;
2836             if (arg[2] != '\0')
2837               INVALID_ARG(arg);
2838             break;
2839           case 'r': /* -repl */
2840             if (asciz_equal(&arg[1],"repl"))
2841               p2->argv_repl = true;
2842             else
2843               INVALID_ARG(arg);
2844             break;
2845           case 'i':             /* initialization files */
2846             if (arg[2] == '\0')
2847               argv_for = for_init;
2848             else
2849               INVALID_ARG(arg);
2850             break;
2851           case 'c':             /* files to be compiled */
2852             p2->argv_compile = true;
2853             argv_for = for_compile;
2854             if (arg[2] == 'l') {
2855               p2->argv_compile_listing = true;
2856               if (arg[3] != '\0')
2857                 INVALID_ARG(arg);
2858             } else {
2859               if (arg[2] != '\0')
2860                 INVALID_ARG(arg);
2861             }
2862             break;
2863           case 'l':             /* compilation listings */
2864             if (arg[2] == 0)
2865               p2->argv_compile_listing = true;
2866             else if (arg[2] == 'p' && arg[3] == 0) {
2867               argv_for = for_load_path;
2868             } else
2869               INVALID_ARG(arg);
2870             break;
2871           case 'o':
2872             if (asciz_equal(&arg[1],"on-error")) {
2873               if (argptr < argptr_limit)
2874                 arg = *argptr++;
2875               else
2876                 INVALID_ARG(arg);
2877               if (asciz_equal(arg,"default"))
2878                 p2->argv_on_error = ON_ERROR_DEFAULT;
2879               else if (asciz_equal(arg,"debug"))
2880                 p2->argv_on_error = ON_ERROR_DEBUG;
2881               else if (asciz_equal(arg,"abort"))
2882                 p2->argv_on_error = ON_ERROR_ABORT;
2883               else if (asciz_equal(arg,"appease"))
2884                 p2->argv_on_error = ON_ERROR_APPEASE;
2885               else if (asciz_equal(arg,"exit"))
2886                 p2->argv_on_error = ON_ERROR_EXIT;
2887               else {
2888                 arg_error("invalid `on-error' action",arg);
2889                 return 1;
2890               }
2891             } else if (arg[2] == '\0') { /* target for files to be compiled */
2892               OPTION_ARG;
2893               if (!((p2->argv_compile_filecount > 0)
2894                     && (p2->argv_compile_files[p2->argv_compile_filecount-1].output_file==NULL)))
2895                 INVALID_ARG(arg);
2896               p2->argv_compile_files[p2->argv_compile_filecount-1].output_file = arg;
2897             } else
2898               INVALID_ARG(arg);
2899             break;
2900           case 'p': /* package: when repeated, only the last one counts. */
2901             OPTION_ARG;
2902             p2->argv_package = arg;
2903             break;
2904           case 'a':             /* ANSI CL Compliance */
2905             if (asciz_equal(arg,"-ansi"))
2906               p2->argv_ansi = 1; /* ANSI */
2907             else
2908               INVALID_ARG(arg);
2909             break;
2910           case 'x':             /* execute LISP-expression */
2911             if (arg[2] != '\0')
2912               INVALID_ARG(arg);
2913             argv_for = for_expr;
2914             break;
2915           case 'w':            /* wait for keypress after termination */
2916             p2->argv_wait_keypress = true;
2917             if (arg[2] != '\0')
2918               INVALID_ARG(arg);
2919             break;
2920           case '-':             /* -- GNU-style long options */
2921             if (arg[2] == 0) /* "--" ==> end of options */
2922               goto done_with_argv;
2923             else if (asciz_equal(&arg[2],"help")) {
2924               usage(delegating);
2925               return 0;
2926             } else if (asciz_equal(&arg[2],"version")) {
2927               p2->argv_expr_count = 0;  /* discard previous -x */
2928               p2->argv_verbose = 1;
2929               p2->argv_norc = true;
2930               p2->argv_repl = false;
2931               p2->argv_exprs[-1-(sintP)(p2->argv_expr_count++)] =
2932                 /* FIXME: i18n */
2933                 "(PROGN (PRINC \"" PACKAGE_NAME " \")"
2934                 "(PRINC (LISP-IMPLEMENTATION-VERSION)) (TERPRI)"
2935                 "(PRINC \"Software: \") (PRINC (SOFTWARE-VERSION))"
2936                 "(PRINC \" \") (PRINC (SOFTWARE-TYPE)) (TERPRI)"
2937                 "(PRINC \"Features: \") (PRINC *FEATURES*) (TERPRI)"
2938                 /* Each module should augment *FEATURES*, so this should
2939                    not be necessary.
2940                    Unfortunately, we have no control over the user code,
2941                    thus we cannot enforce this requirement.
2942                    Since the "--version" output is used for bug reporting,
2943                    we must make it as complete and accurate as possible,
2944                    so we prefer to err on the side of verbosity. */
2945                 "(PRINC \"C Modules: \") (PRINC (EXT::MODULE-INFO)) (TERPRI)"
2946                 "(PRINC \"Installation directory: \")"
2947                 "(PRINC (SYS::LIB-DIRECTORY)) (TERPRI)"
2948                 "(PRINC \"User language: \")"
2949                 "(PRINC (SYS::CURRENT-LANGUAGE)) (TERPRI)"
2950                 "(PRINC \"Machine: \") (PRINC (MACHINE-TYPE))"
2951                 "(PRINC \" (\") (PRINC (MACHINE-VERSION))"
2952                 "(PRINC \") \") (PRINC (MACHINE-INSTANCE)) (TERPRI)"
2953                 /*"(PRINC \"Arguments: \") (PRIN1 (EXT::ARGV)) (TERPRI)"*/
2954                 "(SYS::%EXIT))";
2955               break;
2956             } else if (asciz_equal(&arg[2],"quiet")
2957                        || asciz_equal(&arg[2],"silent")) {
2958               p2->argv_verbose--;
2959               break;
2960             } else if (asciz_equal(&arg[2],"verbose")) {
2961               p2->argv_verbose++;
2962               break;
2963             } else if (asciz_equal(&arg[2],"license")) {
2964               p2->argv_license = true;
2965               break;
2966             } else              /* unknown option */
2967               INVALID_ARG(arg);
2968             break;
2969           default:              /* unknown option */
2970             INVALID_ARG(arg);
2971         }
2972       } else if (arg[0] == 0) {  /* done with the arguments */
2973        done_with_argv:
2974         p2->argv_execute_args = argptr;
2975         p2->argv_execute_arg_count = argptr_limit - argptr;
2976         argptr = argptr_limit; /* abort loop */
2977       } else {             /* non option -> interpreted as file to be */
2978        non_option:         /* loaded / compiled / executed */
2979         switch (argv_for) {
2980           case for_init:
2981             p2->argv_init_files[p2->argv_init_filecount++] = arg;
2982             break;
2983           case for_compile:
2984             p2->argv_compile_files[p2->argv_compile_filecount].input_file = arg;
2985             p2->argv_compile_files[p2->argv_compile_filecount].output_file = NULL;
2986             p2->argv_compile_filecount++;
2987             break;
2988           case for_exec:
2989             p2->argv_execute_file = arg;
2990             /* All further arguments are arguments for argv_execute_file. */
2991             p2->argv_execute_args = argptr;
2992             p2->argv_execute_arg_count = argptr_limit - argptr;
2993             /* Simulate -norc. Batch scripts should be executed in an
2994              environment which does not depend on files in $HOME, for
2995              maximum portability. */
2996             p2->argv_norc = true;
2997             argptr = argptr_limit; /* abort loop */
2998             break;
2999           case for_expr:
3000             p2->argv_exprs[-1-(sintP)(p2->argv_expr_count++)] = arg;
3001             break;
3002           case for_load_path:
3003             p2->argv_load_paths[-1-(sintP)(p2->argv_load_paths_count)].input_file = arg;
3004             p2->argv_load_paths[-1-(sintP)(p2->argv_load_paths_count++)].output_file = NULL;
3005             break;
3006           default: NOTREACHED;
3007         }
3008         argv_for = for_exec;
3009       }
3010     }
3011     if (clisp_superarg_used) DROP_PRIVILEGES;
3012     p2->argv_batchmode_p = /* '-c' or '-x' or file => batch-mode: */
3013       ((p2->argv_compile || p2->argv_expr_count || p2->argv_execute_file != NULL)
3014        && p2->argv_on_error != ON_ERROR_DEBUG
3015        && p2->argv_on_error != ON_ERROR_APPEASE
3016        && !p2->argv_repl);
3017     /* check options semantically and store defaults: */
3018     if (p1->argv_memneed == 0) {
3019      #if defined(SPVW_MIXED_BLOCKS_OPPOSITE) && defined(GENERATIONAL_GC)
3020       /* Because of GENERATIONAL_GC the memory region is hardly exhausted. */
3021       p1->argv_memneed = 3584*1024*sizeof(gcv_object_t); /* 3584 KW = 14 MB Default */
3022      #else
3023       /* normal */
3024       p1->argv_memneed = 768*1024*sizeof(gcv_object_t); /* 768 KW = 3 MB Default */
3025      #endif
3026     }
3027     if (!p2->argv_compile) {
3028       /* Some options are useful only together with '-c' : */
3029       if (p2->argv_compile_listing) {
3030         arg_error(GETTEXTL("-l without -c is invalid"),NULL);
3031         return 1;
3032       }
3033     } else {
3034       /* Other options are useful only without '-c' : */
3035       if (p2->argv_expr_count) {
3036         arg_error(GETTEXTL("-x with -c is invalid"),NULL);
3037         return 1;
3038       }
3039     }
3040     if (p2->argv_expr_count && p2->argv_execute_file) {
3041       arg_error(GETTEXTL("-x with lisp-file is invalid"),p2->argv_execute_file);
3042       return 1;
3043     }
3044   }
3045   return -1;
3046 }
3047 
3048 /* Delete command-line options. */
free_argv_initparams(struct argv_initparams * p)3049 local inline void free_argv_initparams (struct argv_initparams *p) {
3050   unused(p);
3051 }
free_argv_actions(struct argv_actions * p)3052 local inline void free_argv_actions (struct argv_actions *p) {
3053   free(p->argv_init_files);
3054   free(p->argv_compile_files);
3055 }
3056 
3057 /* Saving and Loading of MEM-Files */
3058 #include "spvw_memfile.c"
3059 
3060 /* Initialize memory and load the specified memory image.
3061  Returns 0 if successful, -1 upon error (after printing an error message
3062  to stderr). */
3063 #if 0
3064 #define VAROUT(v)  printf("[%s:%d] %s=%ld\n",__FILE__,__LINE__,STRING(v),v)
3065 #else
3066 #define VAROUT(v)
3067 #endif
init_memory(struct argv_initparams * p)3068 local inline int init_memory (struct argv_initparams *p) {
3069   /* Initialize the table of relocatable pointers: */
3070   {
3071     var object* ptr2 = &pseudofun_tab.pointer[0];
3072     { local const char* pseudocode_name_tab[] = {
3073         #define PSEUDO  PSEUDO_F
3074         #include "pseudofun.c"
3075         #undef PSEUDO
3076       };
3077       var const Pseudofun* ptr1 = (const Pseudofun*)&pseudocode_tab;
3078       var const char* const* nameptr = &pseudocode_name_tab[0];
3079       var uintC count = pseudocode_count;
3080       while (count--) {
3081         verify_pseudocode_alignment(*ptr1,*nameptr);
3082         *ptr2++ = make_machine_code(*ptr1); ptr1++; nameptr++;
3083       }
3084     }
3085     { local const char* pseudodata_name_tab[] = {
3086         #define PSEUDO  PSEUDO_G
3087         #include "pseudofun.c"
3088         #undef PSEUDO
3089       };
3090       var const Pseudofun* ptr1 = (const Pseudofun*)&pseudodata_tab;
3091       var const char* const* nameptr = &pseudodata_name_tab[0];
3092       var uintC count = pseudodata_count;
3093       while(count--) {
3094         verify_pseudodata_alignment(*ptr1,*nameptr);
3095         *ptr2++ = make_machine(*ptr1); ptr1++; nameptr++;
3096       }
3097     }
3098   }
3099   /* fetch memory: */
3100   begin_system_call();
3101  #if (defined(SINGLEMAP_MEMORY) || defined(TRIVIALMAP_MEMORY) || defined(MULTITHREAD)) && (defined(HAVE_MMAP_ANON) || defined(HAVE_MMAP_DEVZERO) || defined(HAVE_MACH_VM) || defined(HAVE_WIN32_VM))
3102   mmap_init_pagesize();
3103  #endif
3104  #if defined(SINGLEMAP_MEMORY) || defined(TRIVIALMAP_MEMORY)
3105   init_map_pagesize();
3106  #endif
3107  #if defined(KERNELVOID32A_HEAPCODES) && defined(HAVE_MMAP_ANON)
3108   /* On machines on which the address space extends up to 0xFFFFFFFF,
3109      disable the address range 0xC0000000..0xDFFFFFFF,
3110      so that we can use it for immediate objects. */
3111   mmap((void*)0xC0000000,0x20000000,PROT_NONE,MAP_ANON|MAP_PRIVATE|MAP_FIXED,-1,0);
3112  #endif
3113  #if defined(KERNELVOID32B_HEAPCODES) && defined(HAVE_MMAP_ANON)
3114   /* On machines on which the address space extends up to 0xFFFFFFFF,
3115      disable the address range 0xE0000000..0xFFFFFFFF,
3116      so that we can use it for immediate objects. */
3117   mmap((void*)0xE0000000,0x20000000,PROT_NONE,MAP_ANON|MAP_PRIVATE|MAP_FIXED,-1,0);
3118  #endif
3119  #if (defined(GENERIC64A_HEAPCODES) || defined(GENERIC64B_HEAPCODES)) && defined(HAVE_MMAP_ANON)
3120   /* On machines on which the address space extends up to 0xFFFFFFFFFFFFFFFF,
3121      disable the address range 0xC000000000000000..0xDFFFFFFFFFFFFFFF,
3122      so that we can use it for immediate objects. */
3123   mmap((void*)0xC000000000000000UL,0x2000000000000000UL,PROT_NONE,MAP_ANON|MAP_PRIVATE|MAP_FIXED,-1,0);
3124  #endif
3125  #ifdef SPVW_PURE
3126   init_mem_heaptypes();
3127   init_objsize_table();
3128  #endif
3129   init_modules_0();             /* assemble the list of modules */
3130   end_system_call();
3131 
3132   back_trace = NULL;
3133  #ifdef MAP_MEMORY_TABLES
3134   {                             /* calculate total_subr_count: */
3135     var uintC total = 0;
3136     var module_t* module;
3137     for_modules(all_modules, { total += *module->stab_size; } );
3138     total_subr_count = total;
3139   }
3140  #endif
3141   {                              /* partitioning of the total memory: */
3142     #define teile             16 /* 16/16 */
3143     #define teile_STACK        2 /* 2/16 */
3144     #ifdef SPVW_MIXED_BLOCKS
3145       #define teile_objects    (teile - teile_STACK) /* rest */
3146     #else
3147       #define teile_objects    0
3148     #endif
3149     var uintL pagesize =        /* size of a page */
3150      #if defined(GENERATIONAL_GC)
3151       mmap_pagesize
3152      #else  /* if the system-pagesize does not play a role */
3153       teile*varobject_alignment
3154      #endif
3155       ;
3156     VAROUT(pagesize);
3157     var uintM memneed = p->argv_memneed; /* needed memory */
3158     VAROUT(memneed);
3159     var aint memblock;  /* lower address of the provided memory block */
3160    #if !(defined(SPVW_MIXED_BLOCKS_OPPOSITE) && !defined(TRIVIALMAP_MEMORY))
3161     memneed = teile_STACK*floor(memneed,teile); /* do not yet calculate memory for objects */
3162     VAROUT(memneed);
3163     #undef teile
3164     #define teile  teile_STACK
3165    #endif
3166    #if defined(TRIVIALMAP_MEMORY) && defined(WIN32_NATIVE)
3167     /* Somehow the RESERVE_FOR_MALLOC limit for mallocs after prepare_zeromap()
3168      seems also to encompass the mallocs before prepare_zeromap().
3169      Do not know why. */
3170     if (memneed > RESERVE_FOR_MALLOC*3/4) { memneed = RESERVE_FOR_MALLOC*3/4; }
3171     VAROUT(memneed);
3172    #endif
3173    #if (defined(SINGLEMAP_MEMORY) && defined(SINGLEMAP_MEMORY_STACK)) || (defined(TRIVIALMAP_MEMORY) && defined(TRIVIALMAP_MEMORY_STACK))
3174     /* No need to call mymalloc at all. */
3175     memblock = 0;
3176    #else
3177     while (1) {
3178       /* Try to allocate memory. */
3179       memblock = (aint)mymalloc(memneed);
3180       VAROUT(memneed); VAROUT(memblock);
3181       if (!((void*)memblock == NULL)) break; /* successful -> OK */
3182       memneed = floor(memneed,8)*7; /* else try again with 7/8 thereof */
3183       if (memneed == 0) break;
3184     }
3185     if (memneed == 0) {
3186       begin_system_call();
3187       memblock = (aint)malloc(1);
3188       end_system_call();
3189       fprint_mymalloc_diagnostic(stderr,memblock);
3190       fprint(stderr,"\n");
3191       return -1;
3192     }
3193     if (memneed < MINIMUM_SPACE+RESERVE) { /* but with less than MINIMUM_SPACE */
3194       /* we will not be satisfied: */
3195       fprintf(stderr,GETTEXTL("Only %ld bytes available."),memneed);
3196       fprint(stderr,"\n");
3197       return -1;
3198     }
3199     {                       /* round to the next lower page boundary: */
3200       var uintL unaligned = (uintL)(-memblock) % pagesize;
3201       memblock += unaligned; memneed -= unaligned;
3202       VAROUT(unaligned); VAROUT(memneed);
3203     }
3204     {                         /* round off to the last page boundary: */
3205       var uintL unaligned = memneed % pagesize;
3206       memneed -= unaligned;
3207       VAROUT(unaligned); VAROUT(memneed);
3208     }
3209     /* the memory region [memblock,memblock+memneed-1] is now free,
3210      and its boundaries are located on page boundaries. */
3211    #endif
3212    #if defined(SINGLEMAP_MEMORY) || defined(TRIVIALMAP_MEMORY) /* <==> SPVW_PURE_BLOCKS || TRIVIALMAP_MEMORY */
3213     if ( initmap() <0) return -1;
3214     #ifdef SINGLEMAP_MEMORY
3215      #ifndef IGNORE_MAPPABLE_ADDRESS_RANGE
3216       /* Verify that all heaps lie in the mappable address range. */
3217       {
3218         var uintL heapnr;
3219         for (heapnr=0; heapnr<heapcount; heapnr++) {
3220           if (mem.heaptype[heapnr] >= -1) {
3221             var uintP heap_start_addr = (uintP)(type_zero_oint(heapnr)+SINGLEMAP_ADDRESS_BASE);
3222             var uintP heap_end_addr = (uintP)(type_zero_oint(heapnr+1)+SINGLEMAP_ADDRESS_BASE);
3223             if (!(heap_start_addr >= MAPPABLE_ADDRESS_RANGE_START
3224                   && heap_end_addr-1 <= MAPPABLE_ADDRESS_RANGE_END)) {
3225               fprintf(stderr,"Invalid values of SINGLEMAP_ADDRESS_BASE and oint_type_shift: Heap %d = [%p,%p] does not lie in MAPPABLE_ADDRESS_RANGE.\n",
3226                       heapnr,(void*)heap_start_addr,(void*)(heap_end_addr-1));
3227               return -1;
3228             }
3229           }
3230         }
3231       }
3232      #endif
3233       /* Pre-initialize all heaps. */
3234       {
3235         var uintL heapnr;
3236         for (heapnr=0; heapnr<heapcount; heapnr++) {
3237           var Heap* heapptr = &mem.heaps[heapnr];
3238           var uintP heap_start_addr = (uintP)(type_zero_oint(heapnr)+SINGLEMAP_ADDRESS_BASE);
3239           var uintP heap_end_addr = (uintP)(type_zero_oint(heapnr+1)+SINGLEMAP_ADDRESS_BASE);
3240          #if defined(UNIX_IRIX) && (defined(MIPS) || defined(MIPS64))
3241           /* Avoid "Warning: reserving address range 0x5f000000...0x5fffffff that contains memory mappings."
3242              and   "Warning: reserving address range 0x5e000000...0x5effffff that contains memory mappings." */
3243           if (heap_end_addr == 0x60000000UL || heap_end_addr == 0x5F000000UL) {
3244             heap_end_addr -= 0x800000UL;
3245           }
3246          #endif
3247           heapptr->heap_limit = heap_start_addr;
3248           heapptr->heap_hardlimit = heap_end_addr;
3249           if (mem.heaptype[heapnr] >= -1) {
3250             if (prepare_zeromap(&heapptr->heap_limit,&heapptr->heap_hardlimit,true) <0)
3251               return -1;
3252           }
3253         }
3254       }
3255       /* Set symbol_tab, subr_tab to address SINGLEMAP_ADDRESS_BASE:
3256          (for this purpose case_symbolflagged must be equivalent to case_symbol!) */
3257       #define map_tab(tab,size)                                                \
3258         do { var uintM map_len = round_up(size,map_pagesize);                  \
3259              if ( zeromap(&tab,map_len) <0) return -1;                         \
3260              mem.heaps[typecode(as_object((oint)&tab))].heap_limit += map_len; \
3261         } while(0)
3262       map_tab(symbol_tab,sizeof(symbol_tab));
3263       map_tab(subr_tab,varobjects_misaligned+total_subr_count*sizeof(subr_t));
3264     #endif
3265     #ifdef TRIVIALMAP_MEMORY
3266      /* Initialize all heaps as empty.
3267         Obey the MAPPABLE_ADDRESS_RANGE_START and MAPPABLE_ADDRESS_RANGE_END
3268         values, since this is the only way to make mmap with MAP_FIXED work
3269         reliably. */
3270      var uintP start = MAPPABLE_ADDRESS_RANGE_START;
3271      var uintP end = MAPPABLE_ADDRESS_RANGE_END;
3272      if (!(start < end)) {
3273        fprint(stderr,"Invalid values of MAPPABLE_ADDRESS_RANGE_START and MAPPABLE_ADDRESS_RANGE_END\n");
3274        return -1;
3275      }
3276      #if defined(HEAPCODES)
3277       var uintL bit_to_avoid = garcol_bit_o-oint_addr_shift;
3278       /* Distinguish between ONE_FREE_BIT_HEAPCODES and the other HEAPCODES schemes. */
3279       if (bit_to_avoid >= 16) {
3280         /* Modify the range so that its endpoints don't contain bit_to_avoid. */
3281         if (start & bit(bit_to_avoid)) {
3282           start |= bit(bit_to_avoid)-1;
3283           start++;
3284         }
3285         if (end & bit(bit_to_avoid)) {
3286           end &= minus_bit(bit_to_avoid);
3287           end--;
3288         }
3289         if (!(start < end)) {
3290           fprintf(stderr,"Wrong choice of garcol_bit: %d. It is not consistent with MAPPABLE_ADDRESS_RANGE.\n",bit_to_avoid);
3291           return -1;
3292         }
3293         /* Modify the range so that it does not contain addresses with bit_to_avoid
3294            in its interior. */
3295         if (bit_to_avoid < pointer_bitsize-1) {
3296           var uintP difference = (end >> (bit_to_avoid+1)) - (start >> (bit_to_avoid+1));
3297           if (difference > 0) {
3298             if (difference == 1) {
3299               /* Use the larger of the two available intervals. */
3300               var uintP length1 = (start | (bit(bit_to_avoid)-1)) - start;
3301               var uintP length2 = end - (end & minus_bit(bit_to_avoid));
3302               if (length1 >= length2) {
3303                 end = start | (bit(bit_to_avoid)-1);
3304               } else {
3305                 start = end & minus_bit(bit_to_avoid);
3306               }
3307             } else {
3308               /* The largest available interval has length 2^bit_to_avoid. */
3309               start |= bit(bit_to_avoid+1)-1;
3310               start++;
3311               end = start | (bit(bit_to_avoid)-1);
3312             }
3313           }
3314         }
3315       }
3316       #if defined(KERNELVOID32_HEAPCODES) || defined(GENERIC64A_HEAPCODES) || defined(GENERIC64B_HEAPCODES)
3317       /* Avoid the address range that we reserve for immediate objects. */
3318       #if defined(KERNELVOID32A_HEAPCODES)
3319       var uintP avoid_start = 0xC0000000;
3320       var uintP avoid_end = avoid_start + 0x20000000 - 1;
3321       #endif
3322       #if defined(KERNELVOID32B_HEAPCODES)
3323       var uintP avoid_start = 0xE0000000;
3324       var uintP avoid_end = avoid_start + 0x20000000 - 1;
3325       #endif
3326       #if defined(GENERIC64A_HEAPCODES) || defined(GENERIC64B_HEAPCODES)
3327       var uintP avoid_start = 0xC000000000000000UL;
3328       var uintP avoid_end = avoid_start + 0x2000000000000000UL - 1;
3329       #endif
3330       /* Compute [start,end] \ [avoid_start,avoid_end]. */
3331       if (!(avoid_end < start || end < avoid_start)) {
3332         /* Need to trim the [start,end] interval. */
3333         if (avoid_start <= start) {
3334           if (end <= avoid_end) {
3335             /* [start,end] \ [avoid_start,avoid_end] is empty. */
3336             fprint(stderr,"The range from MAPPABLE_ADDRESS_RANGE_START and MAPPABLE_ADDRESS_RANGE_END is entirely reserved for immediate objects.\n");
3337             return -1;
3338           } else {
3339             /* [start,end] \ [avoid_start,avoid_end] is a single interval
3340                [avoid_end+1,end]. */
3341             start = avoid_end+1;
3342           }
3343         } else {
3344           if (end <= avoid_end) {
3345             /* [start,end] \ [avoid_start,avoid_end] is a single interval
3346                [start,avoid_start-1]. */
3347             end = avoid_start-1;
3348           } else {
3349             /* [start,end] \ [avoid_start,avoid_end] consists of two intervals
3350                [start,avoid_start-1] ∪ [avoid_end+1,end]. Choose the larger one. */
3351             if (avoid_start-start < end-avoid_end)
3352               start = avoid_end+1;
3353             else
3354               end = avoid_start-1;
3355           }
3356         }
3357       }
3358       #endif
3359      #else /* TYPECODES */
3360       /* Verify that the interval [start,end] is covered by oint_addr_mask. */
3361       var uintP range_mask = bits_used_by_range(start,end);
3362       if ((range_mask & ~(oint_addr_mask>>oint_addr_shift)) != 0) {
3363         fprintf(stderr,"Wrong choice of oint_addr_mask: %p. It is not consistent with MAPPABLE_ADDRESS_RANGE's bits: %p.\n",
3364                 (void*)(uintP)(oint_addr_mask>>oint_addr_shift),(void*)range_mask);
3365         return -1;
3366       }
3367      #endif
3368      /* Verify that the alignment is guaranteed to be a multiple of physpagesize. */
3369      if (!((0xFFFF & start) == 0)) {
3370        fprintf(stderr,"Misaligned MAPPABLE_ADDRESS_RANGE_START: %p\n",(void*)start);
3371        return -1;
3372      }
3373      if (!((0xFFFF & ~end) == 0)) {
3374        fprintf(stderr,"Misaligned MAPPABLE_ADDRESS_RANGE_END: %p\n",(void*)end);
3375        return -1;
3376      }
3377      #ifdef TRIVIALMAP_MEMORY_STACK
3378       /* Allocate at most 1/8, but at most 100000 words, for the STACK. */
3379       {
3380         var uintP size_for_STACK = (end - start) / 8;
3381         if (size_for_STACK > 100000*sizeof(gcv_object_t)) {
3382           size_for_STACK = 100000*sizeof(gcv_object_t);
3383         }
3384         size_for_STACK &= ~(uintP)0xFFFF; /* start must remain a multiple of physpagesize */
3385         var aint low = start;
3386         start += size_for_STACK;
3387         var aint high = start;
3388         if ( prepare_zeromap(&low,&high,true) <0) return -1;
3389         if ( zeromap((void*)low,size_for_STACK) <0) return -1;
3390        #ifdef STACK_DOWN
3391         STACK_bound = (gcv_object_t*)low + 0x40; /* 64 pointers additionally safety margin */
3392         setSTACK(STACK = (gcv_object_t*)high);   /* initialize STACK */
3393        #endif
3394        #ifdef STACK_UP
3395         setSTACK(STACK = (gcv_object_t*)low); /* initialize STACK */
3396         STACK_bound = (gcv_object_t*)high - 0x40; /* 64 pointers additionally safety margin */
3397         #endif
3398         STACK_start = STACK;
3399       }
3400       #undef teile_STACK
3401       #define teile_STACK 0       /* need no more room for the STACK */
3402       #if (teile==0)
3403        #undef teile
3404        #define teile 1            /* avoid division by 0 */
3405       #endif
3406      #endif
3407      #ifdef SPVW_MIXED_BLOCKS_OPPOSITE
3408       mem.heaps[0].heap_limit = start;
3409       mem.heaps[1].heap_limit = end+1;
3410       if ( prepare_zeromap(&mem.heaps[0].heap_limit,&mem.heaps[1].heap_limit,true) <0)
3411         return -1;
3412      #else /* SPVW_MIXED_BLOCKS_STAGGERED */
3413       /* Allocate 2/3 for the varobjects heap, 1/3 for the conses heap. */
3414       var uintP mid = (start / 3) * 2 + (end / 3);
3415       #ifdef GENERATIONAL_GC
3416       mid &= -physpagesize;
3417       #else
3418       mid &= -map_pagesize;
3419       #endif
3420       mem.heaps[0].heap_limit = start;
3421       mem.heaps[0].heap_hardlimit =
3422       mem.heaps[1].heap_limit = mid;
3423       mem.heaps[1].heap_hardlimit = end+1;
3424       if ( prepare_zeromap(&mem.heaps[0].heap_limit,&mem.heaps[1].heap_hardlimit,true) <0)
3425         return -1;
3426      #endif
3427     #endif /* TRIVIALMAP_MEMORY */
3428     {      /* initialize all heaps as empty: */
3429       var uintL heapnr;
3430       for (heapnr=0; heapnr<heapcount; heapnr++) {
3431         var Heap* heapptr = &mem.heaps[heapnr];
3432         heapptr->heap_start = heapptr->heap_limit;
3433        #if varobjects_misaligned
3434         if (is_varobject_heap(heapnr)) {
3435           heapptr->heap_start += varobjects_misaligned;
3436           heapptr->heap_limit = heapptr->heap_start;
3437         }
3438        #endif
3439         heapptr->heap_end = heapptr->heap_start;
3440        #ifdef GENERATIONAL_GC
3441         heapptr->heap_gen0_start = heapptr->heap_gen0_end =
3442           heapptr->heap_gen1_start = heapptr->heap_start;
3443         heapptr->physpages = NULL;
3444        #endif
3445       }
3446     }
3447    #ifdef SINGLEMAP_MEMORY_STACK
3448     {                           /* initialize STACK: */
3449       var uintM map_len = round_up(memneed * teile_STACK/teile, map_pagesize);
3450       /* The stack occupies the interval between 0 and map_len
3451        for typecode = system_type: */
3452       var aint low = (aint)(type_zero_oint(system_type)+SINGLEMAP_ADDRESS_BASE);
3453       var aint high = low + map_len;
3454      #ifndef IGNORE_MAPPABLE_ADDRESS_RANGE
3455       if (!(low >= MAPPABLE_ADDRESS_RANGE_START && high-1 <= MAPPABLE_ADDRESS_RANGE_END)) {
3456         fprint(stderr,"Invalid values of SINGLEMAP_ADDRESS_BASE and oint_type_shift: STACK area does not lie in MAPPABLE_ADDRESS_RANGE.\n");
3457         return -1;
3458       }
3459      #endif
3460       if ( prepare_zeromap(&low,&high,true) <0) return -1;
3461       if ( zeromap((void*)low,map_len) <0) return -1;
3462      #ifdef STACK_DOWN
3463       STACK_bound = (gcv_object_t*)low + 0x40; /* 64 pointers additionally safety margin */
3464       setSTACK(STACK = (gcv_object_t*)high);   /* initialize STACK */
3465      #endif
3466      #ifdef STACK_UP
3467       setSTACK(STACK = (gcv_object_t*)low); /* initialize STACK */
3468       STACK_bound = (gcv_object_t*)high - 0x40; /* 64 pointers additionally safety margin */
3469       #endif
3470       STACK_start = STACK;
3471     }
3472     #undef teile_STACK
3473     #define teile_STACK 0       /* need no more room for the STACK */
3474     #if (teile==0)
3475      #undef teile
3476      #define teile 1            /* avoid division by 0 */
3477     #endif
3478    #endif  /* SINGLEMAP_MEMORY_STACK */
3479    #endif  /* SINGLEMAP_MEMORY || TRIVIALMAP_MEMORY */
3480    #if defined(GENERATIONAL_GC)
3481     init_physpagesize();
3482    #endif
3483     {                           /* divide memory block: */
3484       var uintM free_reserved;  /* number of reserved bytes */
3485       var uintM for_STACK;      /* number of bytes for Lisp-stack */
3486       var uintM for_objects;    /* number of bytes for Lisp-objects */
3487       /* the STACK needs alignment, because for frame-pointers
3488        the last Bit must be =0: */
3489       #define STACK_alignment  bit(addr_shift+1)
3490       #define alignment  (varobject_alignment>STACK_alignment ? varobject_alignment : STACK_alignment)
3491       free_reserved = memneed;
3492       /* make divisible by teile*alignment, so that each 1/16 is aligned: */
3493       free_reserved = round_down(free_reserved,teile*alignment);
3494       free_reserved = free_reserved - RESERVE;
3495       {
3496         var uintM teil = free_reserved/teile; /* a sub block, a 1/16 of the room */
3497         var aint ptr = memblock;
3498         mem.MEMBOT = ptr;
3499           #if defined(WIN32_NATIVE) && !defined(NO_SP_CHECK)
3500             /* Even if the NOCOST_SP_CHECK stack overflow detection (using a
3501              guard page) works, we set SP_bound.
3502              Normally, the stack's `AllocationBase' is = 0x30000, the guard
3503              page is 0x32000-0x32FFF, hence we can set SP_bound = 0x34000. */
3504             { var MEMORY_BASIC_INFORMATION info;
3505               if (!(VirtualQuery((void*)SP(),&info,sizeof(info)) == sizeof(info))) {
3506                 fprint(stderr,GETTEXTL("Could not determine the end of the SP stack!"));
3507                 fprint(stderr,"\n");
3508                 SP_bound = 0;
3509               } else { /* 0x4000 might be enough, but 0x8000 will be better. */
3510                 SP_bound = (void*)((aint)info.AllocationBase + 0x8000);
3511               }
3512             }
3513           #endif
3514         /* allocate STACK: */
3515         #if defined(SINGLEMAP_MEMORY_STACK) || defined(TRIVIALMAP_MEMORY_STACK)
3516         for_STACK = 0;       /* STACK is already allocated elsewhere. */
3517         #else
3518         #ifdef STACK_DOWN
3519           STACK_bound = (gcv_object_t*)ptr + 0x40; /* 64 pointer safety margin */
3520           ptr += for_STACK = teile_STACK*teil; /* 2/16 for Lisp-stack */
3521           setSTACK(STACK = (gcv_object_t*)ptr); /* initialize STACK */
3522         #endif
3523         #ifdef STACK_UP
3524           setSTACK(STACK = (gcv_object_t*)ptr); /* initialize STACK */
3525           ptr += for_STACK = teile_STACK*teil; /* 2/16 for Lisp-stack */
3526           STACK_bound = (gcv_object_t*)ptr - 0x40; /* 64 pointer safety margin */
3527         #endif
3528           STACK_start = STACK;
3529         #endif
3530         #if defined(SPVW_MIXED_BLOCKS_OPPOSITE) && !defined(TRIVIALMAP_MEMORY)
3531         /* now, the lisp-objects start: */
3532         #ifdef GENERATIONAL_GC
3533         mem.varobjects.heap_gen0_start = mem.varobjects.heap_gen0_end =
3534           mem.varobjects.heap_gen1_start = mem.varobjects.heap_start =
3535           ((ptr + (physpagesize-1)) & -physpagesize) + varobjects_misaligned;
3536         #else
3537         mem.varobjects.heap_start = ptr + varobjects_misaligned;
3538         #endif
3539         mem.varobjects.heap_end = mem.varobjects.heap_start; /* there are no objects of variable length, yet */
3540         /* rest (14/16 or a little less) for lisp-objects: */
3541         for_objects = memblock+free_reserved - ptr; /* about = teile_objects*teil */
3542         ptr += for_objects;
3543         #ifdef GENERATIONAL_GC
3544         mem.conses.heap_gen0_start = mem.conses.heap_gen0_end =
3545           mem.conses.heap_gen1_end = mem.conses.heap_end =
3546           ptr & -physpagesize;
3547         #else
3548         mem.conses.heap_end = ptr;
3549         #endif
3550         mem.conses.heap_start = mem.conses.heap_end; /* there are no conses yet */
3551         /* ptr = memblock+free_reserved, because 2/16 + 14/16 = 1
3552          allocate memory reserve: */
3553         ptr += RESERVE;
3554         /* upper memory limit reached. */
3555         mem.MEMTOP = ptr;
3556         /* above (far away) the machine stack. */
3557         #endif
3558         mem.nextgc_trigger_factor = p->argv_nextgc_factor;
3559         #if defined(SPVW_PURE_BLOCKS) || defined(TRIVIALMAP_MEMORY) || defined(GENERATIONAL_GC)
3560         mem.total_room = 0;
3561         #ifdef GENERATIONAL_GC
3562         mem.last_gcend_space0 = 0;
3563         mem.last_gcend_space1 = 0;
3564         #endif
3565         #endif
3566         #ifdef SPVW_PAGES
3567         for_each_heap(heap, { heap->inuse = EMPTY; } );
3568         for_each_cons_heap(heap, { heap->lastused = dummy_lastused; } );
3569         dummy_lastused->page_room = 0;
3570         for_each_varobject_heap(heap, { heap->misaligned = varobjects_misaligned; } );
3571         for_each_cons_heap(heap, { heap->misaligned = conses_misaligned; } );
3572         mem.free_pages = NULL;
3573         mem.total_space = 0;
3574         mem.used_space = 0;
3575         mem.last_gcend_space = 0;
3576         mem.gctrigger_space = 0;
3577         #endif
3578         /* Verify that the range used for STACK is adequate.
3579            Pointers into the stack are
3580              (1) used as Lisp objects, via make_framepointer, and stored e.g.
3581                  in aktenv.var_env,
3582              (2) taken from there, they are also stored in the STACK (in
3583                  variable-binding frames), see e.g. make_variable_frame.
3584            Therefore:
3585              - because of (2), the frame_bit_o (= garcol_bit_o) must be zero
3586                in STACK pointers, and
3587              - because of (1), in TYPECODES model, the typecode must be
3588                system_type.
3589            This verification must be consistent with the implementation of
3590            make_framepointer! */
3591         #if !defined(SINGLEMAP_MEMORY_STACK)
3592          var uintP STACK_range_mask = bits_used_by_range((uintP)STACK,(uintP)STACK_bound);
3593          #if defined(TYPECODES) && !defined(WIDE_SOFT)
3594          if ((((oint)(STACK_range_mask >> addr_shift) << oint_addr_shift) & oint_type_mask) != 0) {
3595            fprintf(stderr,"STACK range (around %p) contains some bits that are reserved as type bits (bit mask %p).\n",
3596                    (void*)STACK,(void*)((oint_type_mask >> oint_addr_shift) << addr_shift));
3597            return -1;
3598          }
3599          #endif
3600          #if (frame_bit_o >= 16)
3601          if ((((oint)(STACK_range_mask >> addr_shift) << oint_addr_shift) & wbit(frame_bit_o)) != 0) {
3602            fprintf(stderr,"STACK range (around %p) contains the bit used to identify frames (bit %d).\n",
3603                    (void*)STACK,(int)(frame_bit_o-oint_addr_shift+addr_shift));
3604            return -1;
3605          }
3606          #endif
3607         #endif
3608         /* initialize stack: */
3609         pushSTACK(nullobj); pushSTACK(nullobj); /* two nullpointer as STACK end marker */
3610       }
3611     }
3612   }
3613  #ifdef DEBUG_SPVW
3614   { /* STACK & SP are settled - check that we have enough STACK */
3615     var uintM stack_size =
3616       STACK_item_count((gcv_object_t*)STACK_bound,STACK);
3617     fprintf(stderr,"STACK size: %lu [0x%lx 0x%lx]\n",stack_size,
3618             (aint)STACK_bound,(aint)STACK);
3619    #ifndef NO_SP_CHECK
3620     if (SP_bound != 0) {
3621       fprintf(stderr,"SP depth: %lu\n",(uintM)
3622              #ifdef SP_UP
3623               ((SPint*)SP_bound - (SPint*)SP())
3624              #else
3625               ((SPint*)SP() - (SPint*)SP_bound)
3626              #endif
3627              );
3628     }
3629    #endif
3630     if (stack_size < ca_limit_1) {
3631       fprintf(stderr,"STACK size is less than CALL-ARGUMENTS-LIMIT (%lu)\n",
3632               (unsigned long)ca_limit_1);
3633       abort();
3634     }
3635     fflush(stderr); /* make sure the debug output comes out first thing */
3636   }
3637  #endif
3638   init_subr_tab_1();            /* initialize subr_tab */
3639   markwatchset = NULL; markwatchset_allocated = markwatchset_size = 0;
3640  #if defined(GENERATIONAL_GC)
3641   /* install Page-Fault-Handler: */
3642   install_segv_handler();
3643  #endif
3644  #if defined(MULTITHREAD)
3645   /* initialize the THREAD:*DEFAULT-VALUE-STACK-SIZE* based on the
3646      calculated STACK size */
3647   Symbol_value(S(default_value_stack_size)) =
3648     uint32_to_I(STACK_item_count(STACK_bound,STACK_start));
3649  #endif
3650   if (p->argv_memfile)
3651     loadmem(p->argv_memfile);   /* load memory file */
3652   else if (!loadmem_from_executable())
3653     p->argv_memfile = get_executable_name();
3654   else initmem();               /* manual initialization */
3655 #if defined(MULTITHREAD)
3656   /* clear the list of threads. the one that we have loaded contains
3657      single thread record which is invalid.*/
3658   O(all_threads) = NIL;
3659   /* initialize again THREAD:*DEFAULT-VALUE-STACK-SIZE* based on the
3660      calculated STACK size, since the memory image may change it */
3661   Symbol_value(S(default_value_stack_size)) =
3662     uint32_to_I(STACK_item_count(STACK_bound,STACK_start));
3663 #endif
3664   /* init O(current_language) */
3665   O(current_language) = current_language_o();
3666   /* set current evaluator-environments to the toplevel-value: */
3667   aktenv.var_env   = NIL;
3668   aktenv.fun_env   = NIL;
3669   aktenv.block_env = NIL;
3670   aktenv.go_env    = NIL;
3671   aktenv.decl_env  = O(top_decl_env);
3672   /* That's it. */
3673   return 0;
3674 }
3675 
3676 /* Output the hash code of the mem file binary interface. */
output_mfih(const uintB mfihash[MFIH_LEN])3677 local void output_mfih (const uintB mfihash[MFIH_LEN])
3678 {
3679   /* Convert to hexadecimal. */
3680   static char hex[16] = {'0','1','2','3','4','5','6','7','8','9','a','b','c','d','e','f'};
3681   var char mfihash_asciz[2*MFIH_LEN+1];
3682   { var const uintB* p = &mfihash[0];
3683     var char* q = mfihash_asciz;
3684     var uintC count;
3685     dotimespC(count,MFIH_LEN, {
3686       var uintB x = *p++;
3687       *q++ = hex[x >> 4];
3688       *q++ = hex[x & 0x0f];
3689     });
3690     *q = '\0';
3691   }
3692   /* Output it. */
3693   printf("%s\n",mfihash_asciz);
3694 }
3695 
3696 /* run all functions in the list
3697  can trigger GC */
run_hooks(object hooks)3698 local void maygc run_hooks (object hooks) {
3699   var gcv_object_t* top_of_frame = STACK; /* pointer over frame */
3700   var sp_jmp_buf returner; /* return point */
3701   finish_entry_frame(DRIVER,returner,,goto done_driver_run_hooks;);
3702   pushSTACK(hooks);
3703   while (mconsp(STACK_0)) {     /* process */
3704     var object obj = STACK_0;
3705     STACK_0 = Cdr(obj); funcall(Car(obj),0);
3706   }
3707  done_driver_run_hooks:
3708   setSTACK(STACK = top_of_frame); /* drop hooks & skip driver-frame */
3709 }
3710 
3711 /* (push arg *args*)
3712  can trigger GC */
push_to_args(const char * s)3713 local void maygc push_to_args(const char *s) {
3714   pushSTACK(asciz_to_string(s,O(misc_encoding)));
3715   var object new_cons = allocate_cons();
3716   Car(new_cons) = popSTACK();
3717   Cdr(new_cons) = Symbol_value(S(args));
3718   Symbol_value(S(args)) = new_cons;
3719 }
3720 
3721 /* Perform the main actions as specified by the command-line arguments. */
main_actions(struct argv_actions * p)3722 local inline void main_actions (struct argv_actions *p) {
3723   /* print greeting: */
3724   if (!nullpSv(quiet)                    /* SYS::*QUIET* /= NIL ? */
3725       || p->argv_execute_file != NULL) { /* batch-mode ? */
3726     /* Prevents the greeting.
3727        One might argue for argv_verbose-- instead of capping it at 1
3728        for the sake of script debugging with "clisp -v -v -v script.lisp".
3729        However, one can debug with "clisp -v -v -v -i script.lisp" even better
3730        because you get the REPL at the end in addition to verbosity. */
3731     if (p->argv_verbose > 1)
3732       p->argv_verbose = 1;
3733   }
3734   if (p->argv_verbose>=2 || p->argv_license)
3735     print_banner();
3736   if (p->argv_license)
3737     print_license();
3738   if (p->argv_execute_arg_count > 0) {
3739     var const char* const* execute_arg_ptr = p->argv_execute_args;
3740     var uintL count = p->argv_execute_arg_count;
3741     do { pushSTACK(asciz_to_string(*execute_arg_ptr++,O(misc_encoding))); }
3742     while (--count);
3743     Symbol_value(S(args)) = listof(p->argv_execute_arg_count);
3744   } else Symbol_value(S(args)) = NIL;
3745   if (p->argv_execute_file != NULL && p->argv_compile) {
3746     push_to_args(p->argv_execute_file); /* compiling: (push exec-file *args*) */
3747   }
3748   if ((p->argv_memfile == NULL) && (p->argv_expr_count == 0)) {
3749     /* warning for beginners */
3750     pushSTACK(var_stream(S(standard_output),strmflags_wr_ch_B)); /* auf *STANDARD-OUTPUT* */
3751     terpri(&STACK_0);
3752     write_sstring(&STACK_0,CLSTEXT("WARNING: No initialization file specified."));
3753     terpri(&STACK_0);
3754     write_sstring(&STACK_0,CLSTEXT("Please try: "));
3755     write_string(&STACK_0,asciz_to_string(program_name,O(pathname_encoding)));
3756     write_string(&STACK_0,ascii_to_string(" -M lispinit.mem\n"));
3757     skipSTACK(1);
3758   }
3759   if (p->argv_lisplibdir == NULL) {
3760     if (nullp(O(lib_dir))) {
3761       /* warning for beginners and careless developers */
3762       pushSTACK(var_stream(S(standard_output),strmflags_wr_ch_B)); /* on *STANDARD-OUTPUT* */
3763       terpri(&STACK_0);
3764       write_sstring(&STACK_0,CLSTEXT("WARNING: No installation directory specified."));
3765       terpri(&STACK_0);
3766       write_sstring(&STACK_0,CLSTEXT("Please try: "));
3767       write_string(&STACK_0,asciz_to_string(program_name,O(pathname_encoding)));
3768       write_string(&STACK_0,ascii_to_string(" -B /usr/local/lib/clisp\n"));
3769       skipSTACK(1);
3770     }
3771   } else {                      /* set it */
3772     pushSTACK(asciz_to_string(p->argv_lisplibdir,O(pathname_encoding)));
3773     funcall(L(set_lib_directory),1);
3774   }
3775   /* if the options suggest that user input will not be available,
3776      reset *DEBUG-IO* so that READ-CHAR on it results in an immediate EOF
3777      to avoid infinite loops on error. */
3778   if (p->argv_batchmode_p) {
3779     /* (setq *debug-io*
3780          (make-two-way-stream (make-concatenated-stream) *query-io*)) */
3781     funcall(L(make_concatenated_stream),0); /* (MAKE-CONCATENATED-STREAM) */
3782     pushSTACK(value1);                      /* empty input-stream */
3783     var object stream = var_stream(S(query_io),strmflags_wr_ch_B);
3784     Symbol_value(S(debug_io)) = make_twoway_stream(popSTACK(),stream);
3785   }
3786   if (p->argv_on_error == ON_ERROR_DEFAULT)
3787     p->argv_on_error =
3788       (!p->argv_repl
3789        && (p->argv_compile || p->argv_execute_file || p->argv_expr_count))
3790       ? ON_ERROR_EXIT : ON_ERROR_DEBUG;
3791   install_global_handlers(p->argv_on_error);
3792   switch (p->argv_ansi) {
3793     case 1:                     /* Maximum ANSI CL compliance */
3794       { pushSTACK(T); funcall(L(set_ansi),1); break; }
3795     case 2:                     /* The traditional CLISP behavior */
3796       { pushSTACK(NIL); funcall(L(set_ansi),1); break; }
3797     default:                /* use the settings from the memory image */
3798       break;
3799   }
3800   if (p->argv_modern) {
3801     /* (IN-PACKAGE "CS-COMMON-LISP-USER") */
3802     Symbol_value(S(packagestar)) = O(modern_user_package);
3803     /* (SETQ *PRINT-CASE* :DOWNCASE) */
3804     Symbol_value(S(print_case)) = S(Kdowncase);
3805   }
3806   if (p->argv_load_compiling)   /* (SETQ *LOAD-COMPILING* T) : */
3807     { Symbol_value(S(load_compiling)) = T; }
3808   if (p->argv_verbose < 1) /* (setq *load-verbose* nil *compile-verbose* nil
3809                                     *saveinitmem-verbose* nil) */
3810     Symbol_value(S(load_verbose)) = Symbol_value(S(compile_verbose)) =
3811       Symbol_value(S(saveinitmem_verbose)) = NIL;
3812   if (p->argv_verbose > 2) /* (setq *load-print* t *compile-print* t
3813                                     *report-error-print-backtrace* t) */
3814     Symbol_value(S(report_error_print_backtrace)) =
3815       Symbol_value(S(load_print)) = Symbol_value(S(compile_print)) = T;
3816   if (p->argv_verbose > 3)      /* (setq *load-echo* t) */
3817     Symbol_value(S(load_echo)) = T;
3818   if (p->argv_developer) { /* developer mode */
3819     /* unlock all packages */
3820     var object packlist = O(all_packages);
3821     while (consp(packlist)) {
3822       mark_pack_unlocked(Car(packlist));
3823       packlist = Cdr(packlist);
3824     }
3825   }
3826   if (p->argv_help_image) { /* -help-image */
3827     if (p->argv_memfile == NULL) return;
3828     pushSTACK(var_stream(S(standard_output),strmflags_wr_ch_B));
3829     if (nullpSv(script))
3830       write_sstring(&STACK_0,CLSTEXT("All positional arguments are put into "));
3831     else
3832       write_sstring(&STACK_0,CLSTEXT("The first positional argument is the script name,\nthe rest are put into "));
3833     prin1(&STACK_0,S(args));
3834     terpri(&STACK_0);
3835     var object image_doc = Symbol_value(S(image_doc));
3836     if (stringp(image_doc))
3837       write_string(&STACK_0,image_doc);
3838     fresh_line(&STACK_0);
3839     skipSTACK(1);
3840     return;
3841   }
3842   /* set *user-lib-directory* */
3843   pushSTACK(ascii_to_string(".clisp/")); pushSTACK(O(user_homedir));
3844   funcall(L(merge_pathnames),2); pushSTACK(value1); /* ~/.clisp/ */
3845   pushSTACK(S(Kerror)); pushSTACK(NIL);             /* ignore errors */
3846   funcall(L(probe_pathname),3);
3847   if (pathnamep(value1)
3848       && nullp(ThePathname(value1)->pathname_name)
3849       && nullp(ThePathname(value1)->pathname_type))
3850     /* ~/.clisp/ exists and is a directory */
3851     Symbol_value(S(user_lib_directory)) = value1;
3852   else Symbol_value(S(user_lib_directory)) = NIL;
3853   /* load RC file ~/.clisprc */
3854   if (nullpSv(norc) && !p->argv_norc && p->argv_memfile) {
3855     var gcv_object_t* top_of_frame = STACK; /* pointer over frame */
3856     var sp_jmp_buf returner; /* return point */
3857     finish_entry_frame(DRIVER,returner,,goto done_driver_rc;);
3858     { /* If no memfile is given, LOAD cannot be called with 3 arguments.
3859        (LOAD (MAKE-PATHNAME :NAME ".clisprc"
3860                             :DEFAULTS (USER-HOMEDIR-PATHNAME))
3861              :IF-DOES-NOT-EXIST NIL) */
3862       pushSTACK(S(Kname));
3863       pushSTACK(ascii_to_string(".clisprc"));
3864       pushSTACK(S(Kdefaults));
3865       pushSTACK(O(user_homedir)); /* (user-homedir-pathname) */
3866       funcall(L(make_pathname),4);
3867       pushSTACK(value1);
3868       pushSTACK(S(Kif_does_not_exist));
3869       pushSTACK(S(nil));
3870       funcall(S(load),3);
3871     }
3872    done_driver_rc:
3873     setSTACK(STACK = top_of_frame); /* skip driver-frame */
3874   }
3875   /* augment *LOAD-PATHS* from -lp - after loading RC so that setting
3876    *LOAD-PATHS* in ~/.clisprc does not override the command line */
3877   if (p->argv_load_paths_count > 0) {
3878     var const argv_compile_file_t* fileptr = &p->argv_load_paths[-1];
3879     var uintL count = p->argv_load_paths_count;
3880     do { pushSTACK(asciz_to_string((fileptr--)->input_file,O(misc_encoding))); }
3881     while (--count);
3882     pushSTACK(Symbol_value(S(load_paths)));
3883     funcall(L(liststar),p->argv_load_paths_count+1);
3884     Symbol_value(S(load_paths)) = value1;
3885   }
3886   /* execute (LOAD initfile) for each initfile: */
3887   if (p->argv_init_filecount > 0) {
3888     var gcv_object_t* top_of_frame = STACK; /* pointer over frame */
3889     var sp_jmp_buf returner; /* return point */
3890     var const char* const* fileptr = &p->argv_init_files[0];
3891     var uintL count = p->argv_init_filecount;
3892     finish_entry_frame(DRIVER,returner,,goto done_driver_init_files;);
3893     do {
3894       pushSTACK(asciz_to_string(*fileptr++,O(misc_encoding)));
3895       funcall(S(load),1);
3896     } while (--count);
3897    done_driver_init_files:
3898     setSTACK(STACK = top_of_frame); /* skip driver-frame */
3899   }
3900   if (p->argv_compile) {
3901     /* execute
3902      (COMPILE-FILE (setq file (MERGE-PATHNAMES file (MERGE-PATHNAMES #".lisp" (CD))))
3903                    [:OUTPUT-FILE (setq output-file (MERGE-PATHNAMES (MERGE-PATHNAMES output-file (MERGE-PATHNAMES #".fas" (CD))) file))]
3904                    [:LISTING (MERGE-PATHNAMES #".lis" (or output-file file))])
3905      for each file: */
3906     if (p->argv_compile_filecount > 0) {
3907       var gcv_object_t* top_of_frame = STACK; /* pointer over frame */
3908       var sp_jmp_buf returner; /* return point */
3909       var const argv_compile_file_t* fileptr = &p->argv_compile_files[0];
3910       var uintL count = p->argv_compile_filecount;
3911       finish_entry_frame(DRIVER,returner,,goto done_driver_compile_files;);
3912       do {
3913         var uintC argcount = 1;
3914         var object filename = asciz_to_string(fileptr->input_file,O(misc_encoding));
3915         pushSTACK(filename);
3916         pushSTACK(O(source_file_type));      /* #".lisp" */
3917         funcall(L(cd),0); pushSTACK(value1); /* (CD) */
3918         funcall(L(merge_pathnames),2); /* (MERGE-PATHNAMES '#".lisp" (CD)) */
3919         pushSTACK(value1);
3920         funcall(L(merge_pathnames),2); /* (MERGE-PATHNAMES file ...) */
3921         pushSTACK(value1);
3922         if (fileptr->output_file) {
3923           filename = asciz_to_string(fileptr->output_file,O(misc_encoding));
3924           pushSTACK(S(Koutput_file));
3925           pushSTACK(filename);
3926           pushSTACK(O(compiled_file_type));    /* #".fas" */
3927           funcall(L(cd),0); pushSTACK(value1); /* (CD) */
3928           funcall(L(merge_pathnames),2); /* (MERGE-PATHNAMES '#".fas" (CD)) */
3929           pushSTACK(value1);
3930           funcall(L(merge_pathnames),2); /* (MERGE-PATHNAMES output-file ...) */
3931           pushSTACK(value1);
3932           pushSTACK(STACK_2);            /* file */
3933           funcall(L(merge_pathnames),2); /* (MERGE-PATHNAMES ... file) */
3934           pushSTACK(value1);
3935           argcount += 2;
3936         }
3937         if (p->argv_compile_listing) {
3938           pushSTACK(S(Klisting));
3939           pushSTACK(O(listing_file_type)); /* #".lis" */
3940           pushSTACK(STACK_2);              /* (or output-file file) */
3941           funcall(L(merge_pathnames),2); /* (MERGE-PATHNAMES '#".lis" ...) */
3942           pushSTACK(value1);
3943           argcount += 2;
3944         }
3945         funcall(S(compile_file),argcount);
3946         fileptr++;
3947       } while (--count);
3948      done_driver_compile_files:
3949       setSTACK(STACK = top_of_frame); /* skip driver-frame */
3950     }
3951     if (!p->argv_repl)
3952       return;
3953   }
3954   if (p->argv_package != NULL) { /* (IN-PACKAGE packagename) */
3955     var object packname = asciz_to_string(p->argv_package,O(misc_encoding));
3956     pushSTACK(packname);
3957     var object package = find_package(packname);
3958     if (!nullp(package)) {
3959       Symbol_value(S(packagestar)) = package;
3960     } else {
3961       pushSTACK(var_stream(S(standard_output),strmflags_wr_ch_B));
3962       terpri(&STACK_0);
3963       write_sstring(&STACK_0,CLSTEXT("WARNING: no such package: "));
3964       write_sstring(&STACK_0,STACK_1);
3965       terpri(&STACK_0);
3966       skipSTACK(1);
3967     }
3968     skipSTACK(1);
3969   }
3970   if (p->argv_execute_file != NULL && !nullpSv(script)) {
3971     var gcv_object_t* top_of_frame = STACK; /* pointer over frame */
3972     var sp_jmp_buf returner; /* return point */
3973     finish_entry_frame(DRIVER,returner,,goto done_driver_execute_file;);
3974     { /*  execute:
3975        (PROGN
3976          #+UNIX (SET-DISPATCH-MACRO-CHARACTER #\##\!
3977                  (FUNCTION SYS::UNIX-EXECUTABLE-READER))
3978          (SETQ *LOAD-VERBOSE* NIL)
3979          (LOAD argv_execute_file :EXTRA-FILE-TYPES ...)
3980          (UNLESS argv_repl (EXIT))) */
3981      #if defined(UNIX) || defined(WIN32_NATIVE)
3982       /* Make clisp ignore the leading #! line. */
3983       pushSTACK(ascii_char('#')); pushSTACK(ascii_char('!'));
3984       pushSTACK(L(unix_executable_reader));
3985       funcall(L(set_dispatch_macro_character),3);
3986      #endif
3987       Symbol_value(S(load_verbose)) = NIL;
3988       if (asciz_equal(p->argv_execute_file,"-")) {
3989         pushSTACK(Symbol_value(S(standard_input))); /* *STANDARD-INPUT* */
3990       } else {
3991         pushSTACK(asciz_to_string(p->argv_execute_file,O(misc_encoding)));
3992       }
3993      #ifdef WIN32_NATIVE
3994       pushSTACK(S(Kextra_file_types));
3995       pushSTACK(O(load_extra_file_types));
3996       funcall(S(load),3);
3997      #else
3998       funcall(S(load),1);
3999      #endif
4000     }
4001    done_driver_execute_file:
4002     setSTACK(STACK = top_of_frame); /* skip driver-frame */
4003     if (!p->argv_repl)
4004       return;
4005   } else if (p->argv_execute_file) { /* !scripting => (push exec-file *args*) */
4006     push_to_args(p->argv_execute_file);
4007   }
4008   if (p->argv_expr_count) {
4009     /* set *STANDARD-INPUT* to a stream, that produces argv_exprs: */
4010     var const char* const* exprs = &p->argv_exprs[-1];
4011     if (p->argv_expr_count > 1) {
4012       var uintL count = p->argv_expr_count;
4013       do { pushSTACK(asciz_to_string(*exprs--,O(misc_encoding))); }
4014       while (--count);
4015       var object total = string_concat(p->argv_expr_count);
4016       pushSTACK(total);
4017     } else
4018       pushSTACK(asciz_to_string(*exprs--,O(misc_encoding)));
4019     funcall(L(make_string_input_stream),1);
4020     /* During bootstrapping, *DRIVER* has no value and SYS::BATCHMODE-ERRORS
4021      is undefined. Do not set an error handler in that case.
4022      we use SYS::MAIN-LOOP instead of the image-specific user-defined
4023      SYS::*DRIVER* so that the users can always get to the repl using
4024      -x '(saveinitmem ...)'
4025     SYS::MAIN-LOOP calls DRIVER, so we do not need to do
4026       finish_entry_frame(DRIVER,returner,,;);
4027     here */
4028     var object main_loop_function = Symbol_function(S(main_loop));
4029     if (closurep(main_loop_function)) { /* see reploop.lisp:main-loop ! */
4030       dynamic_bind(S(standard_input),value1);
4031       /* (MAIN-LOOP !p->argv_repl) */
4032       pushSTACK(p->argv_repl ? NIL : T);
4033       funcall(main_loop_function,1);
4034       dynamic_unbind(S(standard_input));
4035     } else /* no *DRIVER* => bootstrap, no -repl */
4036       Symbol_value(S(standard_input)) = value1;
4037   }
4038   /* call read-eval-print-loop: */
4039   driver();
4040 }
4041 
4042 #if defined(MULTITHREAD)
4043 /* UP: main_actions() replacement in MT.
4044  > param: clisp_thread_t structure of the first lisp thread */
mt_main_actions(void * param)4045 local THREADPROC_SIGNATURE mt_main_actions (void *param)
4046 {
4047   #if USE_CUSTOM_TLS == 2
4048   tse __tse_entry;
4049   tse *__thread_tse_entry=&__tse_entry;
4050   #endif
4051   clisp_thread_t *me=(clisp_thread_t *)param;
4052   /* dummy way to pass arguments :(*/
4053   struct argv_actions *args = (struct argv_actions *)me->_SP_anchor;
4054   set_current_thread(me); /* initialize TLS */
4055   me->_SP_anchor=(void*)SP();
4056   /* reinitialize the system thread id */
4057   TheThread(me->_lthread)->xth_system = xthread_self();
4058   /* initialize thread special varaible bindings */
4059   pushSTACK(Symbol_value(S(default_special_bindings)));
4060   initialize_thread_bindings(&STACK_0);
4061   skipSTACK(1);
4062   /* create a CATCH frame here for thread exit */
4063   pushSTACK(O(thread_exit_tag));
4064   var gcv_object_t* top_of_frame = STACK STACKop 1;
4065   var sp_jmp_buf returner; /* return point */
4066   finish_entry_frame(CATCH,returner,,{
4067     skipSTACK(2); STACK_0=value1; goto thread_killed;});
4068   init_time(); /* initialize thread time variables */
4069   init_reader_low(me); /* initialize the low level i/o for this thread*/
4070   /* now we are ready to start main_actions()*/
4071   main_actions(args);
4072   skipSTACK(3); /* unwind CATCH-frame */
4073   mv_to_list(); /* store thread exit values on STACK */
4074   /* mark that thread will exit normally */
4075   TheThread(me->_lthread)->xth_flags |= thread_flag_normal_exit;
4076  thread_killed:
4077   thread_cleanup();
4078   delete_thread(me); /* just delete ourselves */
4079   /* NB: the LISP stack is "leaked" - in a sense nobody will
4080      ever use it anymore !!!*/
4081   xthread_exit(0);
4082   return NULL; /* keep compiler happy */
4083 }
4084 #endif
4085 
4086 static struct argv_initparams argv1;
4087 static struct argv_actions argv2;
4088 
4089 /* main program stores the name 'main'. */
4090 #ifndef argc_t
4091   #define argc_t int            /* Type of argc is mostly 'int'. */
4092 #endif
main(argc_t argc,char * argv[])4093 global int main (argc_t argc, char* argv[]) {
4094   /* initialization of memory management.
4095    overall procedure:
4096    process command-line-options.
4097    determine memory partitioning.
4098    look at command string and either load LISP-data from .MEM-file
4099    or create manually and initialize static LISP-data.
4100    build up interrupt-handler.
4101    print banner.
4102    jump into the driver.
4103   This is also described in <doc/impext.xml#cradle-grave>! */
4104 #if defined(MULTITHREAD)
4105 /* if on 32 bit machine, no per_thread and asked by the user*/
4106   #if USE_CUSTOM_TLS == 2
4107   tse __tse_entry;
4108   tse *__thread_tse_entry=&__tse_entry;
4109   #endif
4110   /* initialize main thread */
4111   {
4112     init_multithread();
4113     init_heaps_mt();
4114     set_current_thread(create_thread(0));
4115     #ifdef DEBUG_GCSAFETY
4116       use_dummy_alloccount=false; /* now we have threads */
4117       current_thread()->_alloccount=1;
4118     #endif
4119   }
4120 #endif
4121   init_lowest_level(argv);
4122   init_stream_osdeps();
4123   var struct argv_init_c argv0;
4124   {
4125     var int parse_result =
4126       parse_options(argc,(const char**)argv,&argv0,&argv1,&argv2);
4127     if (parse_result >= 0)
4128       quit_instantly(parse_result);
4129   }
4130   /* The argv_* variables now have their final values.
4131    Analyze the environment variables determining the locale.
4132    Deal with LC_CTYPE. */
4133   init_ctype();
4134   /* Deal with LC_MESSAGE.
4135    (This must come last, because it may unset environment variable LC_ALL) */
4136  #ifdef GNU_GETTEXT
4137   init_language(argv0.argv_language,argv0.argv_localedir,false);
4138  #endif
4139 
4140   /* Initialize memory and load a memory image (if specified). */
4141   if (init_memory(&argv1) < 0) goto no_mem;
4142   switch (argv2.argv_main_action) {
4143      case action_mfihash:
4144        { var uintB mfihash[MFIH_LEN];
4145          get_mem_file_interface_hash(&mfihash[0]);
4146          output_mfih(&mfihash[0]);
4147          return 0;
4148        }
4149      case action_mfihash_of:
4150        { var uintB mfihash[MFIH_LEN];
4151          extract_mem_file_interface_hash(&mfihash[0],argv2.argv_memfile);
4152          output_mfih(&mfihash[0]);
4153          return 0;
4154        }
4155      case action_mfcompat:
4156        { var bool compatible = is_mem_file_compatible(argv2.argv_memfile);
4157          return (compatible ? 0 : 1);
4158        }
4159      default: ;
4160   }
4161   SP_anchor = (void*)SP(); /* VTZ: in MT current_thread() should be initialized */
4162 #if defined(MULTITHREAD)
4163   /* after heap is initialized - allocate thread record for main thread.
4164      no locking is needed here*/
4165   {
4166     /* VTZ:TODO when we are loaded from mem file - we should restore the
4167      threads from there.
4168      Currently we just register our main thread and do not care what we have in
4169      mem file!!! Threads do not survive mem file save/restore - just create
4170      garbage in it :( */
4171     /* TODO: give better name :)*/
4172     var object thr_name = coerce_imm_ss(ascii_to_string(GETTEXT("main thread")));
4173     pushSTACK(thr_name);
4174     pushSTACK(allocate_thread(&STACK_0));
4175     var object new_cons=allocate_cons();
4176     var object lthr;
4177     /* add to all_threads global */
4178     Car(new_cons) = lthr = popSTACK();
4179     Cdr(new_cons) = O(all_threads);
4180     O(all_threads) = new_cons;
4181     /* initialize the thread references */
4182     current_thread()->_lthread=lthr;
4183     TheThread(lthr)->xth_globals=current_thread();
4184     TheThread(lthr)->xth_system=xthread_self();
4185     skipSTACK(1);
4186   }
4187 #endif
4188   /* if the image was read from the executable, argv1.argv_memfile was
4189      set to exec name and now it has to be propagated to argv2.argv_memfile
4190      to avoid the beginner warning */
4191   argv2.argv_memfile = argv1.argv_memfile; /* propagate exec name */
4192   /* Prepare for catching SP overflow. */
4193   install_stackoverflow_handler(0x4000); /* 16 KB reserve should be enough */
4194   /* everything completely initialized. */
4195  {var struct backtrace_t bt;
4196   bt.bt_next = NULL;
4197   bt.bt_function = L(driver);
4198   bt.bt_stack = STACK STACKop -1;
4199   bt.bt_num_arg = -1;
4200   back_trace = &bt;
4201   clear_break_sems(); set_break_sem_1();
4202   begin_system_call();
4203 
4204  #if defined(WIN32_NATIVE)
4205   /* cannot do it in init_win32 - too early */
4206   if (isatty(stdout_handle)) {
4207     var HANDLE handle = GetStdHandle(STD_OUTPUT_HANDLE);
4208     if (handle!=INVALID_HANDLE_VALUE) {
4209       var CONSOLE_SCREEN_BUFFER_INFO info;
4210       if (GetConsoleScreenBufferInfo(handle,&info))
4211         Symbol_value(S(prin_linelength)) = fixnum(info.dwSize.X - 1);
4212     }
4213   }
4214  #endif
4215   /* Establish signal handler for SIGWINCH and query the size of the
4216      terminal window also now on program start: */
4217  #if defined(HAVE_SIGNALS)
4218   #if defined(SIGWINCH) && !defined(NO_ASYNC_INTERRUPTS) && !defined(MULTITHREAD)
4219   install_sigwinch_handler();
4220   #endif
4221   update_linelength();
4222  #endif
4223   /* handling of async interrupts with single thread */
4224 #if !defined(MULTITHREAD)
4225   /* establish interrupt-handler: */
4226  #if (defined(HAVE_SIGNALS) && defined(UNIX)) || defined(WIN32_NATIVE)
4227   /* install Ctrl-C-Handler: */
4228   install_sigint_handler();
4229  #endif
4230  #ifdef HAVE_SIGNALS
4231   install_sigcld_handler();
4232   install_sigterm_handler();    /* install SIGTERM &c handlers */
4233  #endif
4234 #else
4235  #ifdef HAVE_SIGNALS
4236   install_sigcld_handler();
4237  #endif
4238   install_async_signal_handlers();
4239 #endif
4240  #if defined(HAVE_SIGNALS) && defined(SIGPIPE)
4241   install_sigpipe_handler();
4242  #endif
4243   /* initialize global time variables: */
4244   init_time();
4245   /* Initialize locale dependent encodings: */
4246   init_dependent_encodings();
4247   /* initialize stream-variables: */
4248   init_streamvars(argv2.argv_batchmode_p);
4249   INIT_READER_LOW();            /* token buffers */
4250  #ifdef MULTITHREAD
4251   /* now we can initialize all per thread special variables. till now
4252      we did this in initmem() and we missed the streams specials. */
4253   /* NB: currently *FEATURES* is not treated differently */
4254   if (num_symvalues == FIRST_SYMVALUE_INDEX) {
4255     /* only if we did not already loaded from image */
4256     init_multithread_special_symbols();
4257   }
4258  #endif
4259   /* make break possible: */
4260   end_system_call();
4261   clr_break_sem_1();
4262   /* initialize pathnames: */
4263   init_pathnames();
4264  #ifdef DYNAMIC_FFI
4265   /* initialize FFI: */
4266   init_ffi();
4267  #endif
4268   init_other_modules_2();     /* initialize modules yet uninitialized */
4269   { /* final module initializations: */
4270     var module_t* module;     /* loop over modules */
4271     for_modules(all_other_modules,{
4272       if (module->initfunction2)
4273         /* call initialization function: */
4274         (*module->initfunction2)(module);
4275     });
4276   }
4277   /* do this before O(argv) is ready so that applications cannot
4278      detect and thus disable "--clisp-" superarg
4279      http://clisp.org/impnotes/image.html#image-exec */
4280   run_hooks(Symbol_value(S(init_hooks)));
4281   { /* Init O(argv). */
4282     O(argv) = allocate_vector(argc);
4283     var argc_t count;
4284     for (count = 0; count < argc; count++) {
4285       var object arg = asciz_to_string(argv[count],O(misc_encoding));
4286       TheSvector(O(argv))->data[count] = arg;
4287     }
4288   }
4289   /* Perform the desired actions (compilations, read-eval-print loop etc.): */
4290 #if defined(MULTITHREAD)
4291   /* may be set it as command line  parameter  - it should be big enough */
4292   #define MAIN_THREAD_C_STACK (1024*1024*16)
4293   SP_anchor=(void *)&argv2;
4294   {
4295     var xthread_t thr;
4296     var clisp_thread_t *param = current_thread();
4297     /* Remove the current thread from threads map */
4298   #if USE_CUSTOM_TLS == 3
4299     /* Since initial thread stack is growable (at least on linux), the
4300        stack range mapped when thread was registered is maximum possible one.
4301        Now pthread_attr_getstack will return (most probably) different range
4302        (smaller) and if we try to unmap it - there will be some mappings left.
4303        This is not a problem in general but it helps for debugging to clear
4304        the whole map.*/
4305     memset(threads_map, 0, sizeof(threads_map));
4306   #elif USE_CUSTOM_TLS == 2
4307     /* we can use set_current_thread(NULL) as well but this will leave
4308        a dummy bucket in the hash table and may slow down the lookups.
4309        better - remove entirely */
4310     tsd_remove_specific();
4311   #else
4312     set_current_thread(NULL); /* no associated lisp thread */
4313   #endif
4314     xthread_create(&thr, mt_main_actions, param, MAIN_THREAD_C_STACK);
4315   }
4316   thr_signal_handler = xthread_self();
4317   /* let's handle signals now :)*/
4318   signal_handler_thread(0);
4319   /* NOTREACHED */
4320 #else
4321   main_actions(&argv2);
4322   quit();
4323 #endif
4324   /*NOTREACHED*/
4325  } /* end var bt */
4326   /* if the memory does not suffice: */
4327   no_mem:
4328   fprintf(stderr,GETTEXTL("%s: Not enough memory for Lisp."),program_name);
4329   fprint(stderr,"\n");
4330   quit_instantly(1);
4331   /*NOTREACHED*/
4332   /* termination of program via quit_instantly(): */
4333   return 0; /* we should never reach here anyway */
4334 }
4335 
4336 /* UP: leave LISP immediately: quit_instantly(exitcode);
4337  > exitcode: 0 for normal, 1 for abnormal end of program, -signum for signal
4338    we must set the SP to the original value.
4339    (On some operating systems, the memory occupied by the program is
4340    returned with free() , before control is withdrawn from it.
4341    For this short span the SP has to be set reasonably.)
4342    In threads builds it is not good to make longjmp() across
4343    threads. Since argv1 and argv2 are global now - it's ok to
4344    have quit_instantly() as function */
quit_instantly(int exitcode)4345 local _Noreturn void quit_instantly (int exitcode)
4346 {
4347   free_argv_initparams(&argv1);
4348   free_argv_actions(&argv2);
4349   fini_lowest_level();
4350   if (exitcode < 0) {
4351     var int sig = -exitcode;
4352     #ifdef HAVE_SIGNALS
4353      /* Reset the signal handler. */
4354      SIGNAL(sig,SIG_DFL);
4355      /* Unblock the signal. */
4356      #if defined(SIGNALBLOCK_POSIX)
4357      {
4358        var sigset_t sigblock_mask;
4359        sigemptyset(&sigblock_mask); sigaddset(&sigblock_mask,sig);
4360        sigprocmask(SIG_UNBLOCK,&sigblock_mask,NULL);
4361      }
4362      #endif
4363      /* Raise the signal. */
4364      raise(sig);
4365     #endif
4366     /* If that did not help: use a fake exit code that encodes the signal. */
4367     exitcode = 128 + sig;
4368   }
4369  #ifdef UNIX
4370   exit(exitcode); /* Calling exit(), not _exit(), allows profiling to work. */
4371  #endif
4372  #ifdef WIN32_NATIVE
4373   _exit(exitcode);
4374  #endif
4375 }
4376 
4377 /* leave LISP-interpreter
4378  quit();
4379  > final_exitcode: 0 for normal, 1 for abnormal end of program, -signum for signal */
4380 global int final_exitcode = 0;
4381 global bool quit_on_signal_in_progress = false;
4382 local int quit_retry = 0;
quit(void)4383 global _GL_NORETURN_FUNC void quit (void) {
4384   /* first "unwind" the STACK downto STACK-end: */
4385   VALUES0; /* do not save values for UNWIND-PROTECT-frames */
4386   unwind_protect_to_save.fun = (restartf_t)&quit;
4387   while (!(eq(STACK_0,nullobj) && eq(STACK_1,nullobj)))
4388     if (framecode(STACK_0) & bit(frame_bit_t))
4389       /* At STACK_0 a frame starts */
4390       { unwind(); }             /* unwind frame */
4391     else
4392       /* STACK_0 contains a normal LISP-object */
4393       { skipSTACK(1); }
4394   run_hooks(Symbol_value(S(fini_hooks)));
4395   /* Then, a farewell message: */
4396   if (quit_retry==0) {
4397     quit_retry++;  /* If this fails, do not retry it. For robustness. */
4398     /* when running as a script, i.e. "clisp lisp-file",
4399         *standard-input*  is /dev/fd/0
4400         *standard-output* is /dev/fd/1
4401         *error-output*    is /dev/fd/2
4402        and *terminal-io* is an #<IO TERMINAL-STREAM>,
4403        so they all need to be terminated individually */
4404     funcall(L(fresh_line),0);   /* (FRESH-LINE [*standard-output*]) */
4405     funcall(L(finish_output),0); /* (FINISH-OUTPUT [*standard-output*]) */
4406     pushSTACK(var_stream(S(error_output),strmflags_wr_ch_B));pushSTACK(STACK_0);
4407     funcall(L(fresh_line),1);   /* (FRESH-LINE *error-output*) */
4408     funcall(L(finish_output),1); /* (FINISH-OUTPUT *error-output*) */
4409     pushSTACK(Symbol_value(S(terminal_io))); pushSTACK(STACK_0);
4410     funcall(L(fresh_line),1);   /* (FRESH-LINE *terminal-io*) */
4411     funcall(L(finish_output),1); /* (FINISH-OUTPUT *terminal-io*) */
4412     if (argv2.argv_verbose >= 2) {
4413       pushSTACK(CLSTEXT("Bye.")); funcall(L(write_line),1);
4414     }
4415   }
4416   /* Then wait for a keypress: */
4417   if (argv2.argv_wait_keypress) {
4418     argv2.argv_wait_keypress = false; /* If this fails, do not retry it (robustness) */
4419     pushSTACK(CLSTEXT("Press a key to terminate..."));
4420     funcall(L(write_line),1);
4421     funcall(S(wait_keypress),0); /* (SYS::WAIT-KEYPRESS) */
4422   }
4423   close_all_files();            /* close all files */
4424   { /* module finalization: */
4425     var module_t* module;       /* loop over modules */
4426     for_modules(all_other_modules,{
4427       if (module->finifunction) /* call exit function: */
4428         (*module->finifunction)(module);
4429     });
4430   }
4431  #ifdef DYNAMIC_FFI
4432   exit_ffi();                   /* close FFI */
4433  #endif
4434   quit_instantly(final_exitcode);  /* leave program */
4435 }
4436 
4437 /* ------------------------ dll loading ----------------------------------- */
4438 #if defined(WIN32_NATIVE) || defined(HAVE_DLOPEN)
4439 
4440 #if defined(HAVE_DLFCN_H)
4441 #include <dlfcn.h>
4442 #endif
4443 
4444 /* open the dynamic library
4445  libname is the name of the library
4446  returns a handle suitable for find_name()
4447  calls dlopen() or LoadLibrary() */
libopen(const char * libname)4448 global void * libopen (const char* libname)
4449 {
4450  #if defined(WIN32_NATIVE)
4451   return (void*)LoadLibrary(libname);
4452  #else
4453   /* FIXME: On UNIX_MACOSX, need to search for the library in /usr/lib */
4454   return dlopen(libname,RTLD_NOW|RTLD_GLOBAL);
4455  #endif
4456 }
4457 
4458 #if defined(WIN32_NATIVE)
4459 /* #include <psapi.h> */
4460 /* support older woe32 incarnations:
4461    fEnumProcessModules is 1 until the first call,
4462    it is NULL if this woe32 does not have EnumProcessModules(),
4463    and it points to EnumProcessModules() when it is present */
4464 typedef BOOL (WINAPI * EnumProcessModules_t)
4465   (HANDLE hProcess,HMODULE* lphModule,DWORD cb,LPDWORD lpcbNeeded);
4466 static EnumProcessModules_t fEnumProcessModules = (EnumProcessModules_t)1;
4467 #endif
4468 
4469 /* find the name in the dynamic library handle
4470  calls dlsym() or GetProcAddress()
4471  handle is an object returned by libopen()
4472         or NULL, which means emulate RTLD_DEFAULT on older FreeBSD and AIX
4473         and WIN32_NATIVE by searching through all libraries
4474  name is the name of the function (or variable) in the library */
find_name(void * handle,const char * name)4475 global void* find_name (void *handle, const char *name)
4476 {
4477   var void *ret = NULL;
4478  #if defined(WIN32_NATIVE)
4479   if (handle == NULL) { /* RTLD_DEFAULT -- search all modules */
4480     HANDLE cur_proc;
4481     HMODULE *modules;
4482     DWORD needed, i;
4483     if ((EnumProcessModules_t)1 == fEnumProcessModules) {
4484       /* first call: try to load EnumProcessModules */
4485       HMODULE psapi = LoadLibrary("psapi.dll");
4486       if (psapi == NULL) fEnumProcessModules = NULL;
4487       else fEnumProcessModules =
4488         (EnumProcessModules_t)GetProcAddress(psapi,"EnumProcessModules");
4489     }
4490     if (NULL != fEnumProcessModules) {
4491       cur_proc = GetCurrentProcess();
4492       if (!fEnumProcessModules(cur_proc,NULL,0,&needed)) OS_error();
4493       var DYNAMIC_ARRAY(modules_mem,char,needed);
4494       modules = (HMODULE*)modules_mem;
4495       if (!fEnumProcessModules(cur_proc,modules,needed,&needed)) OS_error();
4496       for (i=0; i < needed/sizeof(HMODULE); i++)
4497         if ((ret = (void*)GetProcAddress(modules[i],name)))
4498           break;
4499       FREE_DYNAMIC_ARRAY(modules_mem);
4500     }
4501   } else ret = (void*)GetProcAddress((HMODULE)handle,name);
4502  #elif !defined(RTLD_DEFAULT)
4503   /* FreeBSD 4.0 and AIX 5.1 do not support RTLD_DEFAULT, so we emulate it by
4504      searching the executable and the libc. */
4505   if (handle == NULL) {
4506     /* Search the executable. */
4507     ret = dlsym(NULL,name);
4508     if (ret == NULL) {
4509       /* Search the libc. */
4510       static void* libc_handle;
4511       if (libc_handle == NULL)
4512         libc_handle = dlopen("libc.so",RTLD_LAZY);
4513       if (libc_handle != NULL)
4514         ret = dlsym(libc_handle,name);
4515     }
4516   } else
4517     ret = dlsym(handle,name);
4518  #else
4519   ret = dlsym(handle,name);
4520  #endif
4521   return ret;
4522 }
4523 
4524 #endif  /* defined(WIN32_NATIVE) || defined(HAVE_DLOPEN) */
4525 
4526 /* --------------------------------------------------------------------------
4527                        Dynamic Loading of Modules */
4528 
4529 #ifdef DYNAMIC_MODULES
4530 
4531 /* Attaches a shared library to this process' memory, and attempts to load
4532  a number of clisp modules from it. */
error_dlerror(const char * func,const char * symbol,object errstring)4533 local _Noreturn void error_dlerror (const char* func, const char* symbol,
4534                                     object errstring) {
4535   end_system_call();
4536   pushSTACK(errstring);
4537   if (symbol != NULL)
4538     pushSTACK(asciz_to_string(symbol,O(internal_encoding)));
4539   pushSTACK(asciz_to_string(func,O(internal_encoding)));
4540   pushSTACK(TheSubr(subr_self)->name);
4541   error(error_condition,(symbol == NULL ? "~S: ~S -> ~S" : "~S: ~S(~S) -> ~S"));
4542 }
4543 
dlerror_message(void)4544 local object dlerror_message (void) {
4545   end_system_call();
4546  #if defined(HAVE_DLERROR)
4547   var char * e = dlerror();
4548   /* g++ needs explicit cast here */
4549   return e == NULL ? (object)O(unknown_error) : asciz_to_string(e,O(misc_encoding));
4550  #elif defined(WIN32_NATIVE)
4551   var char* buf;
4552   /* note that this message is likely to be less informative
4553      than the pop-up error window enabled by SetErrorMode(0);
4554      http://groups.google.com/group/microsoft.public.win32.programmer.kernel/browse_thread/thread/e720d92269df1398/b2381f02f3bfc8a3 */
4555   FormatMessage(FORMAT_MESSAGE_ALLOCATE_BUFFER | FORMAT_MESSAGE_FROM_SYSTEM
4556                 | FORMAT_MESSAGE_IGNORE_INSERTS,
4557                 NULL, GetLastError(), 0, (char*)&buf, 0, NULL);
4558   var object ret = asciz_to_string(buf,O(misc_encoding));
4559   LocalFree(buf);
4560   return ret;
4561  #else
4562   return O(unknown_error);
4563 #endif
4564 }
4565 
4566 /* find the symbol, signal an error if not found
4567  format: a format string with a single %s, substituted with ...
4568  modname: the name of the module
4569  libhandle: the dll handle, returned by libopen()
4570  returns: non-NULL pointer to the symbol in the library */
get_module_symbol(const char * format,const char * modname,void * libhandle)4571 local void* get_module_symbol (const char* format, const char* modname,
4572                                void* libhandle) {
4573   var DYNAMIC_ARRAY(symbolbuf,char,strlen(format)+strlen(modname));
4574   sprintf(symbolbuf,format,modname);
4575   var void * ret = find_name(libhandle,symbolbuf);
4576   if (ret == NULL) error_dlerror("dlsym",symbolbuf,dlerror_message());
4577   FREE_DYNAMIC_ARRAY(symbolbuf);
4578   return ret;
4579 }
4580 
dynload_modules(const char * library,uintC modcount,const char * const * modnames)4581 global maygc void dynload_modules (const char * library, uintC modcount,
4582                                    const char * const * modnames) {
4583   var void* libhandle;
4584   /* Open the library. */
4585   begin_blocking_system_call();
4586   libhandle = libopen(library);
4587   end_blocking_system_call();
4588   if (libhandle == NULL) error_dlerror("dlopen",NULL,dlerror_message());
4589   if (modcount > 0) {
4590     /* What's the longest module name? What's their total size? */
4591     var uintL total_modname_length = 0;
4592     begin_system_call();
4593     {
4594       var const char * const * modnameptr = modnames;
4595       var uintC count = modcount;
4596       do {
4597         var uintL len = asciz_length(*modnameptr);
4598         total_modname_length += len+1;
4599         modnameptr++;
4600       } while (--count);
4601     }
4602     {                        /* Make room for the module descriptors. */
4603       var module_t* modules = (module_t*)clisp_malloc(modcount*sizeof(module_t)+total_modname_length);
4604       {
4605         var char* modnamebuf = (char*)(&modules[modcount]);
4606         var const char * const * modnameptr = modnames;
4607         var module_t* module = modules;
4608         var uintC count = modcount;
4609         do {
4610           var const char * modname = *modnameptr;
4611           var uintL len = asciz_length(modname);
4612           var const char * err;
4613           /* Copy modname into modnamebuf: */
4614           module->name = modnamebuf;
4615           {
4616             var const char * ptr = modname;
4617             while ((*modnamebuf++ = *ptr++) != '\0') {}
4618           }
4619           /* Find the addresses of some C data in the shared library: */
4620           module->stab = (subr_t*) ((char*) get_module_symbol("module__%s__subr_tab",modname,libhandle) + varobjects_misaligned);
4621           module->stab_size = (const uintC*) get_module_symbol("module__%s__subr_tab_size",modname,libhandle);
4622           module->otab = (gcv_object_t*) get_module_symbol("module__%s__object_tab",modname,libhandle);
4623           module->otab_size = (const uintC*) get_module_symbol("module__%s__object_tab_size",modname,libhandle);
4624           module->initialized = false;
4625           module->stab_initdata = (const subr_initdata_t*) get_module_symbol("module__%s__subr_tab_initdata",modname,libhandle);
4626           module->otab_initdata = (const object_initdata_t*) get_module_symbol("module__%s__object_tab_initdata",modname,libhandle);
4627           /* Find the addresses of some C functions in the shared library: */
4628           module->initfunction1 = (void (*) (module_t*)) get_module_symbol("module__%s__init_function_1",modname,libhandle);
4629           module->initfunction2 = (void (*) (module_t*)) get_module_symbol("module__%s__init_function_2",modname,libhandle);
4630           module->finifunction = (void (*) (module_t*)) get_module_symbol("module__%s__fini_function",modname,libhandle);
4631           module->next = NULL;
4632           modnameptr++; module++;
4633         } while (--count);
4634       }
4635       end_system_call();
4636       { /* We found all the necessary symbols. Now register the modules. */
4637         var module_t* module = modules;
4638         var uintC mcount = modcount;
4639         while (mcount-- > 0) {
4640           add_module(module);
4641           /* pre-initialization, cf. init_subr_tab_1. */
4642           if (*module->stab_size > 0) module_set_argtypes(module);
4643          #if defined(SINGLEMAP_MEMORY) && defined(MAP_MEMORY_TABLES)
4644           {
4645             var subr_t* newptr = (subr_t*)((char*)&subr_tab+varobjects_misaligned) + total_subr_count;
4646             var uintC count = *module->stab_size;
4647             if (count > 0) {
4648               {
4649                 var uintM old_map_len = round_up(varobjects_misaligned+total_subr_count*sizeof(subr_t),map_pagesize);
4650                 var uintM new_map_len = round_up(varobjects_misaligned+(total_subr_count+count)*sizeof(subr_t),map_pagesize);
4651                 if (old_map_len < new_map_len) {
4652                   if (zeromap((void*)((aint)&subr_tab+old_map_len),new_map_len-old_map_len) <0)
4653                     error_dlerror("zeromap",NULL,O(oomst_error));
4654                 }
4655               }
4656               {
4657                 var subr_t* oldptr = module->stab;
4658                 module->stab = newptr;
4659                 do {
4660                   *newptr = *oldptr++;
4661                   newptr->GCself = subr_tab_ptr_as_object(newptr);
4662                   newptr->name = NIL; newptr->keywords = NIL; /* GC stays possible with it */
4663                   newptr++;
4664                 } while (--count);
4665               }
4666               total_subr_count += *module->stab_size;
4667             }
4668           }
4669          #endif
4670           /* main initialization. */
4671           init_module_2(module);
4672           module++;
4673         }
4674       }
4675       {                         /* Now start the modules' life. */
4676         var module_t* module = modules;
4677         var uintC count = modcount;
4678         do {
4679           if (module->initfunction2) /* call initialization function: */
4680             (*module->initfunction2)(module);
4681           module++;
4682         } while (--count);
4683       }
4684     }
4685   }
4686 }
4687 
4688 #endif
4689 
4690 /* --------------------------------------------------------------------------
4691                       Multithreading signal handling  */
4692 #if defined(MULTITHREAD)
4693 /* UP: acquires both heap and threads lock from signal handler thread
4694    without causing deadlock with the GC in the lisp world. */
lock_heap_from_signal()4695 local void lock_heap_from_signal()
4696 {
4697   while (1) {
4698     while (!spinlock_tryacquire(&mem.alloc_lock))
4699       xthread_yield();
4700     /* we got the heap lock, let's check that there is no GC in progress */
4701     if (!gc_suspend_count)
4702       break; /* no GC in progress */
4703     /* give chance to GC to finish */
4704     spinlock_release(&mem.alloc_lock);
4705     xthread_yield();
4706   }
4707 }
4708 
4709 /* UP: Subtract the `struct timeval' values.
4710  > x: first value
4711  > y: second value
4712  < result: result of substraction.
4713  < returns 1 if the difference is negative, otherwise 0.*/
timeval_subtract(struct timeval * result,struct timeval * x,struct timeval * y)4714 local int timeval_subtract(struct timeval *result,
4715                            struct timeval *x,struct timeval *y)
4716 {
4717   /* Perform the carry for the later subtraction by updating y. */
4718   if (x->tv_usec < y->tv_usec) {
4719     int nsec = (y->tv_usec - x->tv_usec) / 1000000 + 1;
4720       y->tv_usec -= 1000000 * nsec;
4721     y->tv_sec += nsec;
4722   }
4723   if (x->tv_usec - y->tv_usec > 1000000) {
4724     int nsec = (x->tv_usec - y->tv_usec) / 1000000;
4725       y->tv_usec += 1000000 * nsec;
4726     y->tv_sec -= nsec;
4727   }
4728   /* Compute the time remaining to wait.
4729      tv_usec is certainly positive. */
4730   result->tv_sec = x->tv_sec - y->tv_sec;
4731   result->tv_usec = x->tv_usec - y->tv_usec;
4732   /* Return 1 if result is negative. */
4733   return x->tv_sec < y->tv_sec;
4734 }
4735 
4736 /* POSIX_THREADS have signals - the other case is WIN32_NATIVE and
4737    WIN32_THREADS*/
4738 #ifdef HAVE_SIGNALS
4739 
4740 /* SIGUSR1 is used for thread interrupt */
4741 #define SIG_THREAD_INTERRUPT SIGUSR1
4742 /* SIGUSR2 WILL BE used for CALL-WITH-TIMEOUT */
4743 #define SIG_TIMEOUT_CALL SIGUSR2
4744 
4745 /* UP: adds to sigset_t mask all terminating signals we handle
4746  > mask: sigset_t mask to add to */
fill_terminating_signals_mask(sigset_t * mask)4747 local void fill_terminating_signals_mask(sigset_t *mask)
4748 {
4749 #ifdef SIGHUP
4750   sigaddset(mask,SIGHUP);
4751 #endif
4752 #ifdef SIGQUIT
4753   sigaddset(mask,SIGQUIT);
4754 #endif
4755 #ifdef SIGKILL
4756   sigaddset(mask,SIGKILL);
4757 #endif
4758 #ifdef SIGTERM
4759   sigaddset(mask,SIGTERM);
4760 #endif
4761 #ifdef SIGTTOU
4762   /* always ignored */
4763   sigaddset(mask,SIGTTOU);
4764 #endif
4765 }
4766 
4767 /* UP: creates mask of signals that we do not want to be delivered
4768    directly to threads. The same signals are handled by special non
4769    lisp thread */
async_signal_mask()4770 local sigset_t async_signal_mask()
4771 {
4772   var sigset_t sigblock_mask;
4773   sigemptyset(&sigblock_mask);
4774   sigaddset(&sigblock_mask,SIGINT);
4775   sigaddset(&sigblock_mask,SIGALRM);
4776   sigaddset(&sigblock_mask,SIG_TIMEOUT_CALL);
4777  #if defined(SIGWINCH)
4778   sigaddset(&sigblock_mask,SIGWINCH);
4779  #endif
4780   if (!quit_on_signal_in_progress) {
4781     /* add terminating signals */
4782     fill_terminating_signals_mask(&sigblock_mask);
4783   } else {
4784     /* till now terminating signals were blocked so we can retrieve
4785        them synchronously via sigwait(). Now after we got one - unblock
4786        them so on next such the process will be terminated immediately. */
4787     var sigset_t term_mask;
4788     sigemptyset(&term_mask);
4789     fill_terminating_signals_mask(&term_mask);
4790     sigprocmask(SIG_UNBLOCK,&term_mask,NULL);
4791   }
4792   return sigblock_mask;
4793 }
4794 
4795 /* UP: waits for a signal and returns it
4796  < returns signal number */
signal_wait()4797 local int signal_wait()
4798 {
4799   var int sig = 0; /* initialize it with invalid value */
4800   var sigset_t sig_mask=async_signal_mask();
4801   while (sigwait(&sig_mask, &sig) ||
4802          !sigismember(&sig_mask,sig)) {
4803     /* Strange - no way to have bad mask but it happens sometimes
4804        (observed on 32 bit debian during (disassemble 'car) and
4805        CTRL-Z and "fg" later).
4806        Also on osx was observed success from sigwait() without setting any
4807        value in &sig.
4808        Ignore both cases (sigwait() failure and signal not in the waited set)*/
4809   }
4810   return sig;
4811 }
4812 
4813 /* UP: signals that new CALL-WITH-TIMEOUT has been issued
4814    and it is the first to expire
4815  < returns 0 on success */
signal_timeout_call()4816 global int signal_timeout_call()
4817 {
4818   return xthread_signal(thr_signal_handler,SIG_TIMEOUT_CALL);
4819 }
4820 
4821 /* UP: schedules the next SIGALRM - for the timeout call that is in the
4822    beginning of timeout_call_chain. Called from signal handler thread.
4823  > useconds: duration after which we want SIGARLM */
schedule_alarm(uintL useconds)4824 local useconds_t schedule_alarm(uintL useconds)
4825 {
4826   return ualarm(useconds,0);
4827 }
4828 
4829 /* UP: SIG_THREAD_INTERRUPT handler
4830  > sig: always equals to SIG_THREAD_INTERRUPT */
interrupt_thread_signal_handler(int sig)4831 local void interrupt_thread_signal_handler (int sig) {
4832   signal_acknowledge(SIG_THREAD_INTERRUPT,&interrupt_thread_signal_handler);
4833   /* have to unblock SIG_THREAD_INTERRUPT since
4834      our funcall may exit non-locally with longjmp(). */
4835   var sigset_t mask;
4836   sigemptyset(&mask);
4837   sigaddset(&mask,SIG_THREAD_INTERRUPT);
4838   xthread_sigmask(SIG_UNBLOCK,&mask,NULL);
4839   clisp_thread_t *thr=current_thread();
4840   spinlock_release(&thr->_signal_reenter_ok); /* release the signal reentry */
4841   /* when we are here - we either wait on the thread suspend lock or we are
4842      blocked in re-entrant system call. In latter case - it is safe to
4843      execute what we have on the stack. In the former - do nothing - just
4844      return - we will get executed shortly when the thread is "resumed" */
4845   if (!thr->_raw_wait_mutex) {
4846     GC_SAFE_REGION_END_WITHOUT_INTERRUPTS();
4847     handle_pending_interrupts();
4848     GC_SAFE_REGION_BEGIN(); /* restore GC safe region */
4849   }
4850 }
4851 
install_async_signal_handlers()4852 local void install_async_signal_handlers()
4853 {
4854   /* 1. disable all async signals
4855      2. install SIG_THREAD_INTERRUPT handler */
4856   var sigset_t sigblock_mask=async_signal_mask();
4857   /* since we are called from the main thread - all threads
4858    in the process will inherit this mask !!*/
4859   sigprocmask(SIG_BLOCK,&sigblock_mask,NULL);
4860   /* install SIG_THREAD_INTERRUPT */
4861   SIGNAL(SIG_THREAD_INTERRUPT,&interrupt_thread_signal_handler);
4862 }
4863 
4864 #else /* WIN32_THREADS */
4865 
4866 /* define missing signals IDs  - since we use the same
4867    signal handler code fot both POSIX and WIN32*/
4868 #define SIGALRM          1
4869 #define SIGINT           2
4870 #define SIG_TIMEOUT_CALL 3
4871 #define SIGBREAK         4
4872 
4873 local DWORD wait_timeout=INFINITE;
4874 local HANDLE sigint_semaphore, sigbreak_event;
4875 local HANDLE timeout_call_semaphore;
4876 
4877 /* UP: ConsoleCtrlHandler for Win32 */
console_handler(DWORD CtrlType)4878 local BOOL WINAPI console_handler(DWORD CtrlType)
4879 {
4880   if (CtrlType == CTRL_C_EVENT || CtrlType == CTRL_BREAK_EVENT) {
4881     /* Send an event to the sigint_thread. */
4882     if (CtrlType == CTRL_C_EVENT)
4883       ReleaseSemaphore(sigint_semaphore,2,NULL);
4884     else if (CtrlType == CTRL_BREAK_EVENT)
4885       SetEvent(sigbreak_event);
4886     /* Don't invoke the other handlers */
4887     return TRUE;
4888   } else /* Do invoke the other handlers. */
4889     return FALSE;
4890 }
4891 
4892 /* UP: installs "async" signal handler on Win32 */
install_async_signal_handlers()4893 local void install_async_signal_handlers()
4894 {
4895   wait_timeout=INFINITE;
4896   sigint_semaphore=CreateSemaphore(NULL,0,MAX_SEMAPHORE_COUNT,NULL);
4897   sigbreak_event=CreateEvent(NULL,TRUE,FALSE,NULL);
4898   timeout_call_semaphore=CreateSemaphore(NULL,0,MAX_SEMAPHORE_COUNT,NULL);
4899   SetConsoleCtrlHandler((PHANDLER_ROUTINE)console_handler,true);
4900 }
4901 
4902 /* UP: waits for a signal and returns it
4903  < returns signal number */
signal_wait()4904 local int signal_wait()
4905 {
4906   var HANDLE sems[]={sigint_semaphore, timeout_call_semaphore, sigbreak_event};
4907  retry:
4908   /* TODO: have to update the wait_timeout !!! */
4909   wait_timeout = INFINITE;
4910   switch (WaitForMultipleObjects(3,sems,FALSE,wait_timeout)) {
4911   case WAIT_OBJECT_0:
4912     return SIGINT;
4913   case WAIT_TIMEOUT:
4914   case WAIT_OBJECT_0 + 1:
4915     wait_timeout=INFINITE; /* in any case */
4916     return SIG_TIMEOUT_CALL;
4917   case WAIT_OBJECT_0 + 2:
4918     return SIGBREAK;
4919   default:
4920     /* hmm, not good ?? */
4921     goto retry;
4922   }
4923 }
4924 /* UP: signals that new CALL-WITH-TIMEOUT has been issued
4925    and it is the first to expire
4926  < returns 0 on success. */
signal_timeout_call()4927 global int signal_timeout_call()
4928 {
4929   ReleaseSemaphore(timeout_call_semaphore,1,NULL);
4930   return 0;
4931 }
4932 
4933 /* UP: schedules the next SIGALRM - for the timeout call that is in the
4934    beginning of timeout_call_chain. Called from signal handler thread.
4935  > useconds: duration after which we want SIGARLM
4936  should be called only from signal_handler_thread() */
schedule_alarm(uintL useconds)4937 local useconds_t schedule_alarm(uintL useconds)
4938 {
4939   wait_timeout = useconds / 1000; /* in milliseconds */
4940   return 0;
4941 }
4942 
4943 #endif
4944 
4945 /* UP: handles any pending interrupt (currently just one).
4946    arguments are on the STACK
4947    It is always called in the context of the thread that has to handle the
4948    interrupt and it is safe to do whatever we want here */
handle_pending_interrupts(void)4949 modexp maygc void handle_pending_interrupts(void)
4950 {
4951   var clisp_thread_t *thr = current_thread();
4952   var uintC pend = thr->_pending_interrupts;
4953   thr->_pending_interrupts = 0; /* we got all of them */
4954   /* it's possible interrupt to come before per-thread
4955    *DEFER-INTERRUPTS* is initialized (while evaluating initial bindings) -
4956    check this case as well */
4957   if (eq(Symbol_thread_value(S(defer_interrupts)), NIL) ||
4958       eq(Symbol_thread_value(S(defer_interrupts)), SYMVALUE_EMPTY)) {
4959     while (pend--) {
4960       skipSTACK(1); /* do not care whether we should defer it */
4961       var uintC argc=posfixnum_to_V(popSTACK()); /* arguments count */
4962       var object intrfun=popSTACK(); /* interrupt function */
4963       /* on non-local exit from the interrupt function and nested
4964          pending interrupts - some of them will not be handled.
4965          In most implementations such non-local exits have undefined
4966          behavior and should not be used (actually thread-interrupt is
4967          discouraged). */
4968       funcall(intrfun,argc);
4969     }
4970   } else { /* we should defer interrupts */
4971     while (pend--) {
4972       var bool force = eq(T,popSTACK());
4973       var uintC argc=posfixnum_to_V(popSTACK()); /* arguments count */
4974       if (force) { /* if asked to ignore *defer-interrupts* */
4975         var object intrfun=popSTACK(); /* interrupt function */
4976         funcall(intrfun,argc);
4977       } else {
4978         pushSTACK(nreverse(listof(argc+1)));
4979         var object kons = allocate_cons();
4980         Car(kons) = popSTACK();
4981         Cdr(kons) = Symbol_thread_value(S(deferred_interrupts));
4982         Symbol_thread_value(S(deferred_interrupts)) = kons;
4983       }
4984     }
4985   }
4986 }
4987 
4988 /* UP: interrupts thread "safely"
4989  > thr: the thread
4990  The thread should be suspended (safe for GC).
4991  Caller should hold the thread _signal_reenter_ok. On failure
4992  (or when the thread will not be signalled) it will be released here*/
interrupt_thread(clisp_thread_t * thr)4993 global bool interrupt_thread(clisp_thread_t *thr)
4994 {
4995   var xcondition_t *condition;
4996   var xmutex_t *mutex;
4997   /* first check whether the thread is dying. no need to interrupt it.*/
4998   if (thr->_thread_is_dying) {
4999     spinlock_release(&thr->_signal_reenter_ok);
5000     return false;
5001   }
5002   thr->_pending_interrupts++;
5003   if (condition = thr->_wait_condition) {
5004     /* release the lock - we are not going to send signal really */
5005     spinlock_release(&thr->_signal_reenter_ok);
5006     mutex = thr->_wait_mutex;
5007     if (mutex) { /* if not exited from xcondition_wait() */
5008       /* wait to be sure control is inside pthread_cond_wait or already
5009          have returned from it. Loop below may look strange but it will never
5010          perform more than few iterations (and THREAD-INTERRUPT is not meant
5011          to be efficient). */
5012       var xthread_t xthr = TheThread(thr->_lthread)->xth_system;
5013       while (thr->_wait_mutex && xthread_equal(mutex->xl_owner, xthr)) {
5014         if (!mutex->xl_owned) {
5015           /* thr has released the ownership of the mutex - check that
5016              pthread_cond_wait has done the same */
5017           if (0 == xmutex_raw_trylock(&mutex->xl_mutex)) {
5018             xmutex_raw_unlock(&mutex->xl_mutex);
5019             break;
5020           }
5021         }
5022         xthread_yield();
5023       }
5024       /* if the control is still in xcondition_wait() - signal the condition
5025          (nb: there is race here - we may be just exiting from xcondition_wait -
5026          in this case other waiters on this condition variable will experience
5027          "spurious" wake up. the interrupt itself will be handled shortly in
5028          EXEMPTION-WAIT) */
5029       if (thr->_wait_mutex)
5030         xcondition_broadcast(condition);
5031     }
5032   } else if (mutex = thr->_wait_mutex) {
5033     /* release the lock - we are not going to send signal really */
5034     spinlock_release(&thr->_signal_reenter_ok);
5035     /* waiting on mutex i.e. xlock_t */
5036     /* wake up all threads on this condition */
5037     xmutex_raw_lock(&(mutex->xl_internal_mutex));
5038     xcondition_broadcast(&(mutex->xl_wait_cv));
5039     xmutex_raw_unlock(&(mutex->xl_internal_mutex));
5040   } else {
5041    #ifdef POSIX_THREADS
5042     /* the thread may wait on it's gc_suspend_lock or in system
5043        re-entrant call*/
5044     if (xthread_signal(TheThread(thr->_lthread)->xth_system,
5045                        SIG_THREAD_INTERRUPT)) {
5046       thr->_pending_interrupts--;
5047       spinlock_release(&thr->_signal_reenter_ok);
5048       return false;
5049     }
5050    #else /* WIN32_THREADS */
5051     /* TODO: implement it. for now - very trivial - wait for the end of the
5052        blocked called */
5053     /* in all cases - release the re-enter spinlock */
5054     spinlock_release(&thr->_signal_reenter_ok);
5055    #endif
5056   }
5057   return true;
5058 }
5059 
5060 #ifdef DEBUG_GCSAFETY
5061   #define ENABLE_DUMMY_ALLOCCOUNT(enable) { use_dummy_alloccount=enable; }
5062 #else
5063   #define ENABLE_DUMMY_ALLOCCOUNT(enable)
5064 #endif
5065 
5066 /* UP: The signal handler in MT build.
5067  > arg: not used. */
signal_handler_thread(void * arg)5068 local void *signal_handler_thread(void *arg)
5069 {
5070   while (1) {
5071     var int sig = signal_wait();
5072     /* before proceeding we have to be sure that there is no GC
5073        in progress at the moment. This is the only situation in
5074        which we have to delay the signal. */
5075     lock_heap_from_signal();
5076     switch (sig) {
5077     case SIGALRM:
5078     case SIG_TIMEOUT_CALL:
5079       /* we got and alarm or just a new CALL-WITH-TIMEOUT call has been
5080          inserrted in the front of the chain. */
5081       spinlock_acquire(&timeout_call_chain_lock);
5082       {
5083         timeout_call *chain=timeout_call_chain;
5084         var struct timeval now;
5085         gettimeofday(&now,NULL);
5086         /* let's "timeout" first threads if needed */
5087         /* with DEBUG_GCSAFETY we stop all threads and use the dummy
5088            alloccount. Generally with DEBUG_GCSAFETY we cannot suspend
5089            single thread from signal handler without interfering with
5090            other threads alloccounts */
5091       #ifdef DEBUG_GCSAFETY
5092         gc_suspend_all_threads(false);
5093         ENABLE_DUMMY_ALLOCCOUNT(true);
5094       #endif
5095         for(;chain && timeval_less(chain->expire,&now); chain=chain->next) {
5096         #ifndef DEBUG_GCSAFETY
5097           suspend_thread(chain->thread->_lthread,true);
5098         #endif
5099           spinlock_acquire(&chain->thread->_signal_reenter_ok);
5100           gcv_object_t *saved_stack=chain->thread->_STACK;
5101           NC_pushSTACK(chain->thread->_STACK,*chain->throw_tag);
5102           NC_pushSTACK(chain->thread->_STACK,S(thread_throw_tag));
5103           NC_pushSTACK(chain->thread->_STACK,posfixnum(1));
5104           NC_pushSTACK(chain->thread->_STACK,NIL); /* defer if needed */
5105           if (!interrupt_thread(chain->thread)) {
5106             /* hmm - signal send failed. restore the stack and mark the timeout
5107                as failed. The next time when we come here we will retry it - if
5108                not reported as warning to the user. The user will always get a
5109                warning. */
5110             chain->failed=true;
5111             chain->thread->_STACK=saved_stack;
5112           }
5113         #ifndef DEBUG_GCSAFETY
5114           resume_thread(chain->thread->_lthread,false);
5115         #endif
5116         }
5117       #ifdef DEBUG_GCSAFETY
5118         ENABLE_DUMMY_ALLOCCOUNT(false);
5119         gc_resume_all_threads(false);
5120       #endif
5121         /* should we set new alarm ? */
5122         if (chain) {
5123           var struct timeval diff;
5124           timeval_subtract(&diff, chain->expire, &now);
5125 	  useconds_t wait =
5126 	    diff.tv_sec > 10 ? 10000000 : diff.tv_sec*1000000 + diff.tv_usec;
5127 	  /* Under virtualization (tested on vmware and virtualbox) passing
5128 	     more than a second causes ualarm() to return -1 and signal is
5129 	     never delivered !!!. This is strange since according to POSIX no
5130              errors are defined for ualarm. If this is the case - just ask for
5131 	     something less than a second */
5132 	  if (schedule_alarm(wait) == (useconds_t)-1)
5133             schedule_alarm(999999);
5134         }
5135         /* release the chain spinlock */
5136         spinlock_release(&timeout_call_chain_lock);
5137       }
5138       break;
5139     case SIGINT:
5140       WITH_STOPPED_WORLD(false,{
5141         var bool signal_sent=false;
5142         ENABLE_DUMMY_ALLOCCOUNT(true);
5143         for_all_threads({
5144           spinlock_acquire(&thread->_signal_reenter_ok);
5145           gcv_object_t *saved_stack=thread->_STACK;
5146           /* line below is not needed but detects bugs */
5147           NC_pushSTACK(thread->_STACK,O(thread_break_description));
5148           NC_pushSTACK(thread->_STACK,S(interrupt_condition)); /* arg */
5149           NC_pushSTACK(thread->_STACK,S(cerror)); /* function */
5150           NC_pushSTACK(thread->_STACK,posfixnum(2)); /* two arguments */
5151           NC_pushSTACK(thread->_STACK,T); /* do not defer the interrupt */
5152           if (!(signal_sent = interrupt_thread(thread))) {
5153             thread->_STACK=saved_stack;
5154           } else
5155             break;
5156         });
5157         if (!signal_sent) {
5158           fprint(stderr,"*** SIGINT will be missed.\n"); abort();
5159         }
5160         ENABLE_DUMMY_ALLOCCOUNT(false);
5161       });
5162       break;
5163    #if defined(SIGWINCH)
5164     case SIGWINCH:
5165       sigwinch_handler(SIGWINCH);
5166       break;
5167    #endif
5168    #ifdef SIGTTOU
5169     case SIGTTOU:
5170       break; /* just ignore it */
5171    #endif
5172 #ifdef UNIX_MACOSX
5173     case SIGHUP:
5174     case SIGCONT:
5175       /* TODO: ignore these two - fix later.
5176          we get them after fork-ed process exits. */
5177       break;
5178 #endif
5179     default:
5180       /* just terminate all threads - the last one will
5181          kill the process from delete_thread */
5182       fprintf(stderr, "Exiting on signal %d\n", sig);
5183       WITH_STOPPED_WORLD(false,{
5184         var bool all_succeeded = true;
5185         ENABLE_DUMMY_ALLOCCOUNT(true);
5186         quit_on_signal_in_progress = true;
5187         final_exitcode = -sig; /* set process exit code */
5188         for_all_threads({
5189           /* be sure the signal handler can be reentered */
5190           spinlock_acquire(&thread->_signal_reenter_ok);
5191           NC_pushSTACK(thread->_STACK,O(thread_exit_tag)); /* thread exit tag */
5192           NC_pushSTACK(thread->_STACK,S(thread_throw_tag)); /* %THROW-TAG */
5193           NC_pushSTACK(thread->_STACK,posfixnum(1)); /* 1 argument */
5194           NC_pushSTACK(thread->_STACK,T); /* do not defer the interrupt */
5195           all_succeeded &= interrupt_thread(thread);
5196         });
5197         fini_lowest_level();
5198         if (!all_succeeded) {
5199           fprint(stderr,"*** some threads were not signaled to terminate.");
5200           exit(-sig); /* nothing we can do - exit immediately (cannot call quit
5201                          from here) */
5202         }
5203         ENABLE_DUMMY_ALLOCCOUNT(false);
5204       });
5205       break;
5206     }
5207     spinlock_release(&mem.alloc_lock);
5208   }
5209   return NULL;
5210 }
5211 
5212 #undef ENABLE_DUMMY_ALLOCCOUNT
5213 
5214 #endif /* MULTITHREAD */
5215