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