libguile/init.c

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