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