libguile/init.c

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