libguile/init.c

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