libguile/script.c

   1 /* Copyright (C) 1994, 1995, 1996, 1997 Free Software Foundation, Inc.
   2  * This program is free software; you can redistribute it and/or modify
   3  * it under the terms of the GNU General Public License as published by
   4  * the Free Software Foundation; either version 2, or (at your option)
   5  * any later version.
   6  *
   7  * This program is distributed in the hope that it will be useful,
   8  * but WITHOUT ANY WARRANTY; without even the implied warranty of
   9  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  10  * GNU General Public License for more details.
  11  *
  12  * You should have received a copy of the GNU General Public License
  13  * along with this software; see the file COPYING.  If not, write to
  14  * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
  15  * Boston, MA 02111-1307 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 /* "script.c" argv tricks for `#!' scripts.
  42    Authors: Aubrey Jaffer and Jim Blandy */
  43
  44 #include <stdio.h>
  45 #include <ctype.h>
  46 #include "_scm.h"
  47 #include "gh.h"
  48 #include "load.h"
  49 #include "version.h"
  50
  51 #include "script.h"
  52
  53 #ifdef HAVE_UNISTD_H
  54 #include <unistd.h>             /* for X_OK define */
  55 #endif
  56
  57 /* Concatentate str2 onto str1 at position n and return concatenated
  58    string if file exists; 0 otherwise. */
  59
  60 static char *
  61 scm_cat_path (str1, str2, n)
  62      char *str1;
  63      const char *str2;
  64      long n;
  65 {
  66   if (!n)
  67     n = strlen (str2);
  68   if (str1)
  69     {
  70       long len = strlen (str1);
  71       str1 = (char *) realloc (str1, (scm_sizet) (len + n + 1));
  72       if (!str1)
  73         return 0L;
  74       strncat (str1 + len, str2, n);
  75       return str1;
  76     }
  77   str1 = (char *) malloc ((scm_sizet) (n + 1));
  78   if (!str1)
  79     return 0L;
  80   str1[0] = 0;
  81   strncat (str1, str2, n);
  82   return str1;
  83 }
  84
  85 #if 0
  86 static char *
  87 scm_try_path (path)
  88      char *path;
  89 {
  90   FILE *f;
  91   /* fprintf(stderr, "Trying %s\n", path);fflush(stderr); */
  92   if (!path)
  93     return 0L;
  94   SCM_SYSCALL (f = fopen (path, "r");
  95     );
  96   if (f)
  97     {
  98       fclose (f);
  99       return path;
 100     }
 101   free (path);
 102   return 0L;
 103 }
 104
 105 static char *
 106 scm_sep_init_try (path, sep, initname)
 107      char *path;
 108      const char *sep, *initname;
 109 {
 110   if (path)
 111     path = scm_cat_path (path, sep, 0L);
 112   if (path)
 113     path = scm_cat_path (path, initname, 0L);
 114   return scm_try_path (path);
 115 }
 116 #endif
 117
 118 #ifndef LINE_INCREMENTORS
 119 #define LINE_INCREMENTORS  '\n'
 120 #ifdef MSDOS
 121 #define WHITE_SPACES  ' ':case '\t':case '\r':case '\f':case 26
 122 #else
 123 #define WHITE_SPACES  ' ':case '\t':case '\r':case '\f'
 124 #endif /* def MSDOS */
 125 #endif /* ndef LINE_INCREMENTORS */
 126
 127 #ifndef MAXPATHLEN
 128 #define MAXPATHLEN 80
 129 #endif /* ndef MAXPATHLEN */
 130 #ifndef X_OK
 131 #define X_OK 1
 132 #endif /* ndef X_OK */
 133
 134 #ifdef unix
 135 char *
 136 scm_find_executable (const char *name)
 137 {
 138   char tbuf[MAXPATHLEN];
 139   int i = 0;
 140   FILE *f;
 141
 142   /* fprintf(stderr, "s_f_e checking access %s ->%d\n", name, access(name, X_OK)); fflush(stderr); */
 143   if (access (name, X_OK))
 144     return 0L;
 145   f = fopen (name, "r");
 146   if (!f)
 147     return 0L;
 148   if ((fgetc (f) == '#') && (fgetc (f) == '!'))
 149     {
 150       while (1)
 151         switch (tbuf[i++] = fgetc (f))
 152           {
 153           case /*WHITE_SPACES */ ' ':
 154           case '\t':
 155           case '\r':
 156           case '\f':
 157           case EOF:
 158             tbuf[--i] = 0;
 159             fclose (f);
 160             return scm_cat_path (0L, tbuf, 0L);
 161           }
 162     }
 163   fclose (f);
 164   return scm_cat_path (0L, name, 0L);
 165 }
 166 #endif /* unix */
 167
 168 #ifdef MSDOS
 169
 170 #define DEFAULT_PATH "C:\\DOS"
 171 #define PATH_DELIMITER ';'
 172 #define ABSOLUTE_FILENAME_P(fname) ((fname[0] == '\\') \
 173                                      || (fname[0] && (fname[1] == ':')))
 174
 175 char *
 176 dld_find_executable (file)
 177      const char *file;
 178 {
 179   /* fprintf(stderr, "dld_find_executable %s -> %s\n", file, scm_cat_path(0L, file, 0L)); fflush(stderr); */
 180   return scm_cat_path (0L, file, 0L);
 181 }
 182 #endif /* def MSDOS */
 183
 184
 185 /* Read a \nnn-style escape.  We've just read the backslash.  */
 186 static int
 187 script_get_octal (f)
 188      FILE *f;
 189 {
 190   int i;
 191   int value = 0;
 192
 193   for (i = 0; i < 3; i++)
 194     {
 195       int c = getc (f);
 196       if ('0' <= c && c <= '7')
 197         value = (value * 8) + (c - '0');
 198       else
 199         scm_wta (SCM_UNDEFINED,
 200                  "malformed script: bad octal backslash escape",
 201                  "script argument parser");
 202     }
 203   return value;
 204 }
 205
 206
 207 static int
 208 script_get_backslash (f)
 209      FILE *f;
 210 {
 211   int c = getc (f);
 212
 213   switch (c)
 214     {
 215     case 'a': return '\a';
 216     case 'b': return '\b';
 217     case 'f': return '\f';
 218     case 'n': return '\n';
 219     case 'r': return '\r';
 220     case 't': return '\t';
 221     case 'v': return '\v';
 222
 223     case '\\':
 224     case ' ':
 225     case '\t':
 226     case '\n':
 227       return c;
 228
 229     case '0': case '1': case '2': case '3':
 230     case '4': case '5': case '6': case '7':
 231       ungetc (c, f);
 232       return script_get_octal (f);
 233
 234     case EOF:
 235       scm_wta (SCM_UNDEFINED,
 236                "malformed script: backslash followed by EOF",
 237                "script argument parser");
 238       return 0; /* not reached? */
 239
 240     default:
 241       scm_wta (SCM_UNDEFINED,
 242                "malformed script: bad backslash sequence",
 243                "script argument parser");
 244       return 0; /* not reached? */
 245     }
 246 }
 247
 248
 249 static char *
 250 script_read_arg (f)
 251      FILE *f;
 252 {
 253   int size = 7;
 254   char *buf = malloc (size + 1);
 255   int len = 0;
 256
 257   if (! buf)
 258     return 0;
 259
 260   for (;;)
 261     {
 262       int c = getc (f);
 263       switch (c)
 264         {
 265         case '\\':
 266           c = script_get_backslash (f);
 267           /* The above produces a new character to add to the argument.
 268              Fall through.  */
 269         default:
 270           if (len >= size)
 271             {
 272               size = (size + 1) * 2;
 273               buf = realloc (buf, size);
 274               if (! buf)
 275                 return 0;
 276             }
 277           buf[len++] = c;
 278           break;
 279
 280         case '\n':
 281           /* This may terminate an arg now, but it will terminate the
 282              entire list next time through.  */
 283           ungetc ('\n', f);
 284         case EOF:
 285           if (len == 0)
 286             {
 287               free (buf);
 288               return 0;
 289             }
 290           /* Otherwise, those characters terminate the argument; fall
 291              through.  */
 292         case ' ':
 293           buf[len] = '\0';
 294           return buf;
 295
 296         case '\t':
 297           free (buf);
 298           scm_wta (SCM_UNDEFINED,
 299                    "malformed script: TAB in meta-arguments",
 300                    "argument parser");
 301           return 0; /* not reached? */
 302         }
 303     }
 304 }
 305
 306
 307 static int
 308 script_meta_arg_P (arg)
 309      char *arg;
 310 {
 311   if ('\\' != arg[0])
 312     return 0L;
 313 #ifdef MSDOS
 314   return !arg[1];
 315 #else
 316   switch (arg[1])
 317     {
 318     case 0:
 319     case '%':
 320     case WHITE_SPACES:
 321       return !0;
 322     default:
 323       return 0L;
 324     }
 325 #endif
 326 }
 327
 328 char **
 329 scm_get_meta_args (argc, argv)
 330      int argc;
 331      char **argv;
 332 {
 333   int nargc = argc, argi = 1, nargi = 1;
 334   char *narg, **nargv;
 335   if (!(argc > 2 && script_meta_arg_P (argv[1])))
 336     return 0L;
 337   if (!(nargv = (char **) malloc ((1 + nargc) * sizeof (char *))))
 338       return 0L;
 339   nargv[0] = argv[0];
 340   while (((argi + 1) < argc) && (script_meta_arg_P (argv[argi])))
 341     {
 342       FILE *f = fopen (argv[++argi], "r");
 343       if (f)
 344         {
 345           nargc--;              /* to compensate for replacement of '\\' */
 346           while (1)
 347             switch (getc (f))
 348               {
 349               case EOF:
 350                 return 0L;
 351               default:
 352                 continue;
 353               case '\n':
 354                 goto found_args;
 355               }
 356         found_args:
 357           while ((narg = script_read_arg (f)))
 358             if (!(nargv = (char **) realloc (nargv,
 359                                              (1 + ++nargc) * sizeof (char *))))
 360                 return 0L;
 361             else
 362               nargv[nargi++] = narg;
 363           fclose (f);
 364           nargv[nargi++] = argv[argi++];
 365         }
 366     }
 367   while (argi <= argc)
 368     nargv[nargi++] = argv[argi++];
 369   return nargv;
 370 }
 371
 372 int
 373 scm_count_argv (argv)
 374      char **argv;
 375 {
 376   int argc = 0;
 377   while (argv[argc])
 378     argc++;
 379   return argc;
 380 }
 381
 382
 383 /* For use in error messages.  */
 384 char *scm_usage_name = 0;
 385
 386 void
 387 scm_shell_usage (int fatal, char *message)
 388 {
 389   if (message)
 390     fprintf (stderr, "%s\n", message);
 391
 392   fprintf (stderr,
 393            "Usage: %s OPTION ...\n"
 394            "Evaluate Scheme code, interactively or from a script.\n"
 395            "\n"
 396            "  -s SCRIPT      load Scheme source code from FILE, and exit\n"
 397            "  -c EXPR        evalute Scheme expression EXPR, and exit\n"
 398            "  --             stop scanning arguments; run interactively\n"
 399            "The above switches stop argument processing, and pass all\n"
 400            "remaining arguments as the value of (command-line).\n"
 401            "\n"
 402            "  -l FILE        load Scheme source code from FILE\n"
 403            "  -e FUNCTION    after reading script, apply FUNCTION to\n"
 404            "                 command line arguments\n"
 405            "  -ds            do -s script at this point\n"
 406            "  --emacs        enable Emacs protocol (experimental)\n"
 407            "  -h, --help     display this help and exit\n"
 408            "  -v, --version  display version information and exit\n"
 409            "  \\              read arguments from following script lines\n",
 410            scm_usage_name);
 411
 412   if (fatal)
 413     exit (fatal);
 414 }
 415
 416
 417 /* Some symbols used by the command-line compiler.  */
 418 SCM_SYMBOL (sym_load, "load");
 419 SCM_SYMBOL (sym_eval_string, "eval-string");
 420 SCM_SYMBOL (sym_command_line, "command-line");
 421 SCM_SYMBOL (sym_begin, "begin");
 422 SCM_SYMBOL (sym_load_user_init, "load-user-init");
 423 SCM_SYMBOL (sym_top_repl, "top-repl");
 424 SCM_SYMBOL (sym_quit, "quit");
 425
 426
 427 /* The boot code "ice-9/boot-9" is only loaded by
 428    SCM_COMPILE_SHELL_SWITCHES when this is false.  The unexec code
 429    uses this, to keep ice_9 from being loaded into dumped guile
 430    executables.  */
 431 int scm_ice_9_already_loaded = 0;
 432
 433 /* Given an array of command-line switches, return a Scheme expression
 434    to carry out the actions specified by the switches.
 435
 436    If you told me this should have been written in Scheme, I'd
 437    probably agree.  I'd say I didn't feel comfortable doing that in
 438    the present system.  You'd say, well, fix the system so you are
 439    comfortable doing that.  I'd agree again.  *shrug*
 440
 441    We load the ice-9 system from here.  It might be nicer if the
 442    libraries initialized from the inner_main function in guile.c (which
 443    will be auto-generated eventually) could assume ice-9 were already
 444    loaded.  Then again, it might be nice if ice-9 could assume that
 445    certain libraries were already loaded.  The solution is to break up
 446    ice-9 into modules which can be frozen and statically linked like any
 447    other module.  Then all the modules can describe their dependencies in
 448    the usual way, and the auto-generated inner_main will do the right
 449    thing. */
 450
 451 static char guile[] = "guile";
 452
 453 SCM
 454 scm_compile_shell_switches (int argc, char **argv)
 455 {
 456   SCM tail = SCM_EOL;           /* We accumulate the list backwards,
 457                                    and then reverse! it before we
 458                                    return it.  */
 459   SCM do_script = SCM_EOL;      /* The element of the list containing
 460                                    the "load" command, in case we get
 461                                    the "-ds" switch.  */
 462   SCM entry_point = SCM_EOL;    /* for -e switch */
 463   int interactive = 1;          /* Should we go interactive when done? */
 464   int use_emacs_interface = 0;
 465   int i;
 466   char *argv0 = guile;
 467
 468   if (argc > 0)
 469     {
 470       argv0 = argv[0];
 471       scm_usage_name = strrchr (argv[0], '/');
 472       if (! scm_usage_name)
 473         scm_usage_name = argv[0];
 474       else
 475         scm_usage_name++;
 476     }
 477   if (! scm_usage_name)
 478     scm_usage_name = guile;
 479
 480   for (i = 1; i < argc; i++)
 481     {
 482       if (! strcmp (argv[i], "-s")) /* load script */
 483         {
 484           if (++i >= argc)
 485             scm_shell_usage (1, "missing argument to `-s' switch");
 486
 487           /* If we specified the -ds option, do_script points to the
 488              cdr of an expression like (load #f); we replace the car
 489              (i.e., the #f) with the script name.  */
 490           if (do_script != SCM_EOL)
 491             {
 492               SCM_SETCAR (do_script, scm_makfrom0str (argv[i]));
 493               do_script = SCM_EOL;
 494             }
 495           else
 496             /* Construct an application of LOAD to the script name.  */
 497             tail = scm_cons (scm_cons2 (sym_load,
 498                                         scm_makfrom0str (argv[i]),
 499                                         SCM_EOL),
 500                                tail);
 501           argv0 = argv[i];
 502           i++;
 503           interactive = 0;
 504           break;
 505         }
 506
 507       else if (! strcmp (argv[i], "-c")) /* evaluate expr */
 508         {
 509           if (++i >= argc)
 510             scm_shell_usage (1, "missing argument to `-c' switch");
 511           tail = scm_cons (scm_cons2 (sym_eval_string,
 512                                       scm_makfrom0str (argv[i]),
 513                                       SCM_EOL),
 514                            tail);
 515           i++;
 516           interactive = 0;
 517           break;
 518         }
 519
 520       else if (! strcmp (argv[i], "--")) /* end args; go interactive */
 521         {
 522           i++;
 523           break;
 524         }
 525
 526       else if (! strcmp (argv[i], "-l")) /* load a file */
 527         {
 528           if (++i < argc)
 529             tail = scm_cons (scm_cons2 (sym_load,
 530                                         scm_makfrom0str (argv[i]),
 531                                         SCM_EOL),
 532                              tail);
 533           else
 534             scm_shell_usage (1, "missing argument to `-l' switch");
 535         }
 536
 537       else if (! strcmp (argv[i], "-e")) /* entry point */
 538         {
 539           if (++i < argc)
 540             entry_point = gh_symbol2scm (argv[i]);
 541           else
 542             scm_shell_usage (1, "missing argument to `-e' switch");
 543         }
 544
 545       else if (! strcmp (argv[i], "-ds")) /* do script here */
 546         {
 547           /* We put a dummy "load" expression, and let the -s put the
 548              filename in.  */
 549           if (do_script != SCM_EOL)
 550             scm_shell_usage (1, "the -ds switch may only be specified once");
 551           do_script = scm_cons (SCM_BOOL_F, SCM_EOL);
 552           tail = scm_cons (scm_cons (sym_load, do_script),
 553                            tail);
 554         }
 555
 556       else if (! strcmp (argv[i], "--emacs")) /* use emacs protocol */
 557         use_emacs_interface = 1;
 558
 559       else if (! strcmp (argv[i], "-h")
 560                || ! strcmp (argv[i], "--help"))
 561         {
 562           scm_shell_usage (0, 0);
 563           exit (0);
 564         }
 565
 566       else if (! strcmp (argv[i], "-v")
 567                || ! strcmp (argv[i], "--version"))
 568         {
 569           /* Print version number.  */
 570           printf ("Guile %s\n"
 571                   "Copyright (c) 1995, 1996, 1997 Free Software Foundation\n"
 572                   "Guile may be distributed under the terms of the GNU General Public Licence;\n"
 573                   "certain other uses are permitted as well.  For details, see the file\n"
 574                   "`COPYING', which is included in the Guile distribution.\n"
 575                   "There is no warranty, to the extent permitted by law.\n",
 576                   SCM_CHARS (scm_version ()));
 577           exit (0);
 578         }
 579
 580       else
 581         {
 582           fprintf (stderr, "%s: Unrecognized switch `%s'\n",
 583                    scm_usage_name, argv[i]);
 584           scm_shell_usage (1, 0);
 585         }
 586     }
 587
 588   /* Check to make sure the -ds got a -s. */
 589   if (do_script != SCM_EOL)
 590     scm_shell_usage (1, "the `-ds' switch requires the use of `-s' as well");
 591
 592   /* Make any remaining arguments available to the
 593      script/command/whatever.  */
 594   scm_set_program_arguments (argc - i, argv + i, argv0);
 595
 596   /* If the --emacs switch was set, now is when we process it.  */
 597   scm_sysintern ("use-emacs-interface",
 598                  (use_emacs_interface) ? SCM_BOOL_T : SCM_BOOL_F);
 599
 600   /* Handle the `-e' switch, if it was specified.  */
 601   if (entry_point != SCM_EOL)
 602     tail = scm_cons (scm_cons2 (entry_point,
 603                                 scm_cons (sym_command_line, SCM_EOL),
 604                                 SCM_EOL),
 605                        tail);
 606
 607   /* If we didn't end with a -c or a -s, load the user's customization
 608      file, and start the repl.  */
 609   if (interactive)
 610     {
 611       tail = scm_cons (scm_cons (sym_load_user_init, SCM_EOL), tail);
 612       tail = scm_cons (scm_cons (sym_top_repl, SCM_EOL), tail);
 613     }
 614   else
 615     {
 616       /* After doing all the other actions prescribed by the command line,
 617          quit.  */
 618       tail = scm_cons (scm_cons (sym_quit, SCM_EOL),
 619                    tail);
 620       /* Allow asyncs (signal handlers etc.) to be run.  */
 621       scm_mask_ints = 0;
 622     }
 623   {
 624     /* We want a path only containing directories from GUILE_LOAD_PATH,
 625        SCM_SITE_DIR and SCM_LIBRARY_DIR when searching for the site init
 626        file, so we do this before loading Ice-9.  */
 627     SCM init_path = scm_sys_search_load_path (scm_makfrom0str ("init.scm"));
 628
 629     /* Load Ice-9.  */
 630     if (!scm_ice_9_already_loaded)
 631       scm_primitive_load_path (scm_makfrom0str ("ice-9/boot-9.scm"));
 632
 633     /* Load the init.scm file.  */
 634     if (SCM_NFALSEP (init_path))
 635       scm_primitive_load (init_path);
 636   }
 637
 638   {
 639     SCM val = scm_cons (sym_begin, scm_reverse_x (tail, SCM_UNDEFINED));
 640
 641 #if 0
 642     scm_write (val, SCM_UNDEFINED);
 643     scm_newline (SCM_UNDEFINED);
 644 #endif
 645
 646     return val;
 647   }
 648 }
 649
 650
 651 void
 652 scm_shell (argc, argv)
 653      int argc;
 654      char **argv;
 655 {
 656   /* If present, add SCSH-style meta-arguments from the top of the
 657      script file to the argument vector.  See the SCSH manual: "The
 658      meta argument" for more details.  */
 659   {
 660     char **new_argv = scm_get_meta_args (argc, argv);
 661
 662     if (new_argv)
 663       {
 664         argv = new_argv;
 665         argc = scm_count_argv (new_argv);
 666       }
 667   }
 668
 669   exit (scm_exit_status (scm_eval_x (scm_compile_shell_switches (argc,argv))));
 670 }
 671
 672
 673 void
 674 scm_init_script ()
 675 {
 676 #include "script.x"
 677 }