libguile/init.c

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