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 SCM
 452 scm_compile_shell_switches (int argc, char **argv)
 453 {
 454   SCM tail = SCM_EOL;           /* We accumulate the list backwards,
 455                                    and then reverse! it before we
 456                                    return it.  */
 457   SCM do_script = SCM_EOL;      /* The element of the list containing
 458                                    the "load" command, in case we get
 459                                    the "-ds" switch.  */
 460   SCM entry_point = SCM_EOL;    /* for -e switch */
 461   int interactive = 1;          /* Should we go interactive when done? */
 462   int use_emacs_interface = 0;
 463   int i;
 464   char *argv0 = argv[0];
 465
 466   if (argc > 0)
 467     {
 468       scm_usage_name = strrchr (argv[0], '/');
 469       if (! scm_usage_name)
 470         scm_usage_name = argv[0];
 471       else
 472         scm_usage_name++;
 473     }
 474   if (! scm_usage_name)
 475     scm_usage_name = "guile";
 476
 477   for (i = 1; i < argc; i++)
 478     {
 479       if (! strcmp (argv[i], "-s")) /* load script */
 480         {
 481           if (++i >= argc)
 482             scm_shell_usage (1, "missing argument to `-s' switch");
 483
 484           /* If we specified the -ds option, do_script points to the
 485              cdr of an expression like (load #f); we replace the car
 486              (i.e., the #f) with the script name.  */
 487           if (do_script != SCM_EOL)
 488             {
 489               SCM_SETCAR (do_script, scm_makfrom0str (argv[i]));
 490               do_script = SCM_EOL;
 491             }
 492           else
 493             /* Construct an application of LOAD to the script name.  */
 494             tail = scm_cons (scm_cons2 (sym_load,
 495                                         scm_makfrom0str (argv[i]),
 496                                         SCM_EOL),
 497                                tail);
 498           argv0 = argv[i];
 499           i++;
 500           interactive = 0;
 501           break;
 502         }
 503
 504       else if (! strcmp (argv[i], "-c")) /* evaluate expr */
 505         {
 506           if (++i >= argc)
 507             scm_shell_usage (1, "missing argument to `-c' switch");
 508           tail = scm_cons (scm_cons2 (sym_eval_string,
 509                                       scm_makfrom0str (argv[i]),
 510                                       SCM_EOL),
 511                            tail);
 512           i++;
 513           interactive = 0;
 514           break;
 515         }
 516
 517       else if (! strcmp (argv[i], "--")) /* end args; go interactive */
 518         {
 519           i++;
 520           break;
 521         }
 522
 523       else if (! strcmp (argv[i], "-l")) /* load a file */
 524         {
 525           if (++i < argc)
 526             tail = scm_cons (scm_cons2 (sym_load,
 527                                         scm_makfrom0str (argv[i]),
 528                                         SCM_EOL),
 529                              tail);
 530           else
 531             scm_shell_usage (1, "missing argument to `-l' switch");
 532         }
 533
 534       else if (! strcmp (argv[i], "-e")) /* entry point */
 535         {
 536           if (++i < argc)
 537             entry_point = gh_symbol2scm (argv[i]);
 538           else
 539             scm_shell_usage (1, "missing argument to `-e' switch");
 540         }
 541
 542       else if (! strcmp (argv[i], "-ds")) /* do script here */
 543         {
 544           /* We put a dummy "load" expression, and let the -s put the
 545              filename in.  */
 546           if (do_script != SCM_EOL)
 547             scm_shell_usage (1, "the -ds switch may only be specified once");
 548           do_script = scm_cons (SCM_BOOL_F, SCM_EOL);
 549           tail = scm_cons (scm_cons (sym_load, do_script),
 550                            tail);
 551         }
 552
 553       else if (! strcmp (argv[i], "--emacs")) /* use emacs protocol */
 554         use_emacs_interface = 1;
 555
 556       else if (! strcmp (argv[i], "-h")
 557                || ! strcmp (argv[i], "--help"))
 558         {
 559           scm_shell_usage (0, 0);
 560           exit (0);
 561         }
 562
 563       else if (! strcmp (argv[i], "-v")
 564                || ! strcmp (argv[i], "--version"))
 565         {
 566           /* Print version number.  */
 567           printf ("Guile %s\n"
 568                   "Copyright (c) 1995, 1996, 1997 Free Software Foundation\n"
 569                   "Guile may be distributed under the terms of the GNU General Public Licence;\n"
 570                   "certain other uses are permitted as well.  For details, see the file\n"
 571                   "`COPYING', which is included in the Guile distribution.\n"
 572                   "There is no warranty, to the extent permitted by law.\n",
 573                   SCM_CHARS (scm_version ()));
 574           exit (0);
 575         }
 576
 577       else
 578         {
 579           fprintf (stderr, "%s: Unrecognized switch `%s'\n",
 580                    scm_usage_name, argv[i]);
 581           scm_shell_usage (1, 0);
 582         }
 583     }
 584
 585   /* Check to make sure the -ds got a -s. */
 586   if (do_script != SCM_EOL)
 587     scm_shell_usage (1, "the `-ds' switch requires the use of `-s' as well");
 588
 589   /* Make any remaining arguments available to the
 590      script/command/whatever.  */
 591   scm_set_program_arguments (argc - i, argv + i, argv0);
 592
 593   /* If the --emacs switch was set, now is when we process it.  */
 594   scm_sysintern ("use-emacs-interface",
 595                  (use_emacs_interface) ? SCM_BOOL_T : SCM_BOOL_F);
 596
 597   /* Handle the `-e' switch, if it was specified.  */
 598   if (entry_point != SCM_EOL)
 599     tail = scm_cons (scm_cons2 (entry_point,
 600                                 scm_cons (sym_command_line, SCM_EOL),
 601                                 SCM_EOL),
 602                        tail);
 603
 604   /* If we didn't end with a -c or a -s, load the user's customization
 605      file, and start the repl.  */
 606   if (interactive)
 607     {
 608       tail = scm_cons (scm_cons (sym_load_user_init, SCM_EOL), tail);
 609       tail = scm_cons (scm_cons (sym_top_repl, SCM_EOL), tail);
 610     }
 611   else
 612     {
 613       /* After doing all the other actions prescribed by the command line,
 614          quit.  */
 615       tail = scm_cons (scm_cons (sym_quit, SCM_EOL),
 616                    tail);
 617       /* Allow asyncs (signal handlers etc.) to be run.  */
 618       scm_mask_ints = 0;
 619     }
 620   {
 621     /* We want a path only containing directories from GUILE_LOAD_PATH,
 622        SCM_SITE_DIR and SCM_LIBRARY_DIR when searching for the site init
 623        file, so we do this before loading Ice-9.  */
 624     SCM init_path = scm_sys_search_load_path (scm_makfrom0str ("init.scm"));
 625
 626     /* Load Ice-9.  */
 627     if (!scm_ice_9_already_loaded)
 628       scm_primitive_load_path (scm_makfrom0str ("ice-9/boot-9.scm"));
 629
 630     /* Load the init.scm file.  */
 631     if (SCM_NFALSEP (init_path))
 632       scm_primitive_load (init_path);
 633   }
 634
 635   {
 636     SCM val = scm_cons (sym_begin, scm_reverse_x (tail, SCM_UNDEFINED));
 637
 638 #if 0
 639     scm_write (val, SCM_UNDEFINED);
 640     scm_newline (SCM_UNDEFINED);
 641 #endif
 642
 643     return val;
 644   }
 645 }
 646
 647
 648 void
 649 scm_shell (argc, argv)
 650      int argc;
 651      char **argv;
 652 {
 653   /* If present, add SCSH-style meta-arguments from the top of the
 654      script file to the argument vector.  See the SCSH manual: "The
 655      meta argument" for more details.  */
 656   {
 657     char **new_argv = scm_get_meta_args (argc, argv);
 658
 659     if (new_argv)
 660       {
 661         argv = new_argv;
 662         argc = scm_count_argv (new_argv);
 663       }
 664   }
 665
 666   exit (scm_exit_status (scm_eval_x (scm_compile_shell_switches (argc,argv))));
 667 }
 668
 669
 670 void
 671 scm_init_script ()
 672 {
 673 #include "script.x"
 674 }