libguile/init.c

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