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