libguile/gscm.c

   1 /*      Copyright (C) 1994, 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
  44 \f
  45
  46 #include <stdio.h>
  47 #include <sys/param.h>
  48 #include "gscm.h"
  49 #include "_scm.h"
  50
  51 #ifdef HAVE_UNISTD_H
  52 #include <unistd.h>
  53 #endif
  54 #ifdef HAVE_STRING_H
  55 #include <string.h>
  56 #endif
  57
  58 \f
  59
  60 extern char *getenv ();
  61
  62 \f
  63 /* {Top Level Evaluation}
  64  *
  65  * Top level evaluation has to establish a dynamic root context,
  66  * enable Scheme signal handlers, and catch global escapes (errors, quits,
  67  * aborts, restarts, and execs) from the interpreter.
  68  */
  69
  70
  71 /* {Printing Objects to Strings}
  72  */
  73
  74 #ifdef __STDC__
  75 static GSCM_status
  76 gscm_portprint_obj (SCM port, SCM obj)
  77 #else
  78 static GSCM_status
  79 gscm_portprint_obj (port, obj)
  80      SCM port;
  81      SCM obj;
  82 #endif
  83 {
  84   scm_iprin1 (obj, port, 1);
  85   return GSCM_OK;
  86 }
  87
  88
  89 struct seval_str_frame
  90 {
  91   GSCM_status status;
  92   SCM * answer;
  93   GSCM_top_level top;
  94   char * str;
  95 };
  96
  97 #ifdef __STDC__
  98 static void
  99 _seval_str_fn (void * vframe)
 100 #else
 101 static void
 102 _seval_str_fn (vframe)
 103      void * vframe;
 104 #endif
 105 {
 106   struct seval_str_frame * frame;
 107   frame = (struct seval_str_frame *)vframe;
 108   frame->status = gscm_seval_str (frame->answer, frame->top, frame->str);
 109 }
 110
 111
 112
 113 #ifdef __STDC__
 114 static GSCM_status
 115 gscm_strprint_obj (SCM * answer, SCM obj)
 116 #else
 117 static GSCM_status
 118 gscm_strprint_obj (answer, obj)
 119      SCM * answer;
 120      SCM obj;
 121 #endif
 122 {
 123   SCM str;
 124   SCM port;
 125   GSCM_status stat;
 126   str = scm_makstr (64, 0);
 127   port = scm_mkstrport (SCM_MAKINUM (0), str, SCM_OPN | SCM_WRTNG, "gscm_strprint_obj");
 128   stat = gscm_portprint_obj (port, obj);
 129   if (stat == GSCM_OK)
 130     *answer = str;
 131   else
 132     *answer = SCM_BOOL_F;
 133   return stat;
 134 }
 135
 136 #ifdef __STDC__
 137 static GSCM_status
 138 gscm_cstr (char ** answer, SCM obj)
 139 #else
 140 static GSCM_status
 141 gscm_cstr (answer, obj)
 142      char ** answer;
 143      SCM obj;
 144 #endif
 145 {
 146   GSCM_status stat;
 147
 148   *answer = (char *)malloc (SCM_LENGTH (obj));
 149   stat = GSCM_OK;
 150   if (!*answer)
 151     stat = GSCM_OUT_OF_MEM;
 152   else
 153     memcpy (*answer, SCM_CHARS (obj), SCM_LENGTH (obj));
 154   return stat;
 155 }
 156
 157
 158 /* {Invoking The Interpreter}
 159  */
 160
 161 #ifdef __STDC__
 162 static SCM
 163 gscm_silent_repl (SCM env)
 164 #else
 165 static SCM
 166 gscm_silent_repl (env)
 167      SCM env;
 168 #endif
 169 {
 170   SCM source;
 171   SCM answer;
 172   answer = SCM_UNSPECIFIED;
 173   while ((source = scm_read (SCM_UNDEFINED, SCM_UNDEFINED, SCM_UNDEFINED)) != SCM_EOF_VAL)
 174     answer = scm_eval_x (source);
 175   return answer;
 176 }
 177
 178
 179 #ifdef _UNICOS
 180 typedef int setjmp_type;
 181 #else
 182 typedef long setjmp_type;
 183 #endif
 184
 185 #ifdef __STDC__
 186 static GSCM_status
 187 _eval_port (SCM * answer, GSCM_top_level toplvl, SCM port, int printp)
 188 #else
 189 static GSCM_status
 190 _eval_port (answer, toplvl, port, printp)
 191      SCM * answer;
 192      GSCM_top_level toplvl;
 193      SCM port;
 194      int printp;
 195 #endif
 196 {
 197   SCM saved_inp;
 198   GSCM_status status;
 199   setjmp_type i;
 200   static int deja_vu = 0;
 201   SCM ignored;
 202
 203   if (deja_vu)
 204     return GSCM_ILLEGALLY_REENTERED;
 205
 206   ++deja_vu;
 207   /* Take over signal handlers for all the interesting signals.
 208    */
 209   scm_init_signals ();
 210
 211
 212   /* Default return values:
 213    */
 214   if (!answer)
 215     answer = &ignored;
 216   status = GSCM_OK;
 217   *answer = SCM_BOOL_F;
 218
 219   /* Perform evalutation under a new dynamic root.
 220    *
 221    */
 222   SCM_BASE (scm_rootcont) = (SCM_STACKITEM *) & i;
 223 #ifdef DEBUG_EXTENSIONS
 224   SCM_DFRAME (scm_rootcont) = last_debug_info_frame = 0;
 225 #endif
 226   saved_inp = scm_cur_inp;
 227   i = setjmp (SCM_JMPBUF (scm_rootcont));
 228 #ifdef SCM_STACK_CHECK
 229   scm_check_stack_p = 1;
 230 #endif
 231   if (!i)
 232     {
 233       scm_gc_heap_lock = 0;
 234       scm_ints_disabled = 0;
 235       /* need to close loading files here. */
 236       scm_cur_inp = port;
 237       {
 238         SCM top_env;
 239         top_env = SCM_EOL;
 240         *answer = gscm_silent_repl (top_env);
 241       }
 242       scm_cur_inp = saved_inp;
 243       if (printp)
 244         status = gscm_strprint_obj (answer, *answer);
 245     }
 246   else
 247     {
 248       scm_cur_inp = saved_inp;
 249       *answer = scm_exitval;
 250       if (printp)
 251         gscm_strprint_obj (answer, *answer);
 252       status = GSCM_ERROR;
 253     }
 254
 255   scm_gc_heap_lock = 1;
 256   scm_ints_disabled = 1;
 257   scm_restore_signals ();
 258   --deja_vu;
 259   return status;
 260 }
 261
 262 #ifdef __STDC__
 263 static GSCM_status
 264 seval_str (SCM *answer, GSCM_top_level toplvl, char * str)
 265 #else
 266 static GSCM_status
 267 seval_str (answer, toplvl, str)
 268      SCM *answer;
 269      GSCM_top_level toplvl;
 270      char * str;
 271 #endif
 272 {
 273   SCM scheme_str;
 274   SCM port;
 275   GSCM_status status;
 276
 277   scheme_str = scm_makfromstr (str, strlen (str), 0);
 278   port = scm_mkstrport (SCM_MAKINUM (0), scheme_str, SCM_OPN | SCM_RDNG, "gscm_seval_str");
 279   status = _eval_port (answer, toplvl, port, 0);
 280   return status;
 281 }
 282
 283
 284 #ifdef __STDC__
 285 GSCM_status
 286 gscm_seval_str (SCM *answer, GSCM_top_level toplvl, char * str)
 287 #else
 288 GSCM_status
 289 gscm_seval_str (answer, toplvl, str)
 290      SCM *answer;
 291      GSCM_top_level toplvl;
 292      char * str;
 293 #endif
 294 {
 295   SCM_STACKITEM i;
 296   GSCM_status status;
 297   scm_stack_base = &i;
 298   status = seval_str (answer, toplvl, str);
 299   scm_stack_base = 0;
 300   return status;
 301 }
 302
 303 #ifdef __STDC__
 304 void
 305 format_load_command (char * buf, char *file_name)
 306 #else
 307 void
 308 format_load_command (buf, file_name)
 309      char * buf;
 310      char *file_name;
 311 #endif
 312 {
 313   char quoted_name[MAXPATHLEN + 1];
 314   int source;
 315   int dest;
 316
 317   for (source = dest = 0; file_name[source]; ++source)
 318     {
 319       if (file_name[source] == '"')
 320         quoted_name[dest++] = '\\';
 321       quoted_name[dest++] = file_name[source];
 322     }
 323   quoted_name[dest] = 0;
 324   sprintf (buf, "(%%try-load \"%s\")", quoted_name);
 325 }
 326
 327 #ifdef __STDC__
 328 GSCM_status
 329 gscm_seval_file (SCM *answer, GSCM_top_level toplvl, char * file_name)
 330 #else
 331 GSCM_status
 332 gscm_seval_file (answer, toplvl, file_name)
 333      SCM *answer;
 334      GSCM_top_level toplvl;
 335      char * file_name;
 336 #endif
 337 {
 338   char command[MAXPATHLEN * 3];
 339   format_load_command (command, file_name);
 340   return gscm_seval_str (answer, toplvl, command);
 341 }
 342
 343
 344 #ifdef __STDC__
 345 static GSCM_status
 346 eval_str (char ** answer, GSCM_top_level toplvl, char * str)
 347 #else
 348 static GSCM_status
 349 eval_str (answer, toplvl, str)
 350      char ** answer;
 351      GSCM_top_level toplvl;
 352      char * str;
 353 #endif
 354 {
 355   SCM sanswer;
 356   SCM scheme_str;
 357   SCM port;
 358   GSCM_status status;
 359
 360   scheme_str = scm_makfromstr (str, strlen (str), 0);
 361   port = scm_mkstrport (SCM_MAKINUM(0), scheme_str, SCM_OPN | SCM_RDNG, "gscm_eval_str");
 362   status = _eval_port (&sanswer, toplvl, port, 1);
 363   if (answer)
 364     {
 365       if (status == GSCM_OK)
 366         status = gscm_cstr (answer, sanswer);
 367       else
 368         *answer = 0;
 369     }
 370   return status;
 371 }
 372
 373
 374 #ifdef __STDC__
 375 GSCM_status
 376 gscm_eval_str (char ** answer, GSCM_top_level toplvl, char * str)
 377 #else
 378 GSCM_status
 379 gscm_eval_str (answer, toplvl, str)
 380      char ** answer;
 381      GSCM_top_level toplvl;
 382      char * str;
 383 #endif
 384 {
 385   SCM_STACKITEM i;
 386   GSCM_status status;
 387   scm_stack_base = &i;
 388   status = eval_str (answer, toplvl, str);
 389   scm_stack_base = 0;
 390   return status;
 391 }
 392
 393
 394 #ifdef __STDC__
 395 GSCM_status
 396 gscm_eval_file (char ** answer, GSCM_top_level toplvl, char * file_name)
 397 #else
 398 GSCM_status
 399 gscm_eval_file (answer, toplvl, file_name)
 400      char ** answer;
 401      GSCM_top_level toplvl;
 402      char * file_name;
 403 #endif
 404 {
 405   char command[MAXPATHLEN * 3];
 406   format_load_command (command, file_name);
 407   return gscm_eval_str (answer, toplvl, command);
 408 }
 409
 410
 411
 412 \f
 413 /* {Error Messages}
 414  */
 415
 416
 417 #ifdef __GNUC__
 418 # define AT(X)  [X] =
 419 #else
 420 # define AT(X)
 421 #endif
 422
 423 static char * gscm_error_msgs[] =
 424 {
 425   AT(GSCM_OK) "No error.",
 426   AT(GSCM_ERROR) "ERROR in init file.",
 427   AT(GSCM_ILLEGALLY_REENTERED) "Gscm function was illegally reentered.",
 428   AT(GSCM_OUT_OF_MEM) "Out of memory.",
 429   AT(GSCM_ERROR_OPENING_FILE) "Error opening file.",
 430   AT(GSCM_ERROR_OPENING_INIT_FILE) "Error opening init file."
 431 };
 432
 433 #ifdef __STDC__
 434 char *
 435 gscm_error_msg (int n)
 436 #else
 437 char *
 438 gscm_error_msg (n)
 439      int n;
 440 #endif
 441 {
 442   if ((n < 0) || (n > (sizeof (gscm_error_msgs) / sizeof (char *))))
 443     return "Unrecognized error.";
 444   else
 445     return gscm_error_msgs[n];
 446 }
 447
 448
 449 \f
 450 /* {Defining New Procedures}
 451  */
 452
 453 #ifdef __STDC__
 454 SCM
 455 gscm_make_subr (SCM (*fn)(), int req, int opt, int varp, char * doc)
 456 #else
 457 SCM
 458 gscm_make_subr (fn, req, opt, varp, doc)
 459      SCM (*fn)();
 460      int req;
 461      int opt;
 462      int varp;
 463      char * doc;
 464 #endif
 465 {
 466   return scm_make_gsubr ("*anonymous*", req, opt, varp, fn);
 467 }
 468 \f
 469 #ifdef __STDC__
 470 int
 471 gscm_2_char (SCM c)
 472 #else
 473 int
 474 gscm_2_char (c)
 475      SCM c;
 476 #endif
 477 {
 478   SCM_ASSERT (SCM_ICHRP (c), c, SCM_ARG1, "gscm_2_char");
 479   return SCM_ICHR (c);
 480 }
 481
 482 \f
 483
 484 #ifdef __STDC__
 485 void
 486 gscm_2_str (char ** out, int * len_out, SCM * objp)
 487 #else
 488 void
 489 gscm_2_str (out, len_out, objp)
 490      char ** out;
 491      int * len_out;
 492      SCM * objp;
 493 #endif
 494 {
 495   SCM_ASSERT (SCM_NIMP (*objp) && SCM_STRINGP (*objp), *objp, SCM_ARG3, "gscm_2_str");
 496   if (out)
 497     *out = SCM_CHARS (*objp);
 498   if (len_out)
 499     *len_out = SCM_LENGTH (*objp);
 500 }
 501 \f
 502
 503 #ifdef __STDC__
 504 void
 505 gscm_error (char * message, SCM args)
 506 #else
 507 void
 508 gscm_error (message, args)
 509      char * message;
 510      SCM args;
 511 #endif
 512 {
 513   SCM errsym;
 514   SCM str;
 515
 516   errsym = SCM_CAR (scm_intern ("error", 5));
 517   str = scm_makfrom0str (message);
 518   scm_throw (errsym, scm_cons (str, args));
 519 }
 520
 521 \f
 522 #ifdef __STDC__
 523 GSCM_status
 524 gscm_run_scm (int argc, char ** argv, FILE * in, FILE * out, FILE * err, GSCM_status (*initfn)(), char * initfile, char * initcmd)
 525 #else
 526 GSCM_status
 527 gscm_run_scm (argc, argv, in, out, err, initfn, initfile, initcmd)
 528      int argc;
 529      char ** argv;
 530      FILE * in;
 531      FILE * out;
 532      FILE * err;
 533      GSCM_status (*initfn)();
 534      char * initfile;
 535      char * initcmd;
 536 #endif
 537 {
 538   SCM_STACKITEM i;
 539   GSCM_status status;
 540   GSCM_top_level top;
 541
 542   scm_ports_prehistory ();
 543   scm_smob_prehistory ();
 544   scm_tables_prehistory ();
 545   scm_init_storage (0);
 546   scm_start_stack (&i, in, out, err);
 547   scm_init_gsubr ();
 548   scm_init_curry ();
 549   scm_init_feature ();
 550 /*  scm_init_debug ();  */
 551   scm_init_alist ();
 552   scm_init_append ();
 553   scm_init_arbiters ();
 554   scm_init_async ();
 555   scm_init_boolean ();
 556   scm_init_chars ();
 557   scm_init_continuations ();
 558   scm_init_dynwind ();
 559   scm_init_eq ();
 560   scm_init_error ();
 561   scm_init_fports ();
 562   scm_init_files ();
 563   scm_init_gc ();
 564   scm_init_hash ();
 565   scm_init_hashtab ();
 566   scm_init_kw ();
 567   scm_init_list ();
 568   scm_init_lvectors ();
 569   scm_init_numbers ();
 570   scm_init_pairs ();
 571   scm_init_ports ();
 572   scm_init_procs ();
 573   scm_init_procprop ();
 574   scm_init_scmsigs ();
 575   scm_init_stackchk ();
 576   scm_init_strports ();
 577   scm_init_struct ();
 578   scm_init_symbols ();
 579   scm_init_load ();
 580   scm_init_print ();
 581   scm_init_read ();
 582   scm_init_sequences ();
 583   scm_init_stime ();
 584   scm_init_strings ();
 585   scm_init_strorder ();
 586   scm_init_mbstrings ();
 587   scm_init_strop ();
 588   scm_init_throw ();
 589   scm_init_variable ();
 590   scm_init_vectors ();
 591   scm_init_weaks ();
 592   scm_init_vports ();
 593   scm_init_eval ();
 594   scm_init_ramap ();
 595   scm_init_unif ();
 596   scm_init_simpos ();
 597   scm_init_elisp ();
 598   scm_init_mallocs ();
 599   scm_init_cnsvobj ();
 600   scm_init_guile ();
 601   initfn ();
 602
 603   /* Save the argument list to be the return value of (program-arguments).
 604    */
 605   scm_progargs = scm_makfromstrs (argc, argv);
 606
 607   scm_gc_heap_lock = 0;
 608   errno = 0;
 609   scm_ints_disabled = 1;
 610
 611 /*  init_basic (); */
 612
 613 /*   init_init(); */
 614
 615   if (initfile == NULL)
 616     {
 617       initfile = getenv ("GUILE_INIT_PATH");
 618       if (initfile == NULL)
 619         initfile = SCM_IMPLINIT;
 620     }
 621
 622   if (initfile == NULL)
 623     {
 624       status = GSCM_OK;
 625     }
 626   else
 627     {
 628       SCM answer;
 629
 630       status = gscm_seval_file (&answer, -1, initfile);
 631       if ((status == GSCM_OK) && (answer == SCM_BOOL_F))
 632         status = GSCM_ERROR_OPENING_INIT_FILE;
 633     }
 634
 635   top = SCM_EOL;
 636
 637   if (status == GSCM_OK)
 638     {
 639       scm_sysintern ("*stdin*", scm_cur_inp);
 640       status = gscm_seval_str (0, top, initcmd);
 641     }
 642   return status;
 643 }
 644
 645 \f
 646
 647 #ifdef __STDC__
 648 void
 649 scm_init_guile (void)
 650 #else
 651 void
 652 scm_init_guile ()
 653 #endif
 654 {
 655 #include "gscm.x"
 656 }
 657