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