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
  50 #include "script.h"
  51
  52 #ifdef HAVE_UNISTD_H
  53 #include <unistd.h>             /* for X_OK define */
  54 #endif
  55
  56 /* Concatentate str2 onto str1 at position n and return concatenated
  57    string if file exists; 0 otherwise. */
  58
  59 static char *
  60 scm_cat_path (str1, str2, n)
  61      char *str1;
  62      const char *str2;
  63      long n;
  64 {
  65   if (!n)
  66     n = strlen (str2);
  67   if (str1)
  68     {
  69       long len = strlen (str1);
  70       str1 = (char *) realloc (str1, (scm_sizet) (len + n + 1));
  71       if (!str1)
  72         return 0L;
  73       strncat (str1 + len, str2, n);
  74       return str1;
  75     }
  76   str1 = (char *) malloc ((scm_sizet) (n + 1));
  77   if (!str1)
  78     return 0L;
  79   str1[0] = 0;
  80   strncat (str1, str2, n);
  81   return str1;
  82 }
  83
  84 #if 0
  85 static char *
  86 scm_try_path (path)
  87      char *path;
  88 {
  89   FILE *f;
  90   /* fprintf(stderr, "Trying %s\n", path);fflush(stderr); */
  91   if (!path)
  92     return 0L;
  93   SCM_SYSCALL (f = fopen (path, "r");
  94     );
  95   if (f)
  96     {
  97       fclose (f);
  98       return path;
  99     }
 100   free (path);
 101   return 0L;
 102 }
 103
 104 static char *
 105 scm_sep_init_try (path, sep, initname)
 106      char *path;
 107      const char *sep, *initname;
 108 {
 109   if (path)
 110     path = scm_cat_path (path, sep, 0L);
 111   if (path)
 112     path = scm_cat_path (path, initname, 0L);
 113   return scm_try_path (path);
 114 }
 115 #endif
 116
 117 #ifndef LINE_INCREMENTORS
 118 #define LINE_INCREMENTORS  '\n'
 119 #ifdef MSDOS
 120 #define WHITE_SPACES  ' ':case '\t':case '\r':case '\f':case 26
 121 #else
 122 #define WHITE_SPACES  ' ':case '\t':case '\r':case '\f'
 123 #endif /* def MSDOS */
 124 #endif /* ndef LINE_INCREMENTORS */
 125
 126 #ifndef MAXPATHLEN
 127 #define MAXPATHLEN 80
 128 #endif /* ndef MAXPATHLEN */
 129 #ifndef X_OK
 130 #define X_OK 1
 131 #endif /* ndef X_OK */
 132
 133 #ifdef unix
 134 char *
 135 scm_find_executable (const char *name)
 136 {
 137   char tbuf[MAXPATHLEN];
 138   int i = 0;
 139   FILE *f;
 140
 141   /* fprintf(stderr, "s_f_e checking access %s ->%d\n", name, access(name, X_OK)); fflush(stderr); */
 142   if (access (name, X_OK))
 143     return 0L;
 144   f = fopen (name, "r");
 145   if (!f)
 146     return 0L;
 147   if ((fgetc (f) == '#') && (fgetc (f) == '!'))
 148     {
 149       while (1)
 150         switch (tbuf[i++] = fgetc (f))
 151           {
 152           case /*WHITE_SPACES */ ' ':
 153           case '\t':
 154           case '\r':
 155           case '\f':
 156           case EOF:
 157             tbuf[--i] = 0;
 158             fclose (f);
 159             return scm_cat_path (0L, tbuf, 0L);
 160           }
 161     }
 162   fclose (f);
 163   return scm_cat_path (0L, name, 0L);
 164 }
 165 #endif /* unix */
 166
 167 #ifdef MSDOS
 168
 169 #define DEFAULT_PATH "C:\\DOS"
 170 #define PATH_DELIMITER ';'
 171 #define ABSOLUTE_FILENAME_P(fname) ((fname[0] == '\\') \
 172                                      || (fname[0] && (fname[1] == ':')))
 173
 174 char *
 175 dld_find_executable (file)
 176      const char *file;
 177 {
 178   /* fprintf(stderr, "dld_find_executable %s -> %s\n", file, scm_cat_path(0L, file, 0L)); fflush(stderr); */
 179   return scm_cat_path (0L, file, 0L);
 180 }
 181 #endif /* def MSDOS */
 182
 183
 184 /* Read a \nnn-style escape.  We've just read the backslash.  */
 185 static int
 186 script_get_octal (f)
 187      FILE *f;
 188 {
 189   int i;
 190   int value = 0;
 191
 192   for (i = 0; i < 3; i++)
 193     {
 194       int c = getc (f);
 195       if ('0' <= c && c <= '7')
 196         value = (value * 8) + (c - '0');
 197       else
 198         scm_wta (SCM_UNDEFINED,
 199                  "malformed script: bad octal backslash escape",
 200                  "script argument parser");
 201     }
 202   return value;
 203 }
 204
 205
 206 static int
 207 script_get_backslash (f)
 208      FILE *f;
 209 {
 210   int c = getc (f);
 211
 212   switch (c)
 213     {
 214     case 'a': return '\a';
 215     case 'b': return '\b';
 216     case 'f': return '\f';
 217     case 'n': return '\n';
 218     case 'r': return '\r';
 219     case 't': return '\t';
 220     case 'v': return '\v';
 221
 222     case '\\':
 223     case ' ':
 224     case '\t':
 225     case '\n':
 226       return c;
 227
 228     case '0': case '1': case '2': case '3':
 229     case '4': case '5': case '6': case '7':
 230       ungetc (c, f);
 231       return script_get_octal (f);
 232
 233     case EOF:
 234       scm_wta (SCM_UNDEFINED,
 235                "malformed script: backslash followed by EOF",
 236                "script argument parser");
 237       return 0; /* not reached? */
 238
 239     default:
 240       scm_wta (SCM_UNDEFINED,
 241                "malformed script: bad backslash sequence",
 242                "script argument parser");
 243       return 0; /* not reached? */
 244     }
 245 }
 246
 247
 248 static char *
 249 script_read_arg (f)
 250      FILE *f;
 251 {
 252   int size = 7;
 253   char *buf = malloc (size + 1);
 254   int len = 0;
 255
 256   if (! buf)
 257     return 0;
 258
 259   for (;;)
 260     {
 261       int c = getc (f);
 262       switch (c)
 263         {
 264         case '\\':
 265           c = script_get_backslash (f);
 266           /* The above produces a new character to add to the argument.
 267              Fall through.  */
 268         default:
 269           if (len >= size)
 270             {
 271               size = (size + 1) * 2;
 272               buf = realloc (buf, size);
 273               if (! buf)
 274                 return 0;
 275             }
 276           buf[len++] = c;
 277           break;
 278
 279         case '\n':
 280           /* This may terminate an arg now, but it will terminate the
 281              entire list next time through.  */
 282           ungetc ('\n', f);
 283         case EOF:
 284           if (len == 0)
 285             {
 286               free (buf);
 287               return 0;
 288             }
 289           /* Otherwise, those characters terminate the argument; fall
 290              through.  */
 291         case ' ':
 292           buf[len] = '\0';
 293           return buf;
 294
 295         case '\t':
 296           free (buf);
 297           scm_wta (SCM_UNDEFINED,
 298                    "malformed script: TAB in meta-arguments",
 299                    "argument parser");
 300           return 0; /* not reached? */
 301         }
 302     }
 303 }
 304
 305
 306 static int
 307 script_meta_arg_P (arg)
 308      char *arg;
 309 {
 310   if ('\\' != arg[0])
 311     return 0L;
 312 #ifdef MSDOS
 313   return !arg[1];
 314 #else
 315   switch (arg[1])
 316     {
 317     case 0:
 318     case '%':
 319     case WHITE_SPACES:
 320       return !0;
 321     default:
 322       return 0L;
 323     }
 324 #endif
 325 }
 326
 327 char **
 328 scm_get_meta_args (argc, argv)
 329      int argc;
 330      char **argv;
 331 {
 332   int nargc = argc, argi = 1, nargi = 1;
 333   char *narg, **nargv;
 334   if (!(argc > 2 && script_meta_arg_P (argv[1])))
 335     return 0L;
 336   if (!(nargv = (char **) malloc ((1 + nargc) * sizeof (char *))))
 337       return 0L;
 338   nargv[0] = argv[0];
 339   while (((argi + 1) < argc) && (script_meta_arg_P (argv[argi])))
 340     {
 341       FILE *f = fopen (argv[++argi], "r");
 342       if (f)
 343         {
 344           nargc--;              /* to compensate for replacement of '\\' */
 345           while (1)
 346             switch (getc (f))
 347               {
 348               case EOF:
 349                 return 0L;
 350               default:
 351                 continue;
 352               case '\n':
 353                 goto found_args;
 354               }
 355         found_args:
 356           while ((narg = script_read_arg (f)))
 357             if (!(nargv = (char **) realloc (nargv,
 358                                              (1 + ++nargc) * sizeof (char *))))
 359                 return 0L;
 360             else
 361               nargv[nargi++] = narg;
 362           fclose (f);
 363           nargv[nargi++] = argv[argi++];
 364         }
 365     }
 366   while (argi <= argc)
 367     nargv[nargi++] = argv[argi++];
 368   return nargv;
 369 }
 370
 371 int
 372 scm_count_argv (argv)
 373      char **argv;
 374 {
 375   int argc = 0;
 376   while (argv[argc])
 377     argc++;
 378   return argc;
 379 }
 380
 381
 382 /* For use in error messages.  */
 383 char *scm_usage_name = 0;
 384
 385 void
 386 scm_shell_usage (int fatal, char *message)
 387 {
 388   if (message)
 389     fprintf (stderr, "%s\n", message);
 390
 391   fprintf (stderr,
 392            "Usage: %s OPTION ...\n"
 393            "Evaluate Scheme code, interactively or from a script.\n"
 394            "\n"
 395            "  -s SCRIPT      load Scheme source code from FILE, and exit\n"
 396            "  -c EXPR        evalute Scheme expression EXPR, and exit\n"
 397            "  --             stop scanning arguments; run interactively\n"
 398            "The above switches stop argument processing, and pass all\n"
 399            "remaining arguments as the value of (command-line).\n"
 400            "\n"
 401            "  -l FILE        load Scheme source code from FILE\n"
 402            "  -e FUNCTION    after reading script, apply FUNCTION to\n"
 403            "                 command line arguments\n"
 404            "  -ds            do -s script at this point\n"
 405            "  --emacs        enable Emacs protocol (experimental)\n"
 406            "  -h, --help     display this help and exit\n"
 407            "  -v, --version  display version information and exit\n"
 408            "  \\              read arguments from following script lines\n",
 409            scm_usage_name);
 410
 411   if (fatal)
 412     exit (fatal);
 413 }
 414
 415
 416 /* Some symbols used by the command-line compiler.  */
 417 SCM_SYMBOL (sym_load, "load");
 418 SCM_SYMBOL (sym_eval_string, "eval-string");
 419 SCM_SYMBOL (sym_command_line, "command-line");
 420 SCM_SYMBOL (sym_begin, "begin");
 421 SCM_SYMBOL (sym_load_user_init, "load-user-init");
 422 SCM_SYMBOL (sym_top_repl, "top-repl");
 423 SCM_SYMBOL (sym_quit, "quit");
 424
 425
 426 /* The boot code "ice-9/boot-9" is only loaded by
 427    SCM_COMPILE_SHELL_SWITCHES when this is false.  The unexec code
 428    uses this, to keep ice_9 from being loaded into dumped guile
 429    executables.  */
 430 int scm_ice_9_already_loaded = 0;
 431
 432 /* Given an array of command-line switches, return a Scheme expression
 433    to carry out the actions specified by the switches.
 434
 435    If you told me this should have been written in Scheme, I'd
 436    probably agree.  I'd say I didn't feel comfortable doing that in
 437    the present system.  You'd say, well, fix the system so you are
 438    comfortable doing that.  I'd agree again.  *shrug*
 439
 440    We load the ice-9 system from here.  It might be nicer if the
 441    libraries initialized from the inner_main function in guile.c (which
 442    will be auto-generated eventually) could assume ice-9 were already
 443    loaded.  Then again, it might be nice if ice-9 could assume that
 444    certain libraries were already loaded.  The solution is to break up
 445    ice-9 into modules which can be frozen and statically linked like any
 446    other module.  Then all the modules can describe their dependencies in
 447    the usual way, and the auto-generated inner_main will do the right
 448    thing. */
 449
 450 SCM
 451 scm_compile_shell_switches (int argc, char **argv)
 452 {
 453   SCM tail = SCM_EOL;           /* We accumulate the list backwards,
 454                                    and then reverse! it before we
 455                                    return it.  */
 456   SCM do_script = SCM_EOL;      /* The element of the list containing
 457                                    the "load" command, in case we get
 458                                    the "-ds" switch.  */
 459   SCM entry_point = SCM_EOL;    /* for -e switch */
 460   int interactive = 1;          /* Should we go interactive when done? */
 461   int use_emacs_interface = 0;
 462   int i;
 463   char *argv0;
 464
 465   if (argc > 0)
 466     {
 467       scm_usage_name = strrchr (argv[0], '/');
 468       if (! scm_usage_name)
 469         scm_usage_name = argv[0];
 470       else
 471         scm_usage_name++;
 472     }
 473   if (! scm_usage_name)
 474     scm_usage_name = "guile";
 475   argv0 = scm_usage_name;
 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 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                   GUILE_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     }
 618   {
 619     /* We want a path only containing directories from SCHEME_LOAD_PATH,
 620        SCM_SITE_DIR and SCM_LIBRARY_DIR when searching for the site init
 621        file, so we do this before loading Ice-9.  */
 622     SCM init_path = scm_sys_search_load_path (scm_makfrom0str ("init.scm"));
 623
 624     /* Load Ice-9.  */
 625     if (!scm_ice_9_already_loaded)
 626       scm_primitive_load_path (scm_makfrom0str ("ice-9/boot-9.scm"));
 627
 628     /* Load the init.scm file.  */
 629     if (SCM_NFALSEP (init_path))
 630       scm_primitive_load (init_path);
 631   }
 632
 633   {
 634     SCM val = scm_cons (sym_begin, scm_list_reverse_x (tail, SCM_UNDEFINED));
 635
 636 #if 0
 637     scm_write (val, SCM_UNDEFINED);
 638     scm_newline (SCM_UNDEFINED);
 639 #endif
 640
 641     return val;
 642   }
 643 }
 644
 645
 646 void
 647 scm_shell (argc, argv)
 648      int argc;
 649      char **argv;
 650 {
 651   /* If present, add SCSH-style meta-arguments from the top of the
 652      script file to the argument vector.  See the SCSH manual: "The
 653      meta argument" for more details.  */
 654   {
 655     char **new_argv = scm_get_meta_args (argc, argv);
 656
 657     if (new_argv)
 658       {
 659         argv = new_argv;
 660         argc = scm_count_argv (new_argv);
 661       }
 662   }
 663
 664   exit (scm_exit_status (scm_eval_x (scm_compile_shell_switches (argc,argv))));
 665 }
 666
 667
 668 void
 669 scm_init_script ()
 670 {
 671 #include "script.x"
 672 }