libguile/init.c

   1 /*      Copyright (C) 1995,1996 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, 675 Mass Ave, Cambridge, MA 02139, USA.
  16  *
  17  * As a special exception, the Free Software Foundation gives permission
  18  * for additional uses of the text contained in its release of GUILE.
  19  *
  20  * The exception is that, if you link the GUILE library with other files
  21  * to produce an executable, this does not by itself cause the
  22  * resulting executable to be covered by the GNU General Public License.
  23  * Your use of that executable is in no way restricted on account of
  24  * linking the GUILE library code into it.
  25  *
  26  * This exception does not however invalidate any other reasons why
  27  * the executable file might be covered by the GNU General Public License.
  28  *
  29  * This exception applies only to the code released by the
  30  * Free Software Foundation under the name GUILE.  If you copy
  31  * code from other Free Software Foundation releases into a copy of
  32  * GUILE, as the General Public License permits, the exception does
  33  * not apply to the code that you add in this way.  To avoid misleading
  34  * anyone as to the status of such modified files, you must delete
  35  * this exception notice from them.
  36  *
  37  * If you write modifications of your own for GUILE, it is your choice
  38  * whether to permit this exception to apply to your modifications.
  39  * If you do not wish that, delete this exception notice.
  40  */
  41 \f
  42
  43 #include <stdio.h>
  44 #include "_scm.h"
  45
  46 /* Everybody has an init function.  */
  47 #include "alist.h"
  48 #include "append.h"
  49 #include "arbiters.h"
  50 #include "async.h"
  51 #include "backtrace.h"
  52 #include "boolean.h"
  53 #include "chars.h"
  54 #include "continuations.h"
  55 #ifdef DEBUG_EXTENSIONS
  56 #include "debug.h"
  57 #endif
  58 #include "dynwind.h"
  59 #include "eq.h"
  60 #include "error.h"
  61 #include "eval.h"
  62 #include "fdsocket.h"
  63 #include "feature.h"
  64 #include "filesys.h"
  65 #include "fports.h"
  66 #include "gc.h"
  67 #include "gdbint.h"
  68 #include "gsubr.h"
  69 #include "hash.h"
  70 #include "hashtab.h"
  71 #include "ioext.h"
  72 #include "kw.h"
  73 #include "list.h"
  74 #include "load.h"
  75 #include "mallocs.h"
  76 #include "mbstrings.h"
  77 #include "numbers.h"
  78 #include "objprop.h"
  79 #include "options.h"
  80 #include "pairs.h"
  81 #include "ports.h"
  82 #include "posix.h"
  83 #include "print.h"
  84 #include "procprop.h"
  85 #include "procs.h"
  86 #include "ramap.h"
  87 #include "read.h"
  88 #include "scmsigs.h"
  89 #include "sequences.h"
  90 #include "simpos.h"
  91 #include "smob.h"
  92 #include "socket.h"
  93 #include "srcprop.h"
  94 #include "stackchk.h"
  95 #include "stacks.h"
  96 #include "stime.h"
  97 #include "strings.h"
  98 #include "strop.h"
  99 #include "strorder.h"
 100 #include "strports.h"
 101 #include "struct.h"
 102 #include "symbols.h"
 103 #include "tag.h"
 104 #include "throw.h"
 105 #include "unif.h"
 106 #include "variable.h"
 107 #include "vectors.h"
 108 #include "version.h"
 109 #include "vports.h"
 110 #include "weaks.h"
 111
 112 #include "init.h"
 113
 114 #ifdef HAVE_STRING_H
 115 #include <string.h>
 116 #endif
 117 #ifdef HAVE_UNISTD_H
 118 #include <unistd.h>
 119 #endif
 120 \f
 121
 122 void
 123 scm_start_stack (base, in, out, err)
 124      void * base;
 125      FILE * in;
 126      FILE * out;
 127      FILE * err;
 128 {
 129   SCM root;
 130   struct scm_port_table * pt;
 131
 132   root = scm_permanent_object (scm_make_root (SCM_UNDEFINED));
 133   scm_set_root (SCM_ROOT_STATE (root));
 134
 135   scm_stack_base = base;
 136
 137   /* Create standard ports from stdio files, if requested to do so.
 138    */
 139
 140   if (!in)
 141     {
 142       scm_def_inp = SCM_BOOL_F;
 143     }
 144   else
 145     {
 146       SCM_NEWCELL (scm_def_inp);
 147       pt = scm_add_to_port_table (scm_def_inp);
 148       SCM_CAR (scm_def_inp) = (scm_tc16_fport | SCM_OPN | SCM_RDNG);
 149       SCM_SETPTAB_ENTRY (scm_def_inp, pt);
 150       SCM_SETSTREAM (scm_def_inp, (SCM)in);
 151       if (isatty (fileno (in)))
 152         {
 153           scm_setbuf0 (scm_def_inp); /* turn off stdin buffering */
 154           SCM_CAR (scm_def_inp) |= SCM_BUF0;
 155         }
 156       scm_set_port_revealed_x (scm_def_inp, SCM_MAKINUM (1));
 157     }
 158
 159   if (!out)
 160     {
 161       scm_def_outp = SCM_BOOL_F;
 162     }
 163   else
 164     {
 165       SCM_NEWCELL (scm_def_outp);
 166       pt = scm_add_to_port_table (scm_def_outp);
 167       SCM_CAR (scm_def_outp) = (scm_tc16_fport | SCM_OPN | SCM_WRTNG);
 168       SCM_SETPTAB_ENTRY (scm_def_outp, pt);
 169       SCM_SETSTREAM (scm_def_outp, (SCM)out);
 170       scm_set_port_revealed_x (scm_def_outp, SCM_MAKINUM (1));
 171     }
 172
 173   if (!err)
 174     {
 175       scm_def_errp = SCM_BOOL_F;
 176     }
 177   else
 178     {
 179       SCM_NEWCELL (scm_def_errp);
 180       pt = scm_add_to_port_table (scm_def_errp);
 181       SCM_CAR (scm_def_errp) = (scm_tc16_fport | SCM_OPN | SCM_WRTNG);
 182       SCM_SETPTAB_ENTRY (scm_def_errp, pt);
 183       SCM_SETSTREAM (scm_def_errp, (SCM)err);
 184       scm_set_port_revealed_x (scm_def_errp, SCM_MAKINUM (1));
 185     }
 186
 187   scm_cur_inp = scm_def_inp;
 188   scm_cur_outp = scm_def_outp;
 189   scm_cur_errp = scm_def_errp;
 190
 191
 192   scm_progargs = SCM_BOOL_F;    /* vestigial */
 193   scm_exitval = SCM_BOOL_F;     /* vestigial */
 194
 195   scm_top_level_lookup_thunk_var = SCM_BOOL_F;
 196   scm_system_transformer = SCM_BOOL_F;
 197
 198   /* Create an object to hold the root continuation.
 199    */
 200   SCM_NEWCELL (scm_rootcont);
 201   SCM_SETJMPBUF (scm_rootcont, scm_must_malloc ((long) sizeof (scm_contregs), "continuation"));
 202   SCM_CAR (scm_rootcont) = scm_tc7_contin;
 203   SCM_SEQ (scm_rootcont) = 0;
 204   /* The root continuation if further initialized by scm_restart_stack. */
 205
 206   /* Create the look-aside stack for variables that are shared between
 207    * captured continuations.
 208    */
 209   scm_continuation_stack = scm_make_vector (SCM_MAKINUM (512), SCM_UNDEFINED, SCM_UNDEFINED);
 210   /* The continuation stack is further initialized by scm_restart_stack. */
 211
 212   /* The remainder of stack initialization is factored out to another function so that
 213    * if this stack is ever exitted, it can be re-entered using scm_restart_stack.
 214    */
 215   scm_restart_stack (base);
 216 }
 217
 218
 219 void
 220 scm_restart_stack (base)
 221      void * base;
 222 {
 223   scm_dynwinds = SCM_EOL;
 224   SCM_DYNENV (scm_rootcont) = SCM_EOL;
 225   SCM_THROW_VALUE (scm_rootcont) = SCM_EOL;
 226 #ifdef DEBUG_EXTENSIONS
 227   SCM_DFRAME (scm_rootcont) = scm_last_debug_frame = 0;
 228 #endif
 229   SCM_BASE (scm_rootcont) = base;
 230   scm_continuation_stack_ptr = SCM_MAKINUM (0);
 231 }
 232
 233 #if 0
 234 static char remsg[] = "remove\n#define ", addmsg[] = "add\n#define ";
 235
 236
 237 static void fixconfig SCM_P ((char *s1, char *s2, int s));
 238
 239 static void
 240 fixconfig (s1, s2, s)
 241      char *s1;
 242      char *s2;
 243      int s;
 244 {
 245   fputs (s1, stderr);
 246   fputs (s2, stderr);
 247   fputs ("\nin ", stderr);
 248   fputs (s ? "setjump" : "scmfig", stderr);
 249   fputs (".h and recompile scm\n", stderr);
 250   exit (1);
 251 }
 252
 253
 254 static void check_config SCM_P ((void));
 255
 256 static void
 257 check_config ()
 258 {
 259   scm_sizet j;
 260
 261   j = HEAP_SEG_SIZE;
 262   if (HEAP_SEG_SIZE != j)
 263     fixconfig ("reduce", "size of HEAP_SEG_SIZE", 0);
 264
 265 #ifdef SCM_SINGLES
 266   if (sizeof (float) != sizeof (long))
 267       fixconfig (remsg, "SCM_SINGLES", 0);
 268 #endif /* def SCM_SINGLES */
 269
 270
 271 #ifdef SCM_BIGDIG
 272   if (2 * SCM_BITSPERDIG / SCM_CHAR_BIT > sizeof (long))
 273       fixconfig (remsg, "SCM_BIGDIG", 0);
 274 #ifndef SCM_DIGSTOOBIG
 275   if (SCM_DIGSPERLONG * sizeof (SCM_BIGDIG) > sizeof (long))
 276       fixconfig (addmsg, "SCM_DIGSTOOBIG", 0);
 277 #endif
 278 #endif
 279
 280 #ifdef SCM_STACK_GROWS_UP
 281   if (((SCM_STACKITEM *) & j - stack_start_ptr) < 0)
 282     fixconfig (remsg, "SCM_STACK_GROWS_UP", 1);
 283 #else
 284   if ((stack_start_ptr - (SCM_STACKITEM *) & j) < 0)
 285     fixconfig (addmsg, "SCM_STACK_GROWS_UP", 1);
 286 #endif
 287 }
 288 #endif
 289
 290
 291 \f
 292 #ifdef _UNICOS
 293 typedef int setjmp_type;
 294 #else
 295 typedef long setjmp_type;
 296 #endif
 297
 298 /* Fire up Scheme.
 299  *
 300  * argc and argv are made the return values of program-arguments.
 301  *
 302  * in, out, and err, if not NULL, become the standard ports.
 303  *      If NULL is passed, your "initfunc" should set up the
 304  *      standard ports.
 305  *
 306  * boot_cmd is a string containing a Scheme expression to evaluate
 307  *      to get things rolling.
 308  *
 309  * result is returned a string containing a printed result of evaluating
 310  *      the boot command.
 311  *
 312  * the return value is:
 313  *      scm_boot_ok       - evaluation concluded normally
 314  *      scm_boot_error    - evaluation concluded with a Scheme error
 315  *      scm_boot_emem     - allocation error mallocing *result
 316  *      scm_boot_ereenter - scm_boot_guile was called re-entrantly, which is
 317  *                          prohibited.
 318  */
 319
 320 static int scm_boot_guile_1 SCM_P ((SCM_STACKITEM *base,
 321                                     char **result,
 322                                     int argc, char **argv,
 323                                     FILE *in, FILE *out, FILE *err,
 324                                     void (*init_func) (),
 325                                     char *boot_cmd));
 326
 327 int
 328 scm_boot_guile (result, argc, argv, in, out, err, init_func, boot_cmd)
 329      char ** result;
 330      int argc;
 331      char ** argv;
 332      FILE * in;
 333      FILE * out;
 334      FILE * err;
 335      void (*init_func) ();
 336      char * boot_cmd;
 337 {
 338   SCM_STACKITEM dummy;
 339
 340   return scm_boot_guile_1 (&dummy, result, argc, argv, in, out, err,
 341                            init_func, boot_cmd);
 342 }
 343
 344 static int
 345 scm_boot_guile_1 (base, result, argc, argv, in, out, err, init_func, boot_cmd)
 346      SCM_STACKITEM *base;
 347      char ** result;
 348      int argc;
 349      char ** argv;
 350      FILE * in;
 351      FILE * out;
 352      FILE * err;
 353      void (*init_func) ();
 354      char * boot_cmd;
 355 {
 356   static int initialized = 0;
 357   static int live = 0;
 358   setjmp_type setjmp_val;
 359   int stat;
 360
 361   if (live)                     /* This function is not re-entrant. */
 362     {
 363       return scm_boot_ereenter;
 364     }
 365
 366   live = 1;
 367
 368   scm_ints_disabled = 1;
 369   scm_block_gc = 1;
 370
 371   if (initialized)
 372     {
 373       scm_restart_stack (base);
 374     }
 375   else
 376     {
 377       scm_ports_prehistory ();
 378       scm_smob_prehistory ();
 379       scm_tables_prehistory ();
 380       scm_init_storage (0);
 381       scm_init_root ();
 382 #ifdef USE_THREADS
 383       scm_init_threads (base);
 384 #endif
 385       scm_start_stack (base, in, out, err);
 386       scm_init_gsubr ();
 387       scm_init_feature ();
 388       scm_init_alist ();
 389       scm_init_append ();
 390       scm_init_arbiters ();
 391       scm_init_async ();
 392       scm_init_backtrace ();
 393       scm_init_boolean ();
 394       scm_init_chars ();
 395       scm_init_continuations ();
 396       scm_init_dynwind ();
 397       scm_init_eq ();
 398       scm_init_error ();
 399       scm_init_fdsocket ();
 400       scm_init_fports ();
 401       scm_init_filesys ();
 402       scm_init_gc ();
 403       scm_init_gdbint ();
 404       scm_init_hash ();
 405       scm_init_hashtab ();
 406       scm_init_ioext ();
 407       scm_init_kw ();
 408       scm_init_list ();
 409       scm_init_mallocs ();
 410       scm_init_numbers ();
 411       scm_init_objprop ();
 412 #if DEBUG_EXTENSIONS
 413       /* Excluding this until it's really needed makes the binary
 414        * smaller after linking.  */
 415       scm_init_options ();
 416 #endif
 417       scm_init_pairs ();
 418       scm_init_ports ();
 419       scm_init_posix ();
 420       scm_init_procs ();
 421       scm_init_procprop ();
 422       scm_init_scmsigs ();
 423       scm_init_socket ();
 424 #ifdef DEBUG_EXTENSIONS
 425       scm_init_srcprop ();
 426 #endif
 427       scm_init_stackchk ();
 428       scm_init_struct ();       /* Requires struct */
 429       scm_init_stacks ();
 430       scm_init_strports ();
 431       scm_init_symbols ();
 432       scm_init_tag ();
 433       scm_init_load ();
 434       scm_init_print ();        /* Requires struct */
 435       scm_init_read ();
 436       scm_init_sequences ();
 437       scm_init_stime ();
 438       scm_init_strings ();
 439       scm_init_strorder ();
 440       scm_init_mbstrings ();
 441       scm_init_strop ();
 442       scm_init_throw ();
 443       scm_init_variable ();
 444       scm_init_vectors ();
 445       scm_init_version ();
 446       scm_init_weaks ();
 447       scm_init_vports ();
 448       scm_init_eval ();
 449 #ifdef DEBUG_EXTENSIONS
 450       scm_init_debug ();        /* Requires macro smobs */
 451 #endif
 452       scm_init_ramap ();
 453       scm_init_unif ();
 454       scm_init_simpos ();
 455       scm_progargs = scm_makfromstrs (argc, argv);
 456       scm_init_load_path ();
 457       initialized = 1;
 458     }
 459
 460   scm_block_gc = 0;             /* permit the gc to run */
 461   /* ints still disabled */
 462
 463   {
 464     SCM command;
 465
 466     command = scm_makfrom0str (boot_cmd);
 467
 468     setjmp_val = setjmp (SCM_JMPBUF (scm_rootcont));
 469
 470 #ifdef STACK_CHECKING
 471     scm_stack_checking_enabled_p = SCM_STACK_CHECKING_P;
 472 #endif
 473     if (!setjmp_val)
 474       {
 475         SCM last = SCM_UNDEFINED;
 476         scm_init_signals ();
 477
 478         /* Call the initialization function passed in by the user, if
 479            present.  */
 480         if (init_func) (*init_func) ();
 481
 482         /* Evaluate boot_cmd string.  */
 483         {
 484           SCM p;
 485           SCM form;
 486
 487           p = scm_mkstrport (SCM_MAKINUM (0),
 488                              command,
 489                              SCM_OPN | SCM_RDNG,
 490                              "boot_guile");
 491           while (1)
 492             {
 493               form = scm_read (p, SCM_BOOL_F, SCM_BOOL_F);
 494               if (SCM_EOF_VAL == form)
 495                 break;
 496               last = scm_eval_x (form);
 497             }
 498
 499         }
 500
 501         scm_restore_signals ();
 502         /* This tick gives any pending
 503          * asyncs a chance to run.  This must be done after
 504          * the call to scm_restore_signals.
 505          */
 506         SCM_ASYNC_TICK;
 507
 508         scm_ints_disabled = 1;  /* Hopefully redundant but just to be sure. */
 509
 510         {
 511           SCM str_answer;
 512
 513           str_answer = scm_strprint_obj (last);
 514           *result = (char *)malloc (1 + SCM_LENGTH (str_answer));
 515           if (!*result)
 516             stat = scm_boot_emem;
 517           else
 518             {
 519               memcpy (*result, SCM_CHARS (str_answer), SCM_LENGTH (str_answer));
 520               (*result)[SCM_LENGTH (str_answer)] = 0;
 521               stat = scm_boot_ok;
 522             }
 523         }
 524       }
 525     else
 526       {
 527         /* This is reached if an unhandled throw terminated Scheme.
 528          * Such an occurence should be extremely unlikely -- it indicates
 529          * a programming error in the boot code.
 530          *
 531          * Details of the bogus exception are stored in scm_exitval even
 532          * though that isn't currently reflected in the return value.
 533          * !!!
 534          */
 535
 536         scm_restore_signals ();
 537         /* This tick gives any pending
 538          * asyncs a chance to run.  This must be done after
 539          * the call to scm_restore_signals.
 540          *
 541          * Note that an unhandled exception during signal handling
 542          * will put as back at the call to scm_restore_signals immediately
 543          * preceeding.   A sufficiently bogus signal handler could
 544          * conceivably cause an infinite loop here.
 545          */
 546         SCM_ASYNC_TICK;
 547
 548         scm_ints_disabled = 1;  /* Hopefully redundant but just to be sure. */
 549
 550         {
 551           SCM str_answer;
 552
 553           str_answer = scm_strprint_obj (scm_exitval);
 554           *result = (char *)malloc (1 + SCM_LENGTH (str_answer));
 555           if (!*result)
 556             stat = scm_boot_emem;
 557           else
 558             {
 559               memcpy (*result, SCM_CHARS (str_answer), SCM_LENGTH (str_answer));
 560               (*result)[SCM_LENGTH (str_answer)] = 0;
 561               stat = scm_boot_error;
 562             }
 563         }
 564       }
 565   }
 566
 567   scm_block_gc = 1;
 568   live = 0;
 569   return stat;
 570 }