libguile/init.c

   1 /* Copyright (C) 1995,1996,1997,1998,1999, 2000 Free Software Foundation, Inc.
   2  *
   3  * This program is free software; you can redistribute it and/or modify
   4  * it under the terms of the GNU General Public License as published by
   5  * the Free Software Foundation; either version 2, or (at your option)
   6  * any later version.
   7  *
   8  * This program 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
  11  * GNU General Public License for more details.
  12  *
  13  * You should have received a copy of the GNU General Public License
  14  * along with this software; see the file COPYING.  If not, write to
  15  * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
  16  * Boston, MA 02111-1307 USA
  17  *
  18  * As a special exception, the Free Software Foundation gives permission
  19  * for additional uses of the text contained in its release of GUILE.
  20  *
  21  * The exception is that, if you link the GUILE library with other files
  22  * to produce an executable, this does not by itself cause the
  23  * resulting executable to be covered by the GNU General Public License.
  24  * Your use of that executable is in no way restricted on account of
  25  * linking the GUILE library code into it.
  26  *
  27  * This exception does not however invalidate any other reasons why
  28  * the executable file might be covered by the GNU General Public License.
  29  *
  30  * This exception applies only to the code released by the
  31  * Free Software Foundation under the name GUILE.  If you copy
  32  * code from other Free Software Foundation releases into a copy of
  33  * GUILE, as the General Public License permits, the exception does
  34  * not apply to the code that you add in this way.  To avoid misleading
  35  * anyone as to the status of such modified files, you must delete
  36  * this exception notice from them.
  37  *
  38  * If you write modifications of your own for GUILE, it is your choice
  39  * whether to permit this exception to apply to your modifications.
  40  * If you do not wish that, delete this exception notice.  */
  41
  42 /* Software engineering face-lift by Greg J. Badros, 11-Dec-1999,
  43    gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */
  44
  45 \f
  46 /* Include the headers for just about everything.
  47    We call all their initialization functions.  */
  48
  49 #include <stdio.h>
  50 #include <sys/stat.h>
  51 #include <fcntl.h>
  52
  53 #include "libguile/_scm.h"
  54
  55 /* Everybody has an init function.  */
  56 #include "libguile/alist.h"
  57 #include "libguile/arbiters.h"
  58 #include "libguile/async.h"
  59 #include "libguile/backtrace.h"
  60 #include "libguile/boolean.h"
  61 #include "libguile/chars.h"
  62 #include "libguile/continuations.h"
  63 #ifdef DEBUG_EXTENSIONS
  64 #include "libguile/debug.h"
  65 #endif
  66 #ifdef GUILE_DEBUG_MALLOC
  67 #include "libguile/debug-malloc.h"
  68 #endif
  69 #include "libguile/dynl.h"
  70 #include "libguile/dynwind.h"
  71 #include "libguile/environments.h"
  72 #include "libguile/eq.h"
  73 #include "libguile/error.h"
  74 #include "libguile/eval.h"
  75 #include "libguile/evalext.h"
  76 #include "libguile/feature.h"
  77 #include "libguile/filesys.h"
  78 #include "libguile/fluids.h"
  79 #include "libguile/fports.h"
  80 #include "libguile/gc.h"
  81 #include "libguile/gdbint.h"
  82 #include "libguile/goops.h"
  83 #include "libguile/gsubr.h"
  84 #include "libguile/hash.h"
  85 #include "libguile/hashtab.h"
  86 #include "libguile/hooks.h"
  87 #ifdef GUILE_ISELECT
  88 #include "libguile/iselect.h"
  89 #endif
  90 #include "libguile/ioext.h"
  91 #include "libguile/keywords.h"
  92 #include "libguile/lang.h"
  93 #include "libguile/list.h"
  94 #include "libguile/load.h"
  95 #include "libguile/macros.h"
  96 #include "libguile/mallocs.h"
  97 #include "libguile/modules.h"
  98 #include "libguile/net_db.h"
  99 #include "libguile/numbers.h"
 100 #include "libguile/objects.h"
 101 #include "libguile/objprop.h"
 102 #include "libguile/options.h"
 103 #include "libguile/pairs.h"
 104 #include "libguile/ports.h"
 105 #include "libguile/posix.h"
 106 #ifdef HAVE_REGCOMP
 107 #include "libguile/regex-posix.h"
 108 #endif
 109 #include "libguile/print.h"
 110 #include "libguile/procprop.h"
 111 #include "libguile/procs.h"
 112 #include "libguile/properties.h"
 113 #include "libguile/ramap.h"
 114 #include "libguile/random.h"
 115 #include "libguile/read.h"
 116 #include "libguile/scmsigs.h"
 117 #include "libguile/script.h"
 118 #include "libguile/simpos.h"
 119 #include "libguile/smob.h"
 120 #include "libguile/socket.h"
 121 #include "libguile/sort.h"
 122 #include "libguile/srcprop.h"
 123 #include "libguile/stackchk.h"
 124 #include "libguile/stacks.h"
 125 #include "libguile/stime.h"
 126 #include "libguile/strings.h"
 127 #include "libguile/strop.h"
 128 #include "libguile/strorder.h"
 129 #include "libguile/strports.h"
 130 #include "libguile/struct.h"
 131 #include "libguile/symbols.h"
 132 #include "libguile/tag.h"
 133 #include "libguile/throw.h"
 134 #include "libguile/unif.h"
 135 #include "libguile/variable.h"
 136 #include "libguile/vectors.h"
 137 #include "libguile/version.h"
 138 #include "libguile/vports.h"
 139 #include "libguile/weaks.h"
 140 #include "libguile/guardians.h"
 141
 142 #include "libguile/init.h"
 143
 144 #ifdef HAVE_STRING_H
 145 #include <string.h>
 146 #endif
 147 #ifdef HAVE_UNISTD_H
 148 #include <unistd.h>
 149 #endif
 150 \f
 151 /* Setting up the stack.  */
 152
 153 static void
 154 restart_stack (void *base)
 155 {
 156   scm_dynwinds = SCM_EOL;
 157   SCM_DYNENV (scm_rootcont) = SCM_EOL;
 158   SCM_THROW_VALUE (scm_rootcont) = SCM_EOL;
 159 #ifdef DEBUG_EXTENSIONS
 160   SCM_DFRAME (scm_rootcont) = scm_last_debug_frame = 0;
 161 #endif
 162   SCM_BASE (scm_rootcont) = base;
 163   scm_continuation_stack_ptr = SCM_MAKINUM (0);
 164 }
 165
 166 static void
 167 start_stack (void *base)
 168 {
 169   SCM root;
 170
 171   root = scm_permanent_object (scm_make_root (SCM_UNDEFINED));
 172   scm_set_root (SCM_ROOT_STATE (root));
 173   scm_stack_base = base;
 174
 175   scm_exitval = SCM_BOOL_F;     /* vestigial */
 176
 177 #if SCM_DEBUG_DEPRECATED == 0
 178   scm_top_level_lookup_closure_var = SCM_BOOL_F;
 179 #endif
 180   scm_system_transformer = SCM_BOOL_F;
 181
 182   scm_root->fluids = scm_make_initial_fluids ();
 183
 184   /* Create an object to hold the root continuation.
 185    */
 186   {
 187     scm_contregs *contregs = scm_must_malloc (sizeof (scm_contregs),
 188                                               "continuation");
 189     contregs->num_stack_items = 0;
 190     contregs->seq = 0;
 191     SCM_NEWSMOB (scm_rootcont, scm_tc16_continuation, contregs);
 192   }
 193   /* The root continuation is further initialized by restart_stack. */
 194
 195   /* Create the look-aside stack for variables that are shared between
 196    * captured continuations.
 197    */
 198   scm_continuation_stack = scm_make_vector (SCM_MAKINUM (512), SCM_UNDEFINED);
 199   /* The continuation stack is further initialized by restart_stack. */
 200
 201   /* The remainder of stack initialization is factored out to another
 202    * function so that if this stack is ever exitted, it can be
 203    * re-entered using restart_stack.  */
 204   restart_stack (base);
 205 }
 206
 207
 208 #if 0
 209 static char remsg[] = "remove\n#define ", addmsg[] = "add\n#define ";
 210
 211
 212 static void
 213 fixconfig (char *s1,char *s2,int s)
 214 {
 215   fputs (s1, stderr);
 216   fputs (s2, stderr);
 217   fputs ("\nin ", stderr);
 218   fputs (s ? "setjump" : "scmfig", stderr);
 219   fputs (".h and recompile scm\n", stderr);
 220   exit (1);
 221 }
 222
 223
 224 static void
 225 check_config (void)
 226 {
 227   scm_sizet j;
 228
 229   j = HEAP_SEG_SIZE;
 230   if (HEAP_SEG_SIZE != j)
 231     fixconfig ("reduce", "size of HEAP_SEG_SIZE", 0);
 232
 233 #ifdef SCM_BIGDIG
 234   if (2 * SCM_BITSPERDIG / SCM_CHAR_BIT > sizeof (long))
 235       fixconfig (remsg, "SCM_BIGDIG", 0);
 236 #ifndef SCM_DIGSTOOBIG
 237   if (SCM_DIGSPERLONG * sizeof (SCM_BIGDIG) > sizeof (long))
 238       fixconfig (addmsg, "SCM_DIGSTOOBIG", 0);
 239 #endif
 240 #endif
 241
 242 #ifdef SCM_STACK_GROWS_UP
 243   if (((SCM_STACKITEM *) & j - stack_start_ptr) < 0)
 244     fixconfig (remsg, "SCM_STACK_GROWS_UP", 1);
 245 #else
 246   if ((stack_start_ptr - (SCM_STACKITEM *) & j) < 0)
 247     fixconfig (addmsg, "SCM_STACK_GROWS_UP", 1);
 248 #endif
 249 }
 250 #endif
 251
 252
 253 \f
 254 /* initializing standard and current I/O ports */
 255
 256 typedef struct
 257 {
 258   int fdes;
 259   char *mode;
 260   char *name;
 261 } stream_body_data;
 262
 263 /* proc to be called in scope of exception handler stream_handler. */
 264 static SCM
 265 stream_body (void *data)
 266 {
 267   stream_body_data *body_data = (stream_body_data *) data;
 268   SCM port = scm_fdes_to_port (body_data->fdes, body_data->mode,
 269                                scm_makfrom0str (body_data->name));
 270
 271   SCM_REVEALED (port) = 1;
 272   return port;
 273 }
 274
 275 /* exception handler for stream_body.  */
 276 static SCM
 277 stream_handler (void *data, SCM tag, SCM throw_args)
 278 {
 279   return SCM_BOOL_F;
 280 }
 281
 282 /* Convert a file descriptor to a port, using scm_fdes_to_port.
 283    - NAME is a C string, not a Guile string
 284    - set the revealed count for FILE's file descriptor to 1, so
 285    that fdes won't be closed when the port object is GC'd.
 286    - catch exceptions: allow Guile to be able to start up even
 287    if it has been handed bogus stdin/stdout/stderr.  replace the
 288    bad ports with void ports.  */
 289 static SCM
 290 scm_standard_stream_to_port (int fdes, char *mode, char *name)
 291 {
 292   SCM port;
 293   stream_body_data body_data;
 294
 295   body_data.fdes = fdes;
 296   body_data.mode = mode;
 297   body_data.name = name;
 298   port = scm_internal_catch (SCM_BOOL_T, stream_body, &body_data,
 299                              stream_handler, NULL);
 300   if (SCM_FALSEP (port))
 301     port = scm_void_port (mode);
 302   return port;
 303 }
 304
 305 /* Create standard ports from stdin, stdout, and stderr.  */
 306 static void
 307 scm_init_standard_ports ()
 308 {
 309   /* From the SCSH manual:
 310
 311      It can be useful to turn I/O buffering off in some cases, for
 312      example when an I/O stream is to be shared by multiple
 313      subprocesses.  For this reason, scsh allocates an unbuffered port
 314      for file descriptor 0 at start-up time.
 315
 316      Because shells frequently share stdin with subprocesses, if the
 317      shell does buffered reads, it might ``steal'' input intended for
 318      a subprocess.  For this reason, all shells, including sh, csh,
 319      and scsh, read stdin unbuffered.  Applications that can tolerate
 320      buffered input on stdin can reset \ex{(current-input-port)} to
 321      block buffering for higher performance.  */
 322
 323   scm_def_inp
 324     = scm_standard_stream_to_port (0,
 325                                    isatty (0) ? "r0" : "r",
 326                                    "standard input");
 327   scm_def_outp = scm_standard_stream_to_port (1,
 328                                               isatty (1) ? "w0" : "w",
 329                                               "standard output");
 330   scm_def_errp = scm_standard_stream_to_port (2,
 331                                               isatty (2) ? "w0" : "w",
 332                                               "standard error");
 333
 334   scm_cur_inp = scm_def_inp;
 335   scm_cur_outp = scm_def_outp;
 336   scm_cur_errp = scm_def_errp;
 337   scm_cur_loadp = SCM_BOOL_F;
 338 }
 339
 340
 341 \f
 342 /* Loading the startup Scheme files.  */
 343
 344 /* The boot code "ice-9/boot-9" is only loaded by scm_boot_guile when
 345    this is false.  The unexec code uses this, to keep ice_9 from being
 346    loaded into dumped guile executables.  */
 347 int scm_ice_9_already_loaded = 0;
 348
 349 void
 350 scm_load_startup_files ()
 351 {
 352   /* We want a path only containing directories from GUILE_LOAD_PATH,
 353      SCM_SITE_DIR and SCM_LIBRARY_DIR when searching for the site init
 354      file, so we do this before loading Ice-9.  */
 355   SCM init_path = scm_sys_search_load_path (scm_makfrom0str ("init.scm"));
 356
 357   /* Load Ice-9.  */
 358   if (!scm_ice_9_already_loaded)
 359     {
 360       scm_primitive_load_path (scm_makfrom0str ("ice-9/boot-9.scm"));
 361
 362       /* Load the init.scm file.  */
 363       if (SCM_NFALSEP (init_path))
 364         scm_primitive_load (init_path);
 365
 366       scm_post_boot_init_modules ();
 367     }
 368 }
 369
 370 /* Get an integer from an environment variable.  */
 371 static int
 372 scm_i_getenv_int (const char *var, int def)
 373 {
 374   char *end, *val = getenv (var);
 375   long res;
 376   if (!val)
 377     return def;
 378   res = strtol (val, &end, 10);
 379   if (end == val)
 380     return def;
 381   return res;
 382 }
 383
 384 \f
 385 /* The main init code.  */
 386
 387 #ifdef _UNICOS
 388 typedef int setjmp_type;
 389 #else
 390 typedef long setjmp_type;
 391 #endif
 392
 393 /* All the data needed to invoke the main function.  */
 394 struct main_func_closure
 395 {
 396   /* the function to call */
 397   void (*main_func)(void *closure, int argc, char **argv);
 398   void *closure;                /* dummy data to pass it */
 399   int argc;
 400   char **argv;                  /* the argument list it should receive */
 401 };
 402
 403
 404 static void scm_init_guile_1 (SCM_STACKITEM *base);
 405 static void scm_boot_guile_1 (SCM_STACKITEM *base,
 406                               struct main_func_closure *closure);
 407 static SCM invoke_main_func(void *body_data);
 408
 409
 410 /* Fire up the Guile Scheme interpreter.
 411
 412    Call MAIN_FUNC, passing it CLOSURE, ARGC, and ARGV.  MAIN_FUNC
 413    should do all the work of the program (initializing other packages,
 414    reading user input, etc.) before returning.  When MAIN_FUNC
 415    returns, call exit (0); this function never returns.  If you want
 416    some other exit value, MAIN_FUNC may call exit itself.
 417
 418    scm_boot_guile arranges for program-arguments to return the strings
 419    given by ARGC and ARGV.  If MAIN_FUNC modifies ARGC/ARGV, should
 420    call scm_set_program_arguments with the final list, so Scheme code
 421    will know which arguments have been processed.
 422
 423    scm_boot_guile establishes a catch-all catch handler which prints
 424    an error message and exits the process.  This means that Guile
 425    exits in a coherent way when system errors occur and the user isn't
 426    prepared to handle it.  If the user doesn't like this behavior,
 427    they can establish their own universal catcher to shadow this one.
 428
 429    Why must the caller do all the real work from MAIN_FUNC?  The
 430    garbage collector assumes that all local variables of type SCM will
 431    be above scm_boot_guile's stack frame on the stack.  If you try to
 432    manipulate SCM values after this function returns, it's the luck of
 433    the draw whether the GC will be able to find the objects you
 434    allocate.  So, scm_boot_guile function exits, rather than
 435    returning, to discourage people from making that mistake.  */
 436
 437
 438 void
 439 scm_boot_guile (int argc, char ** argv, void (*main_func) (), void *closure)
 440 {
 441   /* The garbage collector uses the address of this variable as one
 442      end of the stack, and the address of one of its own local
 443      variables as the other end.  */
 444   SCM_STACKITEM dummy;
 445   struct main_func_closure c;
 446
 447   c.main_func = main_func;
 448   c.closure = closure;
 449   c.argc = argc;
 450   c.argv = argv;
 451
 452   scm_boot_guile_1 (&dummy, &c);
 453 }
 454
 455 void
 456 scm_init_guile ()
 457 {
 458   scm_init_guile_1 ((SCM_STACKITEM *)scm_get_stack_base ());
 459 }
 460
 461 int scm_initialized_p = 0;
 462
 463 static void
 464 scm_init_guile_1 (SCM_STACKITEM *base)
 465 {
 466   if (scm_initialized_p)
 467     return;
 468
 469   if (base == NULL)
 470     {
 471       fprintf (stderr, "cannot determine stack base!\n");
 472       abort ();
 473     }
 474
 475   scm_ints_disabled = 1;
 476   scm_block_gc = 1;
 477
 478   scm_ports_prehistory ();
 479   scm_smob_prehistory ();
 480   scm_tables_prehistory ();
 481 #ifdef GUILE_DEBUG_MALLOC
 482   scm_debug_malloc_prehistory ();
 483 #endif
 484   scm_init_storage (scm_i_getenv_int ("GUILE_INIT_SEGMENT_SIZE_1", 0),
 485                     scm_i_getenv_int ("GUILE_MIN_YIELD_1", 0),
 486                     scm_i_getenv_int ("GUILE_INIT_SEGMENT_SIZE_2", 0),
 487                     scm_i_getenv_int ("GUILE_MIN_YIELD_2", 0),
 488                     scm_i_getenv_int ("GUILE_MAX_SEGMENT_SIZE", 0));
 489   scm_struct_prehistory ();     /* Must come after scm_init_storage */
 490   scm_weaks_prehistory ();      /* Must come after scm_init_storage */
 491   scm_init_subr_table ();
 492   scm_environments_prehistory (); /* create the root environment */
 493   scm_init_continuations ();
 494   scm_init_root ();
 495 #ifdef USE_THREADS
 496   scm_init_threads (base);
 497 #endif
 498   start_stack (base);
 499   scm_init_gsubr ();
 500   scm_init_environments ();
 501   scm_init_feature ();
 502   scm_init_alist ();
 503   scm_init_arbiters ();
 504   scm_init_async ();
 505   scm_init_boolean ();
 506   scm_init_chars ();
 507 #ifdef GUILE_DEBUG_MALLOC
 508   scm_init_debug_malloc ();
 509 #endif
 510   scm_init_dynwind ();
 511   scm_init_eq ();
 512   scm_init_error ();
 513   scm_init_fluids ();
 514   scm_init_backtrace ();        /* Requires fluids */
 515   scm_init_fports ();
 516   scm_init_gdbint ();
 517   scm_init_hash ();
 518   scm_init_hashtab ();
 519   scm_init_objprop ();
 520   scm_init_properties ();
 521   scm_init_hooks ();        /* Requires objprop until hook names are removed */
 522   scm_init_gc ();               /* Requires hooks, async */
 523 #ifdef GUILE_ISELECT
 524   scm_init_iselect ();
 525 #endif
 526   scm_init_ioext ();
 527   scm_init_keywords ();
 528   scm_init_list ();
 529   scm_init_macros ();
 530   scm_init_mallocs ();
 531   scm_init_modules ();
 532   scm_init_numbers ();
 533   scm_init_options ();
 534   scm_init_pairs ();
 535   scm_init_ports ();
 536 #ifdef HAVE_POSIX
 537   scm_init_filesys ();
 538   scm_init_posix ();
 539 #endif
 540 #ifdef HAVE_REGCOMP
 541   scm_init_regex_posix ();
 542 #endif
 543   scm_init_procs ();
 544   scm_init_procprop ();
 545   scm_init_scmsigs ();
 546 #ifdef HAVE_NETWORKING
 547   scm_init_net_db ();
 548   scm_init_socket ();
 549 #endif
 550   scm_init_sort ();
 551 #ifdef DEBUG_EXTENSIONS
 552   scm_init_srcprop ();
 553 #endif
 554   scm_init_stackchk ();
 555   scm_init_struct ();   /* Requires struct */
 556   scm_init_stacks ();
 557   scm_init_strports ();
 558   scm_init_symbols ();
 559   scm_init_tag ();
 560   scm_init_load ();
 561   scm_init_objects ();  /* Requires struct */
 562   scm_init_print ();    /* Requires struct */
 563   scm_init_read ();
 564   scm_init_stime ();
 565   scm_init_strings ();
 566   scm_init_strorder ();
 567   scm_init_strop ();
 568   scm_init_throw ();
 569   scm_init_variable ();
 570   scm_init_vectors ();
 571   scm_init_version ();
 572   scm_init_weaks ();
 573   scm_init_guardian ();
 574   scm_init_vports ();
 575   scm_init_eval ();
 576   scm_init_evalext ();
 577 #ifdef DEBUG_EXTENSIONS
 578   scm_init_debug ();    /* Requires macro smobs */
 579 #endif
 580   scm_init_random ();
 581 #ifdef HAVE_ARRAYS
 582   scm_init_ramap ();
 583   scm_init_unif ();
 584 #endif
 585   scm_init_simpos ();
 586   scm_init_load_path ();
 587   scm_init_standard_ports ();
 588   scm_init_dynamic_linking ();
 589   scm_init_lang ();
 590   scm_init_script ();
 591
 592   scm_init_oop_goops_goopscore_module ();
 593
 594   scm_initialized_p = 1;
 595
 596   scm_block_gc = 0;             /* permit the gc to run */
 597   /* ints still disabled */
 598
 599 #ifdef STACK_CHECKING
 600   scm_stack_checking_enabled_p = SCM_STACK_CHECKING_P;
 601 #endif
 602
 603   scm_load_startup_files ();
 604 }
 605
 606 /* Record here whether SCM_BOOT_GUILE_1 has already been called.  This
 607    variable is now here and not inside SCM_BOOT_GUILE_1 so that one
 608    can tweak it. This is necessary for unexec to work. (Hey, "1-live"
 609    is the name of a local radiostation...) */
 610
 611 int scm_boot_guile_1_live = 0;
 612
 613 static void
 614 scm_boot_guile_1 (SCM_STACKITEM *base, struct main_func_closure *closure)
 615 {
 616   scm_init_guile_1 (base);
 617
 618   /* This function is not re-entrant. */
 619   if (scm_boot_guile_1_live)
 620     abort ();
 621
 622   scm_boot_guile_1_live = 1;
 623
 624   scm_set_program_arguments (closure->argc, closure->argv, 0);
 625   invoke_main_func (closure);
 626
 627   scm_restore_signals ();
 628
 629   /* This tick gives any pending
 630    * asyncs a chance to run.  This must be done after
 631    * the call to scm_restore_signals.
 632    */
 633   SCM_ASYNC_TICK;
 634
 635   /* If the caller doesn't want this, they should return from
 636      main_func themselves.  */
 637   exit (0);
 638 }
 639
 640 static SCM
 641 invoke_main_func (void *body_data)
 642 {
 643   struct main_func_closure *closure = (struct main_func_closure *) body_data;
 644
 645   (*closure->main_func) (closure->closure, closure->argc, closure->argv);
 646
 647   /* never reached */
 648   return SCM_UNDEFINED;
 649 }
 650
 651 /*
 652   Local Variables:
 653   c-file-style: "gnu"
 654   End:
 655 */