/* Copyright 2009-2021
* Kaz Kylheku <kaz@kylheku.com>
* Vancouver, Canada
* All rights reserved.
*
* Redistribution and use in source and binary forms, with or without
* modification, are permitted provided that the following conditions are met:
*
* 1. Redistributions of source code must retain the above copyright notice, this
* list of conditions and the following disclaimer.
*
* 2. Redistributions in binary form must reproduce the above copyright notice,
* this list of conditions and the following disclaimer in the documentation
* and/or other materials provided with the distribution.
*
* THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
* ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
* WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
* DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
* FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
* DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
* SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
* CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
* OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
* OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
*/
#include <stdio.h>
#include <stdlib.h>
#include <limits.h>
#include <stdarg.h>
#include <wchar.h>
#include <signal.h>
#include "config.h"
#if HAVE_UNISTD_H
#include <unistd.h>
#endif
#if HAVE_WINDOWS_H
#include <windows.h>
#undef TEXT
#endif
#if __APPLE__
#include <mach-o/dyld.h>
#endif
#include "lib.h"
#include "stream.h"
#include "gc.h"
#include "signal.h"
#include "unwind.h"
#include "y.tab.h"
#include "parser.h"
#include "match.h"
#include "utf8.h"
#include "debug.h"
#include "eval.h"
#include "regex.h"
#include "arith.h"
#include "sysif.h"
#if HAVE_GLOB
#include "glob.h"
#endif
#include "txr.h"
const wchli_t *version = wli(TXR_VER);
#ifdef TXR_BUILD_ID
const wchli_t *build_id = wli(TXR_BUILD_ID);
#endif
wchar_t *progname;
static const char *progname_u8;
static val prog_path = nil, sysroot_path = nil;
int opt_noninteractive;
int opt_noprofile;
int opt_compat;
int opt_dbg_expansion;
val stdlib_path;
static void help(void)
{
val text = lit(
"\n"
"TXR Version ~a\n"
"Copyright 2009-2021 Kaz Kylheku <kaz@kylheku.com>\n"
"\n"
"Usage:\n"
"\n"
" ~a [ options ] script-file { argument }*\n"
"\n"
#if HAVE_TERMIOS
"If no arguments are present, TXR will enter into interactive listener mode.\n"
"\n"
#endif
"The script-file or data-file arguments may be specified as -, in which case\n"
"standard input is used. All data-file arguments which begin with a !\n"
"character are treated as command pipes. Those which begin with a $\n"
"are interpreted as directories to read. Leading arguments which begin\n"
"with a - followed by one or more characters, and which are not arguments to\n"
"options are interpreted as options. The -- option indicates the end of the\n"
"options.\n"
"\n"
"If no data-file arguments are supplied, then the query itself must open a\n"
"a data source prior to attempting to make any pattern match, or it will\n"
"simply fail due to a match which has run out of data.\n"
"\n"
"options:\n"
"\n"
"-Dvar=value Pre-define variable var, with the given value.\n"
" A list value can be specified using commas.\n"
"-Dvar Predefine variable var, with empty string value.\n"
"-q Quiet: don't report errors during query matching.\n"
"-v Verbose: extra logging from matcher.\n"
"-B Force list of bindings to be dumped, or false\n"
" if termination is unsuccessful.\n"
"-l If dumping bindings, use TXR Lisp format.\n"
"-i Interactive TXR Lisp listener mode.\n"
" (Requires compiled-in support.)\n"
"-d Enable debugger. Implies --backtrace.\n"
"-n Noninteractive input mode for standard input stream,\n"
" even if its connected to a terminal device.\n"
" Also, forces the interactive listener into\n"
" 'plain mode' without editing features.\n"
"-a N Generate array variables up to N dimensions.\n"
" N is a decimal integer. The default value is 1.\n"
" Additional dimensions beyond N are fudged\n"
" by generating numeric suffixes. Implies -B.\n"
"-c query-text The query is read from the query-text argument\n"
" itself. The script-file argument is omitted in\n"
" this case; the first argument is a data file.\n"
"-f script-file Specify the script-file as an option argument\n"
" instead of as the script-file argument.\n"
" This allows #! scripts to pass options through\n"
" to the txr utility.\n"
"-e expression Evaluate TXR Lisp expression. Can be specified\n"
" multiple times. The script-file arg becomes optional.\n"
"-p expression Like -e, but prints the result of the expression\n"
" using the prinl function.\n"
"-P expression Like -p, but prints using pprinl.\n"
"-t expression Like -p, but prints using tprint.\n"
"-b var=value Bind a Lisp global variable as if by defparml.\n"
" var and value are parsed as Lisp syntax.\n"
" value is not evaluated.\n"
"-C N Request backward-compatible behavior to the\n"
" specified version of TXR.\n"
"--help Reproduce this help text.\n"
"--version Display program version.\n"
"--build-id Print build ID string if compiled in.\n"
"--license Display software license.\n"
" Use of txr implies agreement with the disclaimer\n"
" section at the bottom of the license.\n"
"--lisp Treat unsuffixed query files as TXR Lisp.\n"
"--compiled Treat unsuffixed query files as compiled TXR Lisp.\n"
"--lisp-bindings Synonym for -l.\n"
"--debugger Synonym for -d.\n"
"--backtrace Enable backtraces.\n"
"--noninteractive Synonym for -n.\n"
"--compat=N Synonym for -C N.\n"
"--gc-delta=N Invoke garbage collection when malloc activity\n"
" increments by N megabytes since last collection.\n"
"--args... Allows multiple arguments to be encoded as a single\n"
" argument. This is useful in hash-bang scripts.\n"
" Peculiar syntax. See the manual.\n"
"--eargs... arg Extended version of --args: additionally consumes\n"
" the following argument arg and allows one or more\n"
" copies of it to be to be embedded in the\n"
" encoded arguments. See the manual.\n"
"--noprofile Do not read .txr_profile when entering listener.\n"
#if HAVE_FORK_STUFF
"--reexec Re-execute TXR with remaining arguments.\n"
#endif
"--debug-autoload Allow debugger to step through library auto-loading.\n"
"--debug-expansion Allow debugger to step through macro-expansion of query.\n"
"--yydebug Debug Yacc parser, if compiled with YYDEBUG support.\n"
"--gc-debug Enable a garbage collector stress test (slow).\n"
"--vg-debug Enable Valgrind integration, if compiled in.\n"
"--dv-regex Handle all regexes using derivative-based back-end.\n"
"\n"
"Options that take no argument can be combined. The -q and -v options\n"
"are mutually exclusive; the right-most one dominates.\n"
"\n"
);
format(std_output, text, static_str(version), prog_string, nao);
}
#if HAVE_TERMIOS
static void banner(void)
{
format(std_output,
if3(opt_noninteractive,
lit("This is the TXR Lisp plain mode listener of TXR ~a.\n"
"Quit with :quit or Ctrl-D on an empty line.\n"),
lit("This is the TXR Lisp interactive listener of TXR ~a.\n"
"Quit with :quit or Ctrl-D on an empty line. "
"Ctrl-X ? for cheatsheet.\n")),
static_str(version), nao);
}
#else
static void hint(void)
{
format(std_error, lit("~a: incorrect arguments: try --help\n"),
prog_string, nao);
}
#endif
static val check_hash_bang(val stream, val args, int *occurs)
{
val line = get_line(stream);
if (line) {
if (match_str(line, lit("#!"), nil)) {
val pos = search_str(line, lit("\xdc00"), nil, nil);
*occurs = 1;
if (pos) {
val after_null = sub_str(line, succ(pos), t);
val prepend_args = split_str(after_null, lit(" "));
args = nappend2(prepend_args, args);
}
} else {
seek_stream(stream, zero, from_start_k);
}
}
return args;
}
#if __linux__
static val get_self_path(void)
{
char self[PATH_MAX] = { 0 };
int nchar = readlink("/proc/self/exe", self, sizeof self);
if (nchar < 0 || nchar >= convert(int, sizeof self))
return nil;
return string_utf8(self);
}
#elif HAVE_WINDOWS_H
static val get_self_path(void)
{
wchar_t self[MAX_PATH] = { 0 };
DWORD nchar;
SetLastError(0);
nchar = GetModuleFileNameW(NULL, self, MAX_PATH);
if (nchar == 0 ||
(nchar == MAX_PATH &&
((GetLastError() == ERROR_INSUFFICIENT_BUFFER) ||
(self[MAX_PATH - 1] != 0))))
return nil;
return string(self);
}
#elif __APPLE__
static val get_self_path(void)
{
char self[PATH_MAX] = { 0 };
uint32_t size = sizeof self;
if (_NSGetExecutablePath(self, &size) != 0)
return nil;
return string_utf8(self);
}
#elif HAVE_GETEXECNAME
static val get_self_path(void)
{
val execname = string_utf8(getexecname());
if (car(execname) == chr('/'))
return execname;
return scat3(getcwd_wrap(), chr('/'), execname);
}
#else
static val get_self_path(void)
{
char self[PATH_MAX];
if (progname_u8 && realpath(progname_u8, self))
return string_utf8(self);
return lit(TXR_INST_PATH);
}
#endif
static val maybe_sysroot(val exepart)
{
return if2(match_str(prog_path, exepart, negone),
sysroot_path = sub_str(prog_path, 0, neg(length(exepart))));
}
static val substitute_basename(val edited_path, val source_path)
{
val lslash = rpos(chr('/'), edited_path, nil, nil);
val rslash = rpos(chr('/'), source_path, nil, nil);
val basename = if3(rslash,
sub_str(source_path, succ(rslash), t),
source_path);
return if3(lslash,
scat2(sub_str(edited_path, 0, succ(lslash)), basename),
basename);
}
static val sysroot(val target)
{
return scat2(sysroot_path, target);
}
static void sysroot_init(void)
{
val prog_dir;
const wchar_t *psc = coerce(const wchar_t *, path_sep_chars);
int share_txr_stdlib = 1;
#if HAVE_WINDOWS_H
val slash = regex_compile(lit("\\\\"), nil);
#endif
protect(&prog_path, &sysroot_path, &stdlib_path, convert(val *, 0));
prog_path = get_self_path();
#if HAVE_WINDOWS_H
prog_path = regsub(slash, lit("/"), prog_path);
#endif
prog_dir = dir_name(prog_path);
if (ref(prog_dir, negone) != chr(psc[0]))
prog_dir = scat3(prog_dir, chr(psc[0]), lit(""));
if (!(maybe_sysroot(lit(TXR_REL_PATH)) ||
maybe_sysroot(lit(TXR_REL_PATH EXE_SUFF)) ||
maybe_sysroot(substitute_basename(lit(TXR_REL_PATH), prog_path)) ||
(share_txr_stdlib = 0) ||
maybe_sysroot(lit(PROG_NAME)) ||
maybe_sysroot(lit(PROG_NAME EXE_SUFF))))
{
sysroot_path = prog_dir;
}
stdlib_path = sysroot(if3(share_txr_stdlib,
lit("share/txr/stdlib/"),
lit("stdlib/")));
reg_varl(intern(lit("stdlib"), user_package), stdlib_path);
reg_varl(intern(lit("*txr-version*"), user_package),
toint(lit(TXR_VER), nil));
reg_varl(intern(lit("txr-version"), user_package),
toint(lit(TXR_VER), nil));
reg_varl(intern(lit("txr-path"), user_package), prog_dir);
reg_varl(intern(lit("txr-exe-path"), user_package), prog_path);
}
static void sysroot_compat_fixup(int compat_ver)
{
if (compat_ver <= 143)
reg_varl(intern(lit("stdlib"), user_package),
sysroot(lit("share/txr/stdlib")));
}
static int license(void)
{
int retval = EXIT_SUCCESS;
uw_catch_begin(cons(error_s, nil), esym, eargs);
{
val iter;
#if HAVE_GLOB
val glob_pattern = sysroot(lit("share/txr/LICENSE*"));
val path_list = glob_wrap(glob_pattern, zero, nil);
#else
val glob_pattern = sysroot(lit("share/txr/LICENSE"));
val path_list = cons(glob_pattern, nil);
#endif
if (!path_list)
uw_throwf(error_s, lit("pattern ~a didn't match any files."),
glob_pattern, nao);
put_char(chr('\n'), std_output);
for (iter = path_list; iter; iter = cdr(iter)) {
val lic = open_file(car(iter), lit("r"));
put_lines(lazy_stream_cons(lic), std_output);
put_char(chr('\n'), std_output);
}
}
uw_catch (esym, eargs) {
format(std_output,
lit("~a: unable to display license file: ~a\n"),
prog_string, car(eargs), nao);
retval = EXIT_FAILURE;
}
uw_unwind { }
uw_catch_end;
return retval;
}
int txr_main(int argc, char **argv);
int main(int argc, char **argv)
{
val stack_bottom = nil;
repress_privilege();
progname = utf8_dup_from(argv[0] ? argv[0]: "txr");
progname_u8 = argv[0];
init(&stack_bottom);
match_init();
debug_init();
sysroot_init();
return txr_main(argc, argv);
}
static void requires_arg(val opt)
{
format(std_error, lit("~a: option --~a requires an argument\n"),
prog_string, opt, nao);
}
static int do_fixnum_opt(int (*opt_func)(val), val opt, val arg)
{
if (arg) {
val optval = int_str(arg, nil);
if (!optval || !fixnump(optval)) {
format(std_error, lit("~a: option -~a needs a small integer "
"argument, not ~a\n"), prog_string, opt,
arg, nao);
return 0;
}
return opt_func(optval);
}
requires_arg(opt);
return 0;
}
static int compat(val optval)
{
int compat = c_num(optval, lit("txr"));
int min = compat_fixup(compat);
if (min) {
format(std_error, lit("~a: compatibility with versions "
"lower than ~a not supported by version ~a\n"),
prog_string, num(min), static_str(version), nao);
return 0;
}
sysroot_compat_fixup(compat);
opt_compat = compat;
reg_varl(intern(lit("compat"), system_package), num(compat));
return 1;
}
static int array_dim(val optval)
{
opt_arraydims = c_num(optval, lit("txr"));
opt_print_bindings = 1;
return 1;
}
static int gc_delta(val optval)
{
opt_gc_delta = c_num(mul(optval, num_fast(1048576)), lit("gc"));
return 1;
}
static void free_all(void)
{
static int called;
if (!called) {
called = 1;
regex_free_all();
gc_free_all();
arith_free_all();
free(progname);
}
}
#ifndef CONFIG_DEBUG_SUPPORT
static void no_dbg_support(val arg)
{
drop_privilege();
format(std_error,
lit("~a: option ~a requires debug support compiled in\n"),
prog_string, arg, nao);
}
#endif
static int parse_once_noerr(val stream, val name)
{
val pfx = scat2(name, lit(":"));
ignerr_func_body(int, 0, parse_once(prog_string, stream, name),
std_error, pfx);
}
static val read_compiled_file_noerr(val self, val stream, val name, val error_stream)
{
val pfx = scat2(name, lit(":"));
ignerr_func_body(val, nil, read_compiled_file(self, stream, error_stream),
std_error, pfx);
}
static val read_eval_stream_noerr(val self, val stream, val name, val error_stream)
{
val pfx = scat2(name, lit(":"));
ignerr_func_body(val, nil, read_eval_stream(self, stream, error_stream),
std_error, pfx);
}
int txr_main(int argc, char **argv)
{
val self = lit("txr startup");
uses_or2;
val specstring = nil;
val spec = nil;
val spec_file = nil;
val bindings = nil;
val evaled = nil;
val spec_file_str;
int match_loglevel = opt_loglevel;
val arg_undo = nil, arg;
val parse_stream = nil;
val txr_lisp_p = nil;
val enter_repl = nil;
val args_s = intern(lit("*args*"), user_package);
val self_path_s = intern(lit("self-path"), user_package);
val compat_var = lit("TXR_COMPAT");
val compat_val = getenv_wrap(compat_var);
val orig_args = nil, ref_arg_list = nil;
int hb_occurs = 0;
list_collect_decl(arg_list, arg_tail);
list_collect_decl(eff_arg_list, eff_arg_tail);
static char alt_args_buf[128 + 7] = "@(txr):", *alt_args = alt_args_buf + 7;
setvbuf(stderr, 0, _IOLBF, 0);
if (compat_val && length(compat_val) != zero) {
val value = int_str(compat_val, nil);
if (!value) {
format(std_error,
lit("~a: environment variable ~a=~a must be decimal integer\n"),
prog_string, compat_var, compat_val, nao);
return EXIT_FAILURE;
}
if (!compat(value)) {
format(std_error, lit("~a: caused by environment variable ~a=~a\n"),
prog_string, compat_var, compat_val, nao);
return EXIT_FAILURE;
}
}
while (*argv)
arg_tail = list_collect(arg_tail, string_utf8(*argv++));
reg_varl(intern(lit("compat"), system_package), zero);
reg_var(intern(lit("*full-args*"), user_package), arg_list);
reg_var(intern(lit("*args-full*"), user_package), arg_list);
reg_var(intern(lit("*args-eff*"), user_package), eff_arg_list);
if (arg_list) {
eff_arg_tail = list_collect(eff_arg_tail, car(arg_list));
arg_list = cdr(arg_list);
}
if (*alt_args) {
orig_args = arg_list;
arg_list = list(string_utf8(alt_args), nao);
} else if (argc <= 1) {
drop_privilege();
#if HAVE_TERMIOS
banner();
goto repl;
#else
hint();
return EXIT_FAILURE;
#endif
}
for (ref_arg_list = arg_list, arg = upop(&arg_list, &arg_undo);
arg;
arg = upop(&arg_list, &arg_undo))
{
eff_arg_tail = list_collect(eff_arg_tail, arg);
if (equal(arg, lit("--")))
break;
if (car(arg) != chr('-')) {
if (!parse_stream) {
spec_file_str = arg;
open_txr_file(arg, &txr_lisp_p, &spec_file_str, &parse_stream, self);
simulate_setuid_setgid(parse_stream);
dyn_env = make_env(nil, nil, dyn_env);
env_vbind(dyn_env, load_path_s, spec_file_str);
arg_list = check_hash_bang(parse_stream, arg_undo, &hb_occurs);
set(eff_arg_tail, butlastn(one, deref(eff_arg_tail)));
continue;
}
break;
}
if (equal(arg, lit("-")))
break;
/* Odd case 1: --args is followed by an arbitrary delimiting
* character, not necessarily = */
if (match_str(arg, lit("--args"), zero)) {
val sep = sub_str(arg, num(6), num(7));
if (empty(sep)) {
format(std_error,
lit("~a: --args requires argument material\n"),
prog_string, nao);
return EXIT_FAILURE;
}
arg = sub_str(arg, num(7), nil);
arg_list = append2(split_str(arg, sep), arg_list);
set(eff_arg_tail, butlastn(one, deref(eff_arg_tail)));
continue;
}
/* Odd case 2: --eargs is followed by an arbitrary delimiting
* character, not necessarily = */
if (match_str(arg, lit("--eargs"), zero)) {
val sep = sub_str(arg, num(7), num(8));
val arg2;
if (empty(sep)) {
format(std_error,
lit("~a: --eargs requires argument material\n"),
prog_string, nao);
return EXIT_FAILURE;
}
if (!arg_list) {
format(std_error,
lit("~a: --eargs must be followed by an argument\n"),
prog_string, nao);
return EXIT_FAILURE;
}
arg = sub_str(arg, num(8), nil);
arg2 = upop(&arg_list, &arg_undo);
arg_list = append2(mapcar(iffi(pa_12_2(equal_f, lit("{}")),
retf(arg2), nil),
split_str(arg, sep)),
arg_list);
set(eff_arg_tail, butlastn(one, deref(eff_arg_tail)));
continue;
}
/* Odd case 3: -Dfoo=bar syntax. */
if (equal(sub(arg, zero, two), lit("-D"))) {
val dopt_arg = sub(arg, two, t);
cons_bind(var, def, split_str(dopt_arg, lit("=")));
val deflist = if2(def, split_str(car(def), lit(",")));
val sym = intern(var, cur_package);
if (rest(deflist))
bindings = cons(cons(sym, deflist), bindings);
else if (deflist)
bindings = cons(cons(sym, car(deflist)), bindings);
else
bindings = cons(cons(sym, t), bindings);
match_reg_var(sym);
continue;
}
/* Regular long opts */
if (match_str(arg, lit("--"), zero)) {
val no_dashes = sub(arg, two, t);
val pair = partition_star(no_dashes, pos(chr('='), no_dashes, nil, nil));
val opt = pop(&pair);
val org = pop(&pair);
/* Long opts with arguments */
if (equal(opt, lit("gc-delta"))) {
if (!do_fixnum_opt(gc_delta, opt, arg))
return EXIT_FAILURE;
continue;
}
if (equal(opt, lit("compat"))) {
if (!do_fixnum_opt(compat, opt, org))
return EXIT_FAILURE;
continue;
}
/* Long opts with no arguments */
if (0) noarg: {
drop_privilege();
format(std_error,
lit("~a: option --~a takes no argument, ~a given\n"),
prog_string, opt, org, nao);
return EXIT_FAILURE;
}
if (equal(opt, lit("version"))) {
if (org)
goto noarg;
drop_privilege();
format(std_output, lit("~a: version ~a\n"),
prog_string, static_str(version), nao);
return 0;
}
if (equal(opt, lit("build-id"))) {
if (org)
goto noarg;
drop_privilege();
#ifdef TXR_BUILD_ID
format(std_output, lit("~a\n"), static_str(build_id), nao);
#endif
return 0;
}
if (equal(opt, lit("help"))) {
drop_privilege();
help();
return 0;
}
if (equal(opt, lit("license"))) {
if (org)
goto noarg;
drop_privilege();
return license();
}
if (equal(opt, lit("gc-debug"))) {
if (org)
goto noarg;
drop_privilege();
opt_gc_debug = 1;
continue;
} else if (equal(opt, lit("vg-debug"))) {
#if HAVE_VALGRIND
if (org)
goto noarg;
drop_privilege();
opt_vg_debug = 1;
continue;
#else
drop_privilege();
format(std_error,
lit("~a: option ~a requires Valgrind support compiled in\n"),
prog_string, arg, nao);
return EXIT_FAILURE;
#endif
} else if (equal(opt, lit("dv-regex"))) {
if (org)
goto noarg;
opt_derivative_regex = 1;
continue;
} else if (equal(opt, lit("lisp-bindings"))) {
if (org)
goto noarg;
opt_lisp_bindings = 1;
opt_print_bindings = 1;
continue;
} else if (equal(opt, lit("lisp"))) {
if (org)
goto noarg;
txr_lisp_p = t;
continue;
} else if (equal(opt, lit("compiled"))) {
if (org)
goto noarg;
txr_lisp_p = chr('o');
continue;
#if HAVE_FORK_STUFF
} else if (equal(opt, lit("reexec"))) {
if (org)
goto noarg;
exec_wrap(prog_path, arg_list);
return EXIT_FAILURE;
#endif
} else if (equal(opt, lit("debugger"))) {
#if CONFIG_DEBUG_SUPPORT
if (org)
goto noarg;
drop_privilege();
opt_debugger = 1;
debug_set(DBG_ENABLE | DBG_BACKTRACE);
continue;
#else
no_dbg_support(arg);
return EXIT_FAILURE;
#endif
} else if (equal(opt, lit("debug-autoload"))) {
#if CONFIG_DEBUG_SUPPORT
if (org)
goto noarg;
drop_privilege();
opt_debugger = 1;
opt_dbg_autoload = 1;
debug_set(DBG_ENABLE | DBG_BACKTRACE);
continue;
#else
no_dbg_support(opt);
return EXIT_FAILURE;
#endif
} else if (equal(opt, lit("debug-expansion"))) {
#if CONFIG_DEBUG_SUPPORT
if (org)
goto noarg;
drop_privilege();
opt_debugger = 1;
opt_dbg_expansion = 1;
debug_set(DBG_ENABLE | DBG_BACKTRACE);
continue;
#else
no_dbg_support(opt);
return EXIT_FAILURE;
#endif
} else if (equal(opt, lit("yydebug"))) {
if (org)
goto noarg;
drop_privilege();
if (have_yydebug) {
yydebug_onoff(1);
format(std_error,
lit("~a: option --~a takes no argument, ~a given\n"),
prog_string, opt, org, nao);
continue;
} else {
drop_privilege();
format(std_error,
lit("~a: option ~a requires YYDEBUG support compiled in\n"),
prog_string, arg, nao);
return EXIT_FAILURE;
}
} else if (equal(opt, lit("backtrace"))) {
if (org)
goto noarg;
#if CONFIG_DEBUG_SUPPORT
debug_set(DBG_BACKTRACE);
continue;
#else
no_dbg_support(arg);
return EXIT_FAILURE;
#endif
} else if (equal(opt, lit("noninteractive"))) {
if (org)
goto noarg;
opt_noninteractive = 1;
stream_set_prop(std_input, real_time_k, nil);
continue;
} else if (equal(opt, lit("free-all"))) {
if (org)
goto noarg;
atexit(free_all);
continue;
} else if (equal(opt, lit("noprofile"))) {
if (org)
goto noarg;
opt_noprofile = 1;
continue;
} else {
drop_privilege();
format(std_error, lit("~a: unrecognized long option: --~a\n"),
prog_string, opt, nao);
return EXIT_FAILURE;
}
}
/* Single letter options with args: non-clumping. */
if (length(arg) == two && find(ref(arg, one), lit("abcfepPtC"), nil, nil))
{
val opt = chr_str(arg, one);
if (!arg_list) {
drop_privilege();
requires_arg(opt);
return EXIT_FAILURE;
}
arg = upop(&arg_list, &arg_undo);
eff_arg_tail = list_collect(eff_arg_tail, arg);
switch (c_chr(opt)) {
case 'a':
if (!do_fixnum_opt(array_dim, opt, arg))
return EXIT_FAILURE;
break;
case 'C':
if (!do_fixnum_opt(compat, opt, arg))
return EXIT_FAILURE;
break;
case 'b':
drop_privilege();
{
val pair = split_str(arg, chr('='));
if (cdr(pair)) {
val sym = lisp_parse(pop(&pair), std_error,
colon_k, lit("cmdline-expr"), colon_k);
val obj = lisp_parse(pop(&pair), std_error,
colon_k, lit("cmdline-expr"), colon_k);
if (!bindable(sym)) {
format(std_error,
lit("~a: ~s isn't a bindable symbol\n"),
prog_string, sym, nao);
return EXIT_FAILURE;
}
reg_var(sym, obj);
} else {
format(std_error,
lit("~a: -b argument must be var=val syntax\n"),
prog_string, nao);
return EXIT_FAILURE;
}
}
break;
case 'c':
if (txr_lisp_p) {
format(std_error,
lit("~a: -c not compatible with --lisp or --compiled; use -e\n"),
prog_string, nao);
return EXIT_FAILURE;
}
if (parse_stream) {
format(std_error,
lit("~a: -c ~a: input source ~a has already been established\n"),
prog_string, arg, spec_file_str, nao);
return EXIT_FAILURE;
}
specstring = arg;
drop_privilege();
spec_file_str = lit("cmdline");
if (gt(length_str(specstring), zero) &&
chr_str(specstring, minus(length_str(specstring), one)) != chr('\n'))
specstring = cat_str(list(specstring, string(L"\n"), nao), nil);
parse_stream = make_string_byte_input_stream(specstring);
break;
case 'f':
spec_file = arg;
if (parse_stream) {
if (equal(spec_file, spec_file_str))
break;
format(std_error,
lit("~a: -f ~a: input source ~a has already been established\n"),
prog_string, arg, spec_file_str, nao);
return EXIT_FAILURE;
}
if (wcscmp(c_str(spec_file, self), L"-") != 0) {
open_txr_file(spec_file, &txr_lisp_p, &spec_file_str,
&parse_stream, self);
simulate_setuid_setgid(parse_stream);
dyn_env = make_env(nil, nil, dyn_env);
env_vbind(dyn_env, load_path_s, spec_file_str);
arg_list = check_hash_bang(parse_stream, arg_list, &hb_occurs);
} else {
drop_privilege();
spec_file_str = lit("stdin");
parse_stream = std_input;
}
break;
case 'e':
drop_privilege();
{
val args_saved = or2(orig_args, arg_list);
val args_new;
reg_varl(self_path_s, lit("cmdline-expr"));
reg_var(args_s, or2(orig_args, arg_list));
eval_intrinsic(lisp_parse(arg, std_error, colon_k,
lit("cmdline-expr"), colon_k),
make_env(bindings, nil, nil));
evaled = t;
args_new = cdr(lookup_global_var(args_s));
if (args_new != args_saved) {
arg_list = args_new;
orig_args = nil;
}
}
break;
case 'p':
case 'P':
case 't':
drop_privilege();
{
val (*pf)(val obj, val out) = if3(c_chr(opt) == 'p',
prinl,
if3(c_chr(opt) == 'P',
pprinl,
tprint));
val args_saved = or2(orig_args, arg_list);
val args_new;
val obj;
reg_varl(self_path_s, lit("cmdline-expr"));
reg_var(args_s, or2(orig_args, arg_list));
obj = eval_intrinsic(lisp_parse(arg, std_error, colon_k,
lit("cmdline-expr"), colon_k),
make_env(bindings, nil, nil));
gc_hint(obj);
pf(z(obj), std_output);
evaled = t;
args_new = cdr(lookup_global_var(args_s));
if (args_new != args_saved) {
arg_list = args_new;
orig_args = nil;
}
}
break;
}
continue;
}
/* Clumping single-letter options. */
{
val optchars = cdr(arg);
for (; optchars != nil; optchars = cdr(optchars)) {
val opch = car(optchars);
switch (c_chr(opch)) {
case 'v':
match_loglevel = 2;
break;
case 'q':
match_loglevel = 0;
break;
case 'B':
opt_print_bindings = 1;
break;
case 'l':
opt_lisp_bindings = 1;
opt_print_bindings = 1;
break;
case 'i':
drop_privilege();
#if HAVE_TERMIOS
enter_repl = t;
break;
#else
format(std_error,
lit("~a: option ~a requires a platform with termios\n"),
prog_string, arg, nao);
return EXIT_FAILURE;
#endif
case 'd':
drop_privilege();
#if CONFIG_DEBUG_SUPPORT
opt_debugger = 1;
debug_set(DBG_ENABLE | DBG_BACKTRACE);
#else
no_dbg_support(opch);
return EXIT_FAILURE;
#endif
break;
case 'n':
opt_noninteractive = 1;
stream_set_prop(std_input, real_time_k, nil);
break;
case 'a':
case 'b':
case 'c':
case 'e':
case 'p':
case 'P':
case 'f':
case 'C':
case 't':
case 'D':
drop_privilege();
format(std_error, lit("~a: option -~a does not clump\n"),
prog_string, opch, nao);
return EXIT_FAILURE;
case '-':
drop_privilege();
format(std_error, lit("~a: dash in the middle of options: ~a\n"),
prog_string, arg, nao);
return EXIT_FAILURE;
default:
drop_privilege();
format(std_error, lit("~a: unrecognized option: -~a\n"),
prog_string, opch, nao);
return EXIT_FAILURE;
}
}
}
}
eff_arg_tail = list_collect_nconc(eff_arg_tail, arg_list);
if (!equal(cdr(eff_arg_list), ref_arg_list))
reg_var(intern(lit("*args-eff*"), user_package), eff_arg_list);
if (!parse_stream) {
if (!arg) {
drop_privilege();
if (enter_repl)
goto repl;
if (evaled)
return EXIT_SUCCESS;
#if HAVE_TERMIOS
banner();
goto repl;
#else
hint();
return EXIT_FAILURE;
#endif
}
drop_privilege();
spec_file_str = lit("stdin");
parse_stream = std_input;
} else if (specstring || spec_file) {
arg_list = arg_undo;
}
reg_var(args_s, or2(orig_args, arg_list));
reg_varl(self_path_s, spec_file_str);
env_vbind(dyn_env, load_recursive_s, t);
if (hb_occurs)
parser_set_lineno(prog_string, parse_stream, two);
if (!txr_lisp_p)
{
int gc = gc_state(0);
val parser_obj = ensure_parser(parse_stream, spec_file_str);
parser_t *parser = parser_get_impl(prog_string, parser_obj);
parse_once_noerr(parse_stream, spec_file_str);
mut(parser_obj)
gc_state(gc);
close_stream(parse_stream, nil);
uw_release_deferred_warnings();
spec = parser->syntax_tree;
opt_loglevel = match_loglevel;
if (opt_compat && opt_compat <= 199)
reg_var(intern(lit("*self-path*"), user_package), spec_file_str);
if (parser->errors) {
if (enter_repl)
goto repl;
return EXIT_FAILURE;
}
if (opt_loglevel >= 2) {
format(std_error, lit("spec:\n~s\n"), spec, nao);
format(std_error, lit("bindings:\n~s\n"), bindings, nao);
}
{
val result = extract(spec, arg_list, bindings);
cons_bind (new_bindings, success, result);
if (enter_repl) {
bindings = new_bindings;
goto repl;
}
return success ? 0 : EXIT_FAILURE;
}
}
for (; bindings; bindings = cdr(bindings)) {
val binding = car(bindings);
reg_varl(car(binding), cdr(binding));
}
if (txr_lisp_p == chr('o')) {
val result = read_compiled_file_noerr(self, parse_stream, spec_file_str,
std_error);
if (!enter_repl)
return result ? 0 : EXIT_FAILURE;
} else if (enter_repl) {
read_eval_stream_noerr(self, parse_stream, spec_file_str, std_error);
close_stream(parse_stream, nil);
uw_release_deferred_warnings();
} else {
val result = read_eval_stream(self, parse_stream, std_error);
return result ? 0 : EXIT_FAILURE;
}
repl:
#if HAVE_TERMIOS
if (compat_val)
format(std_output,
lit("Note: operating in TXR ~a compatibility mode "
"due to environment variable.\n"),
num(opt_compat), nao);
reg_var(args_s, or2(orig_args, arg_list));
reg_varl(intern(lit("self-path"), user_package), lit("listener"));
env_vbind(dyn_env, package_s,
opt_compat && opt_compat <= 190 ? user_package : public_package);
env_vbind(dyn_env, load_recursive_s, nil);
repl(bindings, std_input, std_output, nil);
#endif
return 0;
}