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