libguile/init.c

   1 /* Copyright (C) 1995-2004, 2006, 2009-2014 Free Software Foundation, Inc.
   2  *
   3  * This library is free software; you can redistribute it and/or
   4  * modify it under the terms of the GNU Lesser General Public License
   5  * as published by the Free Software Foundation; either version 3 of
   6  * the License, or (at your option) any later version.
   7  *
   8  * This library is distributed in the hope that it will be useful, but
   9  * WITHOUT ANY WARRANTY; without even the implied warranty of
  10  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  11  * Lesser General Public License for more details.
  12  *
  13  * You should have received a copy of the GNU Lesser General Public
  14  * License along with this library; if not, write to the Free Software
  15  * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
  16  * 02110-1301 USA
  17  */
  18
  19
  20 \f
  21 /* Include the headers for just about everything.
  22    We call all their initialization functions.  */
  23
  24 #ifdef HAVE_CONFIG_H
  25 #  include <config.h>
  26 #endif
  27
  28 #include <stdlib.h>
  29 #include <stdio.h>
  30 #include <sys/stat.h>
  31 #include <fcntl.h>
  32 #include <gmp.h>
  33
  34 #include "libguile/_scm.h"
  35
  36 /* Everybody has an init function.  */
  37 #include "libguile/alist.h"
  38 #include "libguile/arbiters.h"
  39 #include "libguile/async.h"
  40 #include "libguile/backtrace.h"
  41 #include "libguile/bitvectors.h"
  42 #include "libguile/boolean.h"
  43 #include "libguile/bytevectors.h"
  44 #include "libguile/chars.h"
  45 #include "libguile/control.h"
  46 #include "libguile/continuations.h"
  47 #include "libguile/debug.h"
  48 #ifdef GUILE_DEBUG_MALLOC
  49 #include "libguile/debug-malloc.h"
  50 #endif
  51 #include "libguile/deprecation.h"
  52 #include "libguile/dynl.h"
  53 #include "libguile/dynwind.h"
  54 #include "libguile/eq.h"
  55 #include "libguile/error.h"
  56 #include "libguile/eval.h"
  57 #include "libguile/evalext.h"
  58 #include "libguile/expand.h"
  59 #include "libguile/feature.h"
  60 #include "libguile/filesys.h"
  61 #include "libguile/finalizers.h"
  62 #include "libguile/fluids.h"
  63 #include "libguile/fports.h"
  64 #include "libguile/frames.h"
  65 #include "libguile/gc.h"
  66 #include "libguile/generalized-arrays.h"
  67 #include "libguile/generalized-vectors.h"
  68 #include "libguile/goops.h"
  69 #include "libguile/gsubr.h"
  70 #include "libguile/hash.h"
  71 #include "libguile/hashtab.h"
  72 #include "libguile/hooks.h"
  73 #include "libguile/gettext.h"
  74 #include "libguile/i18n.h"
  75 #include "libguile/instructions.h"
  76 #include "libguile/ioext.h"
  77 #include "libguile/keywords.h"
  78 #include "libguile/list.h"
  79 #include "libguile/load.h"
  80 #include "libguile/macros.h"
  81 #include "libguile/mallocs.h"
  82 #include "libguile/memoize.h"
  83 #include "libguile/modules.h"
  84 #include "libguile/net_db.h"
  85 #include "libguile/numbers.h"
  86 #include "libguile/loader.h"
  87 #include "libguile/objprop.h"
  88 #include "libguile/options.h"
  89 #include "libguile/pairs.h"
  90 #include "libguile/poll.h"
  91 #include "libguile/ports.h"
  92 #include "libguile/posix.h"
  93 #ifdef ENABLE_REGEX
  94 #include "libguile/regex-posix.h"
  95 #endif
  96 #include "libguile/print.h"
  97 #include "libguile/procprop.h"
  98 #include "libguile/procs.h"
  99 #include "libguile/programs.h"
 100 #include "libguile/promises.h"
 101 #include "libguile/array-map.h"
 102 #include "libguile/random.h"
 103 #include "libguile/rdelim.h"
 104 #include "libguile/read.h"
 105 #include "libguile/rw.h"
 106 #include "libguile/scmsigs.h"
 107 #include "libguile/script.h"
 108 #include "libguile/simpos.h"
 109 #include "libguile/smob.h"
 110 #include "libguile/socket.h"
 111 #include "libguile/sort.h"
 112 #include "libguile/srcprop.h"
 113 #include "libguile/stackchk.h"
 114 #include "libguile/stacks.h"
 115 #include "libguile/stime.h"
 116 #include "libguile/strings.h"
 117 #include "libguile/srfi-1.h"
 118 #include "libguile/srfi-4.h"
 119 #include "libguile/srfi-13.h"
 120 #include "libguile/srfi-14.h"
 121 #include "libguile/srfi-60.h"
 122 #include "libguile/strorder.h"
 123 #include "libguile/strports.h"
 124 #include "libguile/struct.h"
 125 #include "libguile/symbols.h"
 126 #include "libguile/throw.h"
 127 #include "libguile/arrays.h"
 128 #include "libguile/trees.h"
 129 #include "libguile/unicode.h"
 130 #include "libguile/values.h"
 131 #include "libguile/variable.h"
 132 #include "libguile/vectors.h"
 133 #include "libguile/version.h"
 134 #include "libguile/vm.h"
 135 #include "libguile/vports.h"
 136 #include "libguile/guardians.h"
 137 #include "libguile/extensions.h"
 138 #include "libguile/uniform.h"
 139 #include "libguile/deprecated.h"
 140
 141 #include "libguile/init.h"
 142 #include "libguile/private-options.h"
 143
 144 #ifdef HAVE_STRING_H
 145 #include <string.h>
 146 #endif
 147 #include <unistd.h>
 148
 149
 150 \f
 151 /* initializing standard and current I/O ports */
 152
 153 typedef struct
 154 {
 155   int fdes;
 156   char *mode;
 157 } stream_body_data;
 158
 159 /* proc to be called in scope of exception handler stream_handler. */
 160 static SCM
 161 stream_body (void *data)
 162 {
 163   stream_body_data *body_data = (stream_body_data *) data;
 164   SCM port = scm_fdes_to_port (body_data->fdes, body_data->mode, SCM_BOOL_F);
 165   scm_set_port_revealed_x (port, SCM_INUM1);
 166   return port;
 167 }
 168
 169 /* exception handler for stream_body.  */
 170 static SCM
 171 stream_handler (void *data SCM_UNUSED,
 172                 SCM tag SCM_UNUSED,
 173                 SCM throw_args SCM_UNUSED)
 174 {
 175   return SCM_BOOL_F;
 176 }
 177
 178 /* Convert a file descriptor to a port, using scm_fdes_to_port.
 179    - set the revealed count for FILE's file descriptor to 1, so
 180    that fdes won't be closed when the port object is GC'd.
 181    - catch exceptions: allow Guile to be able to start up even
 182    if it has been handed bogus stdin/stdout/stderr.  replace the
 183    bad ports with void ports.  */
 184 static SCM
 185 scm_standard_stream_to_port (int fdes, char *mode)
 186 {
 187   SCM port;
 188   stream_body_data body_data;
 189
 190   body_data.fdes = fdes;
 191   body_data.mode = mode;
 192   port = scm_internal_catch (SCM_BOOL_T, stream_body, &body_data,
 193                              stream_handler, NULL);
 194   if (scm_is_false (port))
 195     port = scm_void_port (mode);
 196   return port;
 197 }
 198
 199 /* Create standard ports from stdin, stdout, and stderr.  */
 200 static void
 201 scm_init_standard_ports ()
 202 {
 203   /* From the SCSH manual:
 204
 205      It can be useful to turn I/O buffering off in some cases, for
 206      example when an I/O stream is to be shared by multiple
 207      subprocesses.  For this reason, scsh allocates an unbuffered port
 208      for file descriptor 0 at start-up time.
 209
 210      Because shells frequently share stdin with subprocesses, if the
 211      shell does buffered reads, it might ``steal'' input intended for
 212      a subprocess.  For this reason, all shells, including sh, csh,
 213      and scsh, read stdin unbuffered.  Applications that can tolerate
 214      buffered input on stdin can reset \ex{(current-input-port)} to
 215      block buffering for higher performance.  */
 216
 217   scm_set_current_input_port
 218     (scm_standard_stream_to_port (0, isatty (0) ? "r0" : "r"));
 219   scm_set_current_output_port
 220     (scm_standard_stream_to_port (1, isatty (1) ? "w0" : "w"));
 221   scm_set_current_error_port
 222     (scm_standard_stream_to_port (2, isatty (2) ? "w0" : "w"));
 223   scm_set_current_warning_port (scm_current_error_port ());
 224 }
 225
 226
 227 \f
 228 /* Loading the startup Scheme files.  */
 229
 230 /* The boot code "ice-9/boot-9" is only loaded by scm_boot_guile when
 231    this is false.  The unexec code uses this, to keep ice_9 from being
 232    loaded into dumped guile executables.  */
 233 int scm_ice_9_already_loaded = 0;
 234
 235 void
 236 scm_load_startup_files ()
 237 {
 238   /* We want a path only containing directories from GUILE_LOAD_PATH,
 239      SCM_SITE_DIR and SCM_LIBRARY_DIR when searching for the site init
 240      file, so we do this before loading Ice-9.  */
 241   SCM init_path =
 242     scm_sys_search_load_path (scm_from_locale_string ("init.scm"));
 243
 244   /* Load Ice-9.  */
 245   if (!scm_ice_9_already_loaded)
 246     {
 247       scm_c_primitive_load_path ("ice-9/boot-9");
 248
 249       /* Load the init.scm file.  */
 250       if (scm_is_true (init_path))
 251         scm_primitive_load (init_path);
 252     }
 253 }
 254
 255 \f
 256 /* The main init code.  */
 257
 258 #ifdef _UNICOS
 259 typedef int setjmp_type;
 260 #else
 261 typedef long setjmp_type;
 262 #endif
 263
 264 /* All the data needed to invoke the main function.  */
 265 struct main_func_closure
 266 {
 267   /* the function to call */
 268   void (*main_func)(void *closure, int argc, char **argv);
 269   void *closure;                /* dummy data to pass it */
 270   int argc;
 271   char **argv;                  /* the argument list it should receive */
 272 };
 273
 274 static void *invoke_main_func(void *body_data);
 275
 276
 277 /* Fire up the Guile Scheme interpreter.
 278
 279    Call MAIN_FUNC, passing it CLOSURE, ARGC, and ARGV.  MAIN_FUNC
 280    should do all the work of the program (initializing other packages,
 281    reading user input, etc.) before returning.  When MAIN_FUNC
 282    returns, call exit (EXIT_FAILURE); this function never returns.
 283    If you want some other exit value, MAIN_FUNC may call exit itself.
 284
 285    scm_boot_guile arranges for program-arguments to return the strings
 286    given by ARGC and ARGV.  If MAIN_FUNC modifies ARGC/ARGV, should
 287    call scm_set_program_arguments with the final list, so Scheme code
 288    will know which arguments have been processed.
 289
 290    scm_boot_guile establishes a catch-all catch handler which prints
 291    an error message and exits the process.  This means that Guile
 292    exits in a coherent way when system errors occur and the user isn't
 293    prepared to handle it.  If the user doesn't like this behavior,
 294    they can establish their own universal catcher to shadow this one.
 295
 296    Why must the caller do all the real work from MAIN_FUNC?  The
 297    garbage collector assumes that all local variables of type SCM will
 298    be above scm_boot_guile's stack frame on the stack.  If you try to
 299    manipulate SCM values after this function returns, it's the luck of
 300    the draw whether the GC will be able to find the objects you
 301    allocate.  So, scm_boot_guile function exits, rather than
 302    returning, to discourage people from making that mistake.  */
 303
 304
 305 void
 306 scm_boot_guile (int argc, char ** argv, void (*main_func) (), void *closure)
 307 {
 308   void *res;
 309   struct main_func_closure c;
 310
 311   /* On Windows, convert backslashes in argv[0] to forward
 312      slashes.  */
 313   if (argc > 0)
 314     scm_i_mirror_backslashes (argv[0]);
 315
 316   c.main_func = main_func;
 317   c.closure = closure;
 318   c.argc = argc;
 319   c.argv = argv;
 320
 321   res = scm_with_guile (invoke_main_func, &c);
 322
 323   /* If the caller doesn't want this, they should exit from main_func
 324      themselves.
 325   */
 326   if (res == NULL)
 327     exit (EXIT_FAILURE);
 328   else
 329     exit (EXIT_SUCCESS);
 330 }
 331
 332 static void *
 333 invoke_main_func (void *body_data)
 334 {
 335   struct main_func_closure *closure = (struct main_func_closure *) body_data;
 336
 337   scm_i_set_boot_program_arguments (closure->argc, closure->argv);
 338   (*closure->main_func) (closure->closure, closure->argc, closure->argv);
 339
 340   scm_restore_signals ();
 341
 342   /* This tick gives any pending
 343    * asyncs a chance to run.  This must be done after
 344    * the call to scm_restore_signals.
 345    */
 346   SCM_ASYNC_TICK;
 347
 348   /* Indicate success by returning non-NULL.
 349    */
 350   return (void *)1;
 351 }
 352
 353 scm_i_pthread_mutex_t scm_i_init_mutex = SCM_I_PTHREAD_MUTEX_INITIALIZER;
 354 int scm_initialized_p = 0;
 355
 356 static void *
 357 really_cleanup_for_exit (void *unused)
 358 {
 359   scm_flush_all_ports ();
 360   return NULL;
 361 }
 362
 363 static void
 364 cleanup_for_exit ()
 365 {
 366   if (scm_i_pthread_mutex_trylock (&scm_i_init_mutex) == 0)
 367     scm_i_pthread_mutex_unlock (&scm_i_init_mutex);
 368   else
 369     {
 370       fprintf (stderr, "Cannot exit gracefully when init is in progress; aborting.\n");
 371       abort ();
 372     }
 373
 374   /* This function might be called in non-guile mode, so we need to
 375      enter it temporarily.
 376   */
 377   scm_with_guile (really_cleanup_for_exit, NULL);
 378 }
 379
 380 void
 381 scm_i_init_guile (void *base)
 382 {
 383   if (scm_initialized_p)
 384     return;
 385
 386   scm_storage_prehistory ();
 387   scm_threads_prehistory (base);  /* requires storage_prehistory */
 388   scm_weak_table_prehistory ();        /* requires storage_prehistory */
 389 #ifdef GUILE_DEBUG_MALLOC
 390   scm_debug_malloc_prehistory ();
 391 #endif
 392   scm_symbols_prehistory ();      /* requires weak_table_prehistory */
 393   scm_modules_prehistory ();
 394   scm_init_array_handle ();
 395   scm_bootstrap_bytevectors ();   /* Requires array-handle */
 396   scm_bootstrap_instructions ();
 397   scm_bootstrap_loader ();
 398   scm_bootstrap_programs ();
 399   scm_bootstrap_vm ();
 400   scm_register_r6rs_ports ();
 401   scm_register_foreign ();
 402   scm_register_foreign_object ();
 403   scm_register_srfi_1 ();
 404   scm_register_srfi_60 ();
 405   scm_register_poll ();
 406
 407   scm_init_strings ();            /* Requires array-handle */
 408   scm_init_struct ();             /* Requires strings */
 409   scm_smob_prehistory ();
 410   scm_init_variable ();
 411   scm_init_continuations ();      /* requires smob_prehistory */
 412   scm_init_root ();               /* requires continuations */
 413   scm_init_threads ();            /* requires smob_prehistory */
 414   scm_init_gsubr ();
 415   scm_init_thread_procs ();       /* requires gsubrs */
 416   scm_init_procprop ();
 417   scm_init_alist ();
 418   scm_init_arbiters ();           /* requires smob_prehistory */
 419   scm_init_async ();              /* requires smob_prehistory */
 420   scm_init_boolean ();
 421   scm_init_chars ();
 422 #ifdef GUILE_DEBUG_MALLOC
 423   scm_init_debug_malloc ();
 424 #endif
 425   scm_init_dynwind ();            /* requires smob_prehistory */
 426   scm_init_eq ();
 427   scm_init_error ();
 428   scm_init_finalizers ();
 429   scm_init_fluids ();
 430   scm_init_control ();            /* requires fluids */
 431   scm_init_feature ();
 432   scm_init_backtrace ();
 433   scm_init_fports ();
 434   scm_init_strports ();
 435   scm_init_ports ();
 436   scm_init_hash ();
 437   scm_init_hashtab ();
 438   scm_init_deprecation ();
 439   scm_init_objprop ();
 440   scm_init_promises ();         /* requires smob_prehistory */
 441   scm_init_hooks ();            /* Requires smob_prehistory */
 442   scm_init_stime ();
 443   scm_init_gc ();               /* Requires hooks and `get_internal_run_time' */
 444   scm_init_gc_protect_object ();  /* requires threads_prehistory */
 445   scm_init_gettext ();
 446   scm_init_ioext ();
 447   scm_init_keywords ();    /* Requires smob_prehistory */
 448   scm_init_fports_keywords ();
 449   scm_init_list ();
 450   scm_init_random ();      /* Requires smob_prehistory */
 451   scm_init_macros ();      /* Requires smob_prehistory and random */
 452   scm_init_mallocs ();     /* Requires smob_prehistory */
 453   scm_init_modules ();     /* Requires smob_prehistory */
 454   scm_init_numbers ();
 455   scm_init_options ();
 456   scm_init_pairs ();
 457   scm_init_filesys ();     /* Requires smob_prehistory */
 458 #ifdef HAVE_POSIX
 459   scm_init_posix ();
 460 #endif
 461 #ifdef ENABLE_REGEX
 462   scm_init_regex_posix (); /* Requires smob_prehistory */
 463 #endif
 464   scm_init_procs ();
 465   scm_init_scmsigs ();
 466 #ifdef HAVE_NETWORKING
 467   scm_init_net_db ();
 468   scm_init_socket ();
 469 #endif
 470   scm_init_sort ();
 471   scm_init_srcprop ();     /* requires smob_prehistory */
 472   scm_init_stackchk ();
 473
 474   scm_init_generalized_arrays ();
 475   scm_init_generalized_vectors ();
 476   scm_init_vectors ();  /* Requires array-handle, */
 477   scm_init_uniform ();
 478   scm_init_bitvectors ();  /* Requires smob_prehistory, array-handle */
 479   scm_init_srfi_4 ();  /* Requires smob_prehistory, array-handle */
 480   scm_init_arrays ();    /* Requires smob_prehistory, array-handle */
 481   scm_init_array_map ();
 482
 483   scm_init_frames ();   /* Requires smob_prehistory */
 484   scm_init_stacks ();   /* Requires strings, struct, frames */
 485   scm_init_symbols ();
 486   scm_init_values ();   /* Requires struct */
 487   scm_init_load ();     /* Requires strings */
 488   scm_init_print ();    /* Requires strings, struct, smob */
 489   scm_init_read ();
 490   scm_init_strorder ();
 491   scm_init_srfi_13 ();
 492   scm_init_srfi_14 ();  /* Requires smob_prehistory */
 493   scm_init_throw ();    /* Requires smob_prehistory */
 494   scm_init_trees ();
 495   scm_init_version ();
 496   scm_init_weak_set ();
 497   scm_init_weak_table ();
 498   scm_init_weak_vectors ();
 499   scm_init_guardians (); /* requires smob_prehistory */
 500   scm_init_vports ();
 501   scm_init_standard_ports ();  /* Requires fports */
 502   scm_init_expand ();   /* Requires structs */
 503   scm_init_memoize ();  /* Requires smob_prehistory */
 504   scm_init_eval ();     /* Requires smob_prehistory */
 505   scm_init_load_path ();
 506   scm_init_eval_in_scheme ();
 507   scm_init_evalext ();
 508   scm_init_debug ();    /* Requires macro smobs */
 509   scm_init_simpos ();
 510 #if HAVE_MODULES
 511   scm_init_dynamic_linking (); /* Requires smob_prehistory */
 512 #endif
 513   scm_bootstrap_i18n ();
 514   scm_init_script ();
 515   scm_init_unicode ();
 516
 517   scm_init_goops ();
 518
 519 #if SCM_ENABLE_DEPRECATED == 1
 520   scm_i_init_deprecated ();
 521 #endif
 522
 523   scm_initialized_p = 1;
 524
 525   scm_stack_checking_enabled_p = SCM_STACK_CHECKING_P;
 526
 527   scm_init_rdelim ();
 528   scm_init_rw ();
 529   scm_init_extensions ();
 530
 531   atexit (cleanup_for_exit);
 532   scm_load_startup_files ();
 533   scm_init_load_should_auto_compile ();
 534
 535   /* Capture the dynamic state after loading boot-9, so that new threads end up
 536      in the guile-user module. */
 537   scm_init_threads_default_dynamic_state ();
 538
 539   /* Finally, cause finalizers to run in a separate thread.  */
 540   scm_init_finalizer_thread ();
 541 }
 542
 543 /*
 544   Local Variables:
 545   c-file-style: "gnu"
 546   End:
 547 */