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