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