libguile/init.c

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