/*
* Display an error to the client.
*/
int send_http_error_message (struct conn_s *connptr)
{
char *error_file;
FILE *infile;
int ret;
const char *fallback_error =
"<?xml version=\"1.0\" encoding=\"UTF-8\" ?>\n"
"<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.1//EN\" "
"\"http://www.w3.org/TR/xhtml11/DTD/xhtml11.dtd\">\n"
"<html>\n"
"<head><title>%d %s</title></head>\n"
"<body>\n"
"<h1>%s</h1>\n"
"<p>%s</p>\n"
"<hr />\n"
"<p><em>Generated by %s version %s.</em></p>\n" "</body>\n"
"</html>\n";
send_http_headers (connptr, connptr->error_number,
connptr->error_string);
error_file = get_html_file (connptr->error_number);
if (!(infile = fopen (error_file, "r"))) {
char *detail = lookup_variable (connptr, "detail");
return (write_message (connptr->client_fd, fallback_error,
connptr->error_number,
connptr->error_string,
connptr->error_string,
detail, PACKAGE, VERSION));
}
ret = send_html_file (infile, connptr);
fclose (infile);
return (ret);
}
/* Set a variable. Set "expand' to 1 if you want variable
definitions inside the value getting passed in to be expanded
before assigment. */
static debug_return_t dbg_cmd_set_var (char *psz_args, int expand)
{
if (!psz_args || 0==strlen(psz_args)) {
dbg_msg(_("You need to supply a variable name."));
} else {
variable_t *p_v;
char *psz_varname = get_word(&psz_args);
unsigned int u_len = strlen(psz_varname);
while (*psz_args && whitespace (*psz_args))
*psz_args +=1;
p_v = lookup_variable (psz_varname, u_len);
if (p_v) {
char *psz_value = expand ? variable_expand(psz_args) : psz_args;
define_variable_in_set(p_v->name, u_len, psz_value,
o_debugger, 0, NULL,
&(p_v->fileinfo));
dbg_msg(_("Variable %s now has value '%s'"), psz_varname,
psz_value);
} else {
try_without_dollar(psz_varname);
}
}
return debug_readloop;
}
__inline
#endif
static char *
reference_variable (char *o, const char *name, unsigned int length)
{
struct variable *v;
char *value;
v = lookup_variable (name, length);
if (v == 0)
warn_undefined (name, length);
/* If there's no variable by that name or it has no value, stop now. */
if (v == 0 || (*v->value == '\0' && !v->append))
return o;
value = (v->recursive ? recursively_expand (v) : v->value);
o = variable_buffer_output (o, value, strlen (value));
if (v->recursive)
free (value);
return o;
}
exprtree*
make_sub_assignment (scanner_ident_t *name_ident, exprtree *subscripts, exprtree *value)
{
char *name = name_ident->str;
scanner_region_t region = scanner_region_merge(name_ident->region,
scanner_region_merge(exprlist_region(subscripts), value->region));
exprtree *tree = alloc_exprtree();
tuple_info_t info;
variable_t *var = lookup_variable(the_mathmap->current_filter->v.mathmap.variables, name, &info);
if (var == 0)
{
sprintf(error_string, _("Undefined variable %s."), name);
error_region = name_ident->region;
JUMP(1);
}
if (subscripts->result.length != value->result.length)
{
sprintf(error_string, _("Lhs does not match rhs in sub assignment."));
error_region = region;
JUMP(1);
}
tree->type = EXPR_SUB_ASSIGNMENT;
tree->val.sub_assignment.var = var;
tree->val.sub_assignment.subscripts = subscripts;
tree->val.sub_assignment.value = value;
tree->result = value->result;
tree->region = region;
return tree;
}
int for_input::get()
{
if (p == 0)
return EOF;
for (;;) {
if (*p != '\0')
return (unsigned char)*p++;
if (!done_newline) {
done_newline = 1;
return '\n';
}
double val;
if (!lookup_variable(var, &val)) {
lex_error("body of `for' terminated enclosing block");
return EOF;
}
if (by_is_multiplicative)
val *= by;
else
val += by;
define_variable(var, val);
if ((from <= to && val > to)
|| (from >= to && val < to)) {
p = 0;
return EOF;
}
p = body;
done_newline = 0;
}
}
int new_variable(YARA_CONTEXT* context, char* identifier, TERM_VARIABLE** term)
{
TERM_VARIABLE* new_term = NULL;
VARIABLE* variable;
int result = ERROR_SUCCESS;
variable = lookup_variable(context->variables, identifier);
if (variable != NULL) /* external variable should be defined */
{
new_term = (TERM_VARIABLE*) yr_malloc(sizeof(TERM_VARIABLE));
if (new_term != NULL)
{
new_term->type = TERM_TYPE_VARIABLE;
new_term->variable = variable;
}
else
{
result = ERROR_INSUFICIENT_MEMORY;
}
}
else
{
strncpy(context->last_error_extra_info, identifier, sizeof(context->last_error_extra_info));
context->last_error_extra_info[sizeof(context->last_error_extra_info)-1] = 0;
result = ERROR_UNDEFINED_IDENTIFIER;
}
*term = new_term;
return result;
}
void
lock_variable(char *variable)
{
register struct variable_defs *var;
if ((var = lookup_variable(variable)) != NULL)
var->var_flags |= V_LOCKED;
}
exprtree*
make_var (scanner_ident_t *name_ident)
{
char *name = name_ident->str;
scanner_region_t region = name_ident->region;
tuple_info_t info;
exprtree *tree = 0;
if (lookup_internal(the_mathmap->current_filter->v.mathmap.internals, name, 0) != 0)
{
tree = alloc_exprtree();
tree->type = EXPR_INTERNAL;
tree->val.internal = lookup_internal(the_mathmap->current_filter->v.mathmap.internals, name, 0);
tree->result = make_tuple_info(nil_tag_number, 1);
tree->region = region;
}
else if (lookup_variable_macro(name, &info) != 0)
{
macro_function_t function = lookup_variable_macro(name, &info);
tree = function(0);
tree->region = name_ident->region;
}
else if (lookup_userval(the_mathmap->current_filter->userval_infos, name) != 0)
{
userval_info_t *info = lookup_userval(the_mathmap->current_filter->userval_infos, name);
tree = make_userval(info, 0, region);
}
else if (lookup_variable(the_mathmap->current_filter->v.mathmap.variables, name, &info) != 0)
{
variable_t *var = lookup_variable(the_mathmap->current_filter->v.mathmap.variables, name, &info);
return make_var_exprtree(var, info, region);
}
else
{
sprintf(error_string, _("Undefined variable %s."), name);
error_region = region;
JUMP(1);
}
return tree;
}
/*! Show a expression. Set "expand" to 1 if you want variable
definitions inside the displayed value expanded.
*/
bool
dbg_cmd_show_exp (char *psz_varname, bool expand)
{
if (!psz_varname || 0==strlen(psz_varname)) {
printf(_("You need to supply a variable name.\n"));
return false;
} else {
variable_t *p_v;
variable_set_t *p_set = NULL;
variable_set_list_t *p_file_vars = NULL;
if (p_stack && p_stack->p_target && p_stack->p_target->name) {
const char *psz_target = p_stack->p_target->name;
file_t *p_target = lookup_file (psz_target);
if (p_target) {
initialize_file_variables (p_target, 0);
set_file_variables (p_target);
p_file_vars = p_target->variables;
p_set = p_file_vars->set;
}
}
if (p_set) {
p_v = lookup_variable_in_set(psz_varname, strlen(psz_varname), p_set);
if (!p_v)
/* May be a global variable. */
p_v = lookup_variable (psz_varname, strlen (psz_varname));
} else {
p_v = lookup_variable (psz_varname, strlen (psz_varname));
}
if (p_v) {
if (expand) {
print_variable_expand(p_v);
} else
print_variable(p_v);
} else {
if (expand)
printf("%s\n", variable_expand_set(psz_varname, p_file_vars));
else {
try_without_dollar(psz_varname);
return false;
}
}
}
return true;
}
graphic_object *object_spec::make_box(position *curpos, direction *dirp)
{
static double last_box_height;
static double last_box_width;
static double last_box_radius;
static int have_last_box = 0;
if (!(flags & HAS_HEIGHT)) {
if ((flags & IS_SAME) && have_last_box)
height = last_box_height;
else
lookup_variable("boxht", &height);
}
if (!(flags & HAS_WIDTH)) {
if ((flags & IS_SAME) && have_last_box)
width = last_box_width;
else
lookup_variable("boxwid", &width);
}
if (!(flags & HAS_RADIUS)) {
if ((flags & IS_SAME) && have_last_box)
radius = last_box_radius;
else
lookup_variable("boxrad", &radius);
}
last_box_width = width;
last_box_height = height;
last_box_radius = radius;
have_last_box = 1;
radius = fabs(radius);
if (radius*2.0 > fabs(width))
radius = fabs(width/2.0);
if (radius*2.0 > fabs(height))
radius = fabs(height/2.0);
box_object *p = new box_object(position(width, height), radius);
if (!position_rectangle(p, curpos, dirp)) {
delete p;
p = 0;
}
return p;
}
double output::compute_scale(double sc, const position &ll, const position &ur)
{
distance dim = ur - ll;
if (desired_width != 0.0 || desired_height != 0.0) {
sc = 0.0;
if (desired_width != 0.0) {
if (dim.x == 0.0)
error("width specified for picture with zero width");
else
sc = dim.x/desired_width;
}
if (desired_height != 0.0) {
if (dim.y == 0.0)
error("height specified for picture with zero height");
else {
double tem = dim.y/desired_height;
if (tem > sc)
sc = tem;
}
}
return sc == 0.0 ? 1.0 : sc;
}
else {
if (sc <= 0.0)
sc = 1.0;
distance sdim = dim/sc;
double max_width = 0.0;
lookup_variable("maxpswid", &max_width);
double max_height = 0.0;
lookup_variable("maxpsht", &max_height);
if ((max_width > 0.0 && sdim.x > max_width)
|| (max_height > 0.0 && sdim.y > max_height)) {
double xscale = dim.x/max_width;
double yscale = dim.y/max_height;
return xscale > yscale ? xscale : yscale;
}
else
return sc;
}
}
void
toggle_variable(char *variable)
{
register struct variable_defs *var;
if ((var = lookup_variable(variable)) == NULL)
return;
if (VAR_TYPE != V_BOOLEAN) {
init_message("variable %s is not boolean", variable);
return;
}
BOOL_VAR = !BOOL_VAR;
}
int
test_variable(char *expr)
{
char *variable;
register struct variable_defs *var;
int res = -1;
variable = expr;
if ((expr = strchr(variable, '=')) == NULL)
goto err;
*expr++ = NUL;
if ((var = lookup_variable(variable)) == NULL) {
msg("testing unknown variable %s=%s", variable, expr);
goto out;
}
switch (VAR_TYPE) {
case V_BOOLEAN:
res = BOOL_VAR;
if (strcmp(expr, "on") == 0 || strcmp(expr, "true") == 0)
break;
if (strcmp(expr, "off") == 0 || strcmp(expr, "false") == 0) {
res = !res;
break;
}
msg("boolean variables must be tested =on or =off");
break;
case V_INTEGER:
res = (INT_VAR == atoi(expr)) ? 1 : 0;
break;
default:
msg("%s: cannot only test boolean and integer variables", variable);
break;
}
out:
*--expr = '=';
err:
return res;
}
static char *
reference_variable (char *o, const char *name, unsigned int length)
{
// fprintf(stderr, "reference variable for name=%s, length=%d, o=%s\n", name, length, o);
struct variable *v;
char *value;
v = lookup_variable (name, length);
if (v == 0)
warn_undefined (name, length);
/* If there's no variable by that name or it has no value, stop now. */
if (v == 0 || (*v->value == '\0' && !v->append)) {
// Vizmake
if (!v) {
char buf[BSIZE];
if (length > BSIZE) length = BSIZE - 1;
strncpy(buf, name, length);
buf[length] = '\0';
vprint("VAR REF END---UNDEFINED---%s", buf);
}
else
vprint_var(v, "");
return o;
}
value = (v->recursive ? recursively_expand (v) : v->value);
// Wenbin
vprint_var(v, value);
o = variable_buffer_output (o, value, strlen (value));
// fprintf(stderr, "wenbin: %s: %s=%s => %s\n", name, v->name, v->value, o);
if (v->recursive)
free (value);
return o;
}
exprtree*
make_assignment (scanner_ident_t *name_ident, exprtree *value)
{
char *name = name_ident->str;
scanner_region_t region = name_ident->region;
exprtree *tree = alloc_exprtree();
variable_t *var = lookup_variable(the_mathmap->current_filter->v.mathmap.variables, name, &tree->result);
if (var == NULL)
{
if (lookup_internal(the_mathmap->current_filter->v.mathmap.internals, name, TRUE) != NULL
|| lookup_variable_macro(name, NULL) != NULL)
{
sprintf(error_string, _("Cannot assign to internal variable `%s'."), name);
error_region = region;
JUMP(1);
}
if (lookup_userval(the_mathmap->current_filter->userval_infos, name) != NULL)
{
sprintf(error_string, _("Cannot assign to filter argument `%s'."), name);
error_region = region;
JUMP(1);
}
var = register_variable(&the_mathmap->current_filter->v.mathmap.variables, name, value->result);
tree->result = value->result;
}
if (tree->result.number != value->result.number || tree->result.length != value->result.length)
{
sprintf(error_string, _("Variable %s is being assigned two different types."), name);
error_region = region;
JUMP(1);
}
tree->type = EXPR_ASSIGNMENT;
tree->val.assignment.var = var;
tree->val.assignment.value = value;
tree->region = region;
return tree;
}
__inline
#endif
static char *
#endif
reference_variable (char *o, const char *name, unsigned int length)
{
struct variable *v;
#ifndef CONFIG_WITH_VALUE_LENGTH
char *value;
#endif
v = lookup_variable (name, length);
if (v == 0)
warn_undefined (name, length);
/* If there's no variable by that name or it has no value, stop now. */
if (v == 0 || (*v->value == '\0' && !v->append))
return o;
#ifdef CONFIG_WITH_VALUE_LENGTH
assert (v->value_length == strlen (v->value));
if (!v->recursive)
o = variable_buffer_output (o, v->value, v->value_length);
else
o = reference_recursive_variable (o, v);
#else /* !CONFIG_WITH_VALUE_LENGTH */
value = (v->recursive ? recursively_expand (v) : v->value);
o = variable_buffer_output (o, value, strlen (value));
if (v->recursive)
free (value);
#endif /* !CONFIG_WITH_VALUE_LENGTH */
return o;
}
int for_input::peek()
{
if (p == 0)
return EOF;
if (*p != '\0')
return (unsigned char)*p;
if (!done_newline)
return '\n';
double val;
if (!lookup_variable(var, &val))
return EOF;
if (by_is_multiplicative) {
if (val * by > to)
return EOF;
}
else {
if ((from <= to && val + by > to)
|| (from >= to && val + by < to))
return EOF;
}
if (*body == '\0')
return EOF;
return (unsigned char)*body;
}
/* Scan STRING for variable references and expansion-function calls. Only
LENGTH bytes of STRING are actually scanned. If LENGTH is -1, scan until
a null byte is found.
Write the results to LINE, which must point into `variable_buffer'. If
LINE is NULL, start at the beginning of the buffer.
Return a pointer to LINE, or to the beginning of the buffer if LINE is
NULL.
*/
char *
variable_expand_string (char *line, const char *string, long length)
{
struct variable *v;
const char *p, *p1;
char *abuf = NULL;
char *o;
unsigned int line_offset;
if (!line)
line = initialize_variable_output();
o = line;
line_offset = line - variable_buffer;
if (length == 0)
{
variable_buffer_output (o, "", 1);
return (variable_buffer);
}
/* If we want a subset of the string, allocate a temporary buffer for it.
Most of the functions we use here don't work with length limits. */
if (length > 0 && string[length] != '\0')
{
abuf = xmalloc(length+1);
memcpy(abuf, string, length);
abuf[length] = '\0';
string = abuf;
}
p = string;
while (1)
{
/* Copy all following uninteresting chars all at once to the
variable output buffer, and skip them. Uninteresting chars end
at the next $ or the end of the input. */
p1 = strchr (p, '$');
o = variable_buffer_output (o, p, p1 != 0 ? (unsigned int)(p1 - p) : strlen (p) + 1);
if (p1 == 0)
break;
p = p1 + 1;
/* Dispatch on the char that follows the $. */
switch (*p)
{
case '$':
/* $$ seen means output one $ to the variable output buffer. */
o = variable_buffer_output (o, p, 1);
break;
case '(':
case '{':
/* $(...) or ${...} is the general case of substitution. */
{
char openparen = *p;
char closeparen = (openparen == '(') ? ')' : '}';
const char *begp;
const char *beg = p + 1;
char *op;
char *abeg = NULL;
const char *end, *colon;
op = o;
begp = p;
if (handle_function (&op, &begp))
{
o = op;
p = begp;
break;
}
/* Is there a variable reference inside the parens or braces?
If so, expand it before expanding the entire reference. */
end = strchr (beg, closeparen);
if (end == 0)
/* Unterminated variable reference. */
fatal (*expanding_var, _("unterminated variable reference"));
p1 = lindex (beg, end, '$');
if (p1 != 0)
{
/* BEG now points past the opening paren or brace.
Count parens or braces until it is matched. */
int count = 0;
for (p = beg; *p != '\0'; ++p)
{
if (*p == openparen)
++count;
else if (*p == closeparen && --count < 0)
break;
}
/* If COUNT is >= 0, there were unmatched opening parens
or braces, so we go to the simple case of a variable name
such as `$($(a)'. */
if (count < 0)
{
abeg = expand_argument (beg, p); /* Expand the name. */
beg = abeg;
end = strchr (beg, '\0');
}
}
else
/* Advance P to the end of this reference. After we are
finished expanding this one, P will be incremented to
continue the scan. */
p = end;
/* This is not a reference to a built-in function and
any variable references inside are now expanded.
Is the resultant text a substitution reference? */
colon = lindex (beg, end, ':');
if (colon)
{
/* This looks like a substitution reference: $(FOO:A=B). */
const char *subst_beg, *subst_end, *replace_beg, *replace_end;
subst_beg = colon + 1;
subst_end = lindex (subst_beg, end, '=');
if (subst_end == 0)
/* There is no = in sight. Punt on the substitution
reference and treat this as a variable name containing
a colon, in the code below. */
colon = 0;
else
{
replace_beg = subst_end + 1;
replace_end = end;
/* Extract the variable name before the colon
and look up that variable. */
v = lookup_variable (beg, colon - beg);
if (v == 0)
warn_undefined (beg, colon - beg);
/* If the variable is not empty, perform the
substitution. */
if (v != 0 && *v->value != '\0')
{
char *pattern, *replace, *ppercent, *rpercent;
char *value = (v->recursive
? recursively_expand (v)
: v->value);
/* Copy the pattern and the replacement. Add in an
extra % at the beginning to use in case there
isn't one in the pattern. */
pattern = alloca (subst_end - subst_beg + 2);
*(pattern++) = '%';
memcpy (pattern, subst_beg, subst_end - subst_beg);
pattern[subst_end - subst_beg] = '\0';
replace = alloca (replace_end - replace_beg + 2);
*(replace++) = '%';
memcpy (replace, replace_beg,
replace_end - replace_beg);
replace[replace_end - replace_beg] = '\0';
/* Look for %. Set the percent pointers properly
based on whether we find one or not. */
ppercent = find_percent (pattern);
if (ppercent)
{
++ppercent;
rpercent = find_percent (replace);
if (rpercent)
++rpercent;
}
else
{
ppercent = pattern;
rpercent = replace;
--pattern;
--replace;
}
o = patsubst_expand_pat (o, value, pattern, replace,
ppercent, rpercent);
if (v->recursive)
free (value);
}
}
}
if (colon == 0)
/* This is an ordinary variable reference.
Look up the value of the variable. */
o = reference_variable (o, beg, end - beg);
if (abeg)
free (abeg);
}
break;
case '\0':
break;
default:
if (isblank ((unsigned char)p[-1]))
break;
/* A $ followed by a random char is a variable reference:
$a is equivalent to $(a). */
o = reference_variable (o, p, 1);
break;
}
if (*p == '\0')
break;
++p;
}
if (abuf)
free (abuf);
variable_buffer_output (o, "", 1);
return (variable_buffer + line_offset);
}
object_t lookup_variable_value(object_t variable, object_t environment) {
return lookup_variable(variable, environment);
}
/* Scan STRING for variable references and expansion-function calls. Only
LENGTH bytes of STRING are actually scanned. If LENGTH is -1, scan until
a null byte is found.
Write the results to LINE, which must point into `variable_buffer'. If
LINE is NULL, start at the beginning of the buffer.
Return a pointer to LINE, or to the beginning of the buffer if LINE is
NULL. Set EOLP to point to the string terminator.
*/
char *
variable_expand_string_2 (char *line, const char *string, long length, char **eolp)
{
struct variable *v;
const char *p, *p1, *eos;
char *o;
unsigned int line_offset;
if (!line)
line = initialize_variable_output();
o = line;
line_offset = line - variable_buffer;
if (length < 0)
length = strlen (string);
else
MY_ASSERT_MSG (string + length == (p1 = memchr (string, '\0', length)) || !p1, ("len=%ld p1=%p %s\n", length, p1, line));
/* Simple 1: Emptry string. */
if (length == 0)
{
o = variable_buffer_output (o, "\0", 2);
*eolp = o - 2;
return (variable_buffer + line_offset);
}
/* Simple 2: Nothing to expand. ~50% if the kBuild calls. */
p1 = (const char *)memchr (string, '$', length);
if (p1 == 0)
{
o = variable_buffer_output (o, string, length);
o = variable_buffer_output (o, "\0", 2);
*eolp = o - 2;
assert (strchr (variable_buffer + line_offset, '\0') == *eolp);
return (variable_buffer + line_offset);
}
p = string;
eos = p + length;
while (1)
{
/* Copy all following uninteresting chars all at once to the
variable output buffer, and skip them. Uninteresting chars end
at the next $ or the end of the input. */
o = variable_buffer_output (o, p, p1 != 0 ? (p1 - p) : (eos - p));
if (p1 == 0)
break;
p = p1 + 1;
/* Dispatch on the char that follows the $. */
switch (*p)
{
case '$':
/* $$ seen means output one $ to the variable output buffer. */
o = variable_buffer_output (o, p, 1);
break;
case '(':
case '{':
/* $(...) or ${...} is the general case of substitution. */
{
char openparen = *p;
char closeparen = (openparen == '(') ? ')' : '}';
const char *begp;
const char *beg = p + 1;
char *op;
char *abeg = NULL;
unsigned int alen = 0;
const char *end, *colon;
op = o;
begp = p;
end = may_be_function_name (p + 1, eos);
if ( end
&& handle_function (&op, &begp, end, eos))
{
o = op;
p = begp;
MY_ASSERT_MSG (!(p1 = memchr (variable_buffer + line_offset, '\0', o - (variable_buffer + line_offset))),
("line=%p o/exp_end=%p act_end=%p\n", variable_buffer + line_offset, o, p1));
break;
}
/* Is there a variable reference inside the parens or braces?
If so, expand it before expanding the entire reference. */
end = memchr (beg, closeparen, eos - beg);
if (end == 0)
/* Unterminated variable reference. */
fatal (*expanding_var, _("unterminated variable reference"));
p1 = lindex (beg, end, '$');
if (p1 != 0)
{
/* BEG now points past the opening paren or brace.
Count parens or braces until it is matched. */
int count = 0;
for (p = beg; p < eos; ++p)
{
if (*p == openparen)
++count;
else if (*p == closeparen && --count < 0)
break;
}
/* If COUNT is >= 0, there were unmatched opening parens
or braces, so we go to the simple case of a variable name
such as `$($(a)'. */
if (count < 0)
{
unsigned int len;
char saved;
/* Expand the name. */
saved = *p;
*(char *)p = '\0'; /* XXX: proove that this is safe! XXX2: shouldn't be necessary any longer! */
abeg = allocated_variable_expand_3 (beg, p - beg, &len, &alen);
beg = abeg;
end = beg + len;
*(char *)p = saved;
}
}
else
/* Advance P to the end of this reference. After we are
finished expanding this one, P will be incremented to
continue the scan. */
p = end;
/* This is not a reference to a built-in function and
any variable references inside are now expanded.
Is the resultant text a substitution reference? */
colon = lindex (beg, end, ':');
if (colon)
{
/* This looks like a substitution reference: $(FOO:A=B). */
const char *subst_beg, *subst_end, *replace_beg, *replace_end;
subst_beg = colon + 1;
subst_end = lindex (subst_beg, end, '=');
if (subst_end == 0)
/* There is no = in sight. Punt on the substitution
reference and treat this as a variable name containing
a colon, in the code below. */
colon = 0;
else
{
replace_beg = subst_end + 1;
replace_end = end;
/* Extract the variable name before the colon
and look up that variable. */
v = lookup_variable (beg, colon - beg);
if (v == 0)
warn_undefined (beg, colon - beg);
/* If the variable is not empty, perform the
substitution. */
if (v != 0 && *v->value != '\0')
{
char *pattern, *replace, *ppercent, *rpercent;
char *value = (v->recursive
? recursively_expand (v)
: v->value);
/* Copy the pattern and the replacement. Add in an
extra % at the beginning to use in case there
isn't one in the pattern. */
pattern = alloca (subst_end - subst_beg + 2);
*(pattern++) = '%';
memcpy (pattern, subst_beg, subst_end - subst_beg);
pattern[subst_end - subst_beg] = '\0';
replace = alloca (replace_end - replace_beg + 2);
*(replace++) = '%';
memcpy (replace, replace_beg,
replace_end - replace_beg);
replace[replace_end - replace_beg] = '\0';
/* Look for %. Set the percent pointers properly
based on whether we find one or not. */
ppercent = find_percent (pattern);
if (ppercent)
{
++ppercent;
rpercent = find_percent (replace);
if (rpercent)
++rpercent;
}
else
{
ppercent = pattern;
rpercent = replace;
--pattern;
--replace;
}
o = patsubst_expand_pat (o, value, pattern, replace,
ppercent, rpercent);
if (v->recursive)
free (value);
}
}
}
if (colon == 0)
/* This is an ordinary variable reference.
Look up the value of the variable. */
o = reference_variable (o, beg, end - beg);
if (abeg)
recycle_variable_buffer (abeg, alen);
}
break;
case '\0':
assert (p == eos);
break;
default:
if (isblank ((unsigned char)p[-1])) /* XXX: This looks incorrect, previous is '$' */
break;
/* A $ followed by a random char is a variable reference:
$a is equivalent to $(a). */
o = reference_variable (o, p, 1);
break;
}
if (++p >= eos)
break;
p1 = memchr (p, '$', eos - p);
}
o = variable_buffer_output (o, "\0", 2); /* KMK: compensate for the strlen + 1 that was removed above. */
*eolp = o - 2;
MY_ASSERT_MSG (strchr (variable_buffer + line_offset, '\0') == *eolp,
("expected=%d actual=%d\nlength=%ld string=%.*s\n",
(int)(*eolp - variable_buffer + line_offset), (int)strlen(variable_buffer + line_offset),
length, (int)length, string));
return (variable_buffer + line_offset);
}
/**
* Appends text to a textfile, creating the textfile if necessary.
*/
int kmk_builtin_append(int argc, char **argv, char **envp)
{
int i;
int fFirst;
int iFile;
FILE *pFile;
int fNewline = 0;
int fNoTrailingNewline = 0;
int fTruncate = 0;
int fDefine = 0;
int fVariables = 0;
int fCommands = 0;
g_progname = argv[0];
/*
* Parse options.
*/
i = 1;
while (i < argc
&& argv[i][0] == '-'
&& argv[i][1] != '\0' /* '-' is a file */
&& strchr("-cdnNtv", argv[i][1]) /* valid option char */
)
{
char *psz = &argv[i][1];
if (*psz != '-')
{
do
{
switch (*psz)
{
case 'c':
if (fVariables)
{
errx(1, "Option '-c' clashes with '-v'.");
return usage(stderr);
}
#ifndef kmk_builtin_append
fCommands = 1;
break;
#else
errx(1, "Option '-c' isn't supported in external mode.");
return usage(stderr);
#endif
case 'd':
if (fVariables)
{
errx(1, "Option '-d' must come before '-v'!");
return usage(stderr);
}
fDefine = 1;
break;
case 'n':
fNewline = 1;
break;
case 'N':
fNoTrailingNewline = 1;
break;
case 't':
fTruncate = 1;
break;
case 'v':
if (fCommands)
{
errx(1, "Option '-v' clashes with '-c'.");
return usage(stderr);
}
#ifndef kmk_builtin_append
fVariables = 1;
break;
#else
errx(1, "Option '-v' isn't supported in external mode.");
return usage(stderr);
#endif
default:
errx(1, "Invalid option '%c'! (%s)", *psz, argv[i]);
return usage(stderr);
}
} while (*++psz);
}
else if (!strcmp(psz, "-help"))
{
usage(stdout);
return 0;
}
else if (!strcmp(psz, "-version"))
return kbuild_version(argv[0]);
else
break;
i++;
}
if (i + fDefine >= argc)
{
if (i <= argc)
errx(1, "missing filename!");
else
errx(1, "missing define name!");
return usage(stderr);
}
/*
* Open the output file.
*/
iFile = i;
pFile = fopen(argv[i], fTruncate ? "w" : "a");
if (!pFile)
return err(1, "failed to open '%s'", argv[i]);
/*
* Start define?
*/
if (fDefine)
{
i++;
fprintf(pFile, "define %s\n", argv[i]);
}
/*
* Append the argument strings to the file
*/
fFirst = 1;
for (i++; i < argc; i++)
{
const char *psz = argv[i];
size_t cch = strlen(psz);
if (!fFirst)
fputc(fNewline ? '\n' : ' ', pFile);
#ifndef kmk_builtin_append
if (fCommands)
{
char *pszOldBuf;
unsigned cchOldBuf;
char *pchEnd;
install_variable_buffer(&pszOldBuf, &cchOldBuf);
pchEnd = func_commands(variable_buffer, &argv[i], "commands");
fwrite(variable_buffer, 1, pchEnd - variable_buffer, pFile);
restore_variable_buffer(pszOldBuf, cchOldBuf);
}
else if (fVariables)
{
struct variable *pVar = lookup_variable(psz, cch);
if (!pVar)
continue;
if ( !pVar->recursive
|| IS_VARIABLE_RECURSIVE_WITHOUT_DOLLAR(pVar))
fwrite(pVar->value, 1, pVar->value_length, pFile);
else
{
char *pszExpanded = allocated_variable_expand(pVar->value);
fwrite(pszExpanded, 1, strlen(pszExpanded), pFile);
free(pszExpanded);
}
}
else
#endif
fwrite(psz, 1, cch, pFile);
fFirst = 0;
}
/*
* End the define?
*/
if (fDefine)
{
if (fFirst)
fwrite("\nendef", 1, sizeof("\nendef") - 1, pFile);
else
fwrite("endef", 1, sizeof("endef") - 1, pFile);
}
/*
* Add the final newline (unless supressed) and close the file.
*/
if ( ( !fNoTrailingNewline
&& fputc('\n', pFile) == EOF)
|| ferror(pFile))
{
fclose(pFile);
return errx(1, "error writing to '%s'!", argv[iFile]);
}
if (fclose(pFile))
return err(1, "failed to fclose '%s'!", argv[iFile]);
return 0;
}
void
Interpret (int pop_return_p)
{
long dispatch_code;
struct interpreter_state_s new_state;
/* Primitives jump back here for errors, requests to evaluate an
expression, apply a function, or handle an interrupt request. On
errors or interrupts they leave their arguments on the stack, the
primitive itself in GET_EXP. The code should do a primitive
backout in these cases, but not in others (apply, eval, etc.),
since the primitive itself will have left the state of the
interpreter ready for operation. */
bind_interpreter_state (&new_state);
dispatch_code = (setjmp (interpreter_catch_env));
preserve_signal_mask ();
fixup_float_environment ();
switch (dispatch_code)
{
case 0: /* first time */
if (pop_return_p)
goto pop_return; /* continue */
else
break; /* fall into eval */
case PRIM_APPLY:
PROCEED_AFTER_PRIMITIVE ();
goto internal_apply;
case PRIM_NO_TRAP_APPLY:
PROCEED_AFTER_PRIMITIVE ();
goto Apply_Non_Trapping;
case PRIM_APPLY_INTERRUPT:
PROCEED_AFTER_PRIMITIVE ();
PREPARE_APPLY_INTERRUPT ();
SIGNAL_INTERRUPT (PENDING_INTERRUPTS ());
case PRIM_APPLY_ERROR:
PROCEED_AFTER_PRIMITIVE ();
APPLICATION_ERROR (prim_apply_error_code);
case PRIM_DO_EXPRESSION:
SET_VAL (GET_EXP);
PROCEED_AFTER_PRIMITIVE ();
REDUCES_TO (GET_VAL);
case PRIM_NO_TRAP_EVAL:
SET_VAL (GET_EXP);
PROCEED_AFTER_PRIMITIVE ();
NEW_REDUCTION (GET_VAL, GET_ENV);
goto eval_non_trapping;
case PRIM_POP_RETURN:
PROCEED_AFTER_PRIMITIVE ();
goto pop_return;
case PRIM_RETURN_TO_C:
PROCEED_AFTER_PRIMITIVE ();
unbind_interpreter_state (interpreter_state);
return;
case PRIM_NO_TRAP_POP_RETURN:
PROCEED_AFTER_PRIMITIVE ();
goto pop_return_non_trapping;
case PRIM_INTERRUPT:
back_out_of_primitive ();
SIGNAL_INTERRUPT (PENDING_INTERRUPTS ());
case PRIM_ABORT_TO_C:
back_out_of_primitive ();
unbind_interpreter_state (interpreter_state);
return;
case ERR_ARG_1_WRONG_TYPE:
back_out_of_primitive ();
Do_Micro_Error (ERR_ARG_1_WRONG_TYPE, true);
goto internal_apply;
case ERR_ARG_2_WRONG_TYPE:
back_out_of_primitive ();
Do_Micro_Error (ERR_ARG_2_WRONG_TYPE, true);
goto internal_apply;
case ERR_ARG_3_WRONG_TYPE:
back_out_of_primitive ();
Do_Micro_Error (ERR_ARG_3_WRONG_TYPE, true);
goto internal_apply;
default:
back_out_of_primitive ();
Do_Micro_Error (dispatch_code, true);
goto internal_apply;
}
do_expression:
/* GET_EXP has an Scode item in it that should be evaluated and the
result left in GET_VAL.
A "break" after the code for any operation indicates that all
processing for this operation has been completed, and the next
step will be to pop a return code off the stack and proceed at
pop_return. This is sometimes called "executing the
continuation" since the return code can be considered the
continuation to be performed after the operation.
An operation can terminate with a REDUCES_TO or REDUCES_TO_NTH
macro. This indicates that the value of the current Scode item
is the value returned when the new expression is evaluated.
Therefore no new continuation is created and processing continues
at do_expression with the new expression in GET_EXP.
Finally, an operation can terminate with a DO_NTH_THEN macro.
This indicates that another expression must be evaluated and them
some additional processing will be performed before the value of
this S-Code item available. Thus a new continuation is created
and placed on the stack (using SAVE_CONT), the new expression is
placed in the GET_EXP, and processing continues at do_expression.
*/
/* Handling of Eval Trapping.
If we are handling traps and there is an Eval Trap set, turn off
all trapping and then go to internal_apply to call the user
supplied eval hook with the expression to be evaluated and the
environment. */
#ifdef COMPILE_STEPPER
if (trapping
&& (!WITHIN_CRITICAL_SECTION_P ())
&& ((FETCH_EVAL_TRAPPER ()) != SHARP_F))
{
trapping = false;
Will_Push (4);
PUSH_ENV ();
PUSH_EXP ();
STACK_PUSH (FETCH_EVAL_TRAPPER ());
PUSH_APPLY_FRAME_HEADER (2);
Pushed ();
goto Apply_Non_Trapping;
}
#endif /* COMPILE_STEPPER */
eval_non_trapping:
#ifdef EVAL_UCODE_HOOK
EVAL_UCODE_HOOK ();
#endif
switch (OBJECT_TYPE (GET_EXP))
{
case TC_BIG_FIXNUM: /* The self evaluating items */
case TC_BIG_FLONUM:
case TC_CHARACTER_STRING:
case TC_CHARACTER:
case TC_COMPILED_CODE_BLOCK:
case TC_COMPLEX:
case TC_CONTROL_POINT:
case TC_DELAYED:
case TC_ENTITY:
case TC_ENVIRONMENT:
case TC_EXTENDED_PROCEDURE:
case TC_FIXNUM:
case TC_HUNK3_A:
case TC_HUNK3_B:
case TC_INTERNED_SYMBOL:
case TC_LIST:
case TC_NON_MARKED_VECTOR:
case TC_NULL:
case TC_PRIMITIVE:
case TC_PROCEDURE:
case TC_QUAD:
case TC_RATNUM:
case TC_REFERENCE_TRAP:
case TC_RETURN_CODE:
case TC_UNINTERNED_SYMBOL:
case TC_CONSTANT:
case TC_VECTOR:
case TC_VECTOR_16B:
case TC_VECTOR_1B:
default:
SET_VAL (GET_EXP);
break;
case TC_ACCESS:
Will_Push (CONTINUATION_SIZE);
PUSH_NTH_THEN (RC_EXECUTE_ACCESS_FINISH, ACCESS_ENVIRONMENT);
case TC_ASSIGNMENT:
Will_Push (CONTINUATION_SIZE + 1);
PUSH_ENV ();
PUSH_NTH_THEN (RC_EXECUTE_ASSIGNMENT_FINISH, ASSIGN_VALUE);
case TC_BROKEN_HEART:
Microcode_Termination (TERM_BROKEN_HEART);
case TC_COMBINATION:
{
long length = ((VECTOR_LENGTH (GET_EXP)) - 1);
Will_Push (length + 2 + CONTINUATION_SIZE);
stack_pointer = (STACK_LOC (-length));
STACK_PUSH (MAKE_OBJECT (TC_MANIFEST_NM_VECTOR, length));
/* The finger: last argument number */
Pushed ();
if (length == 0)
{
PUSH_APPLY_FRAME_HEADER (0); /* Frame size */
DO_NTH_THEN (RC_COMB_APPLY_FUNCTION, COMB_FN_SLOT);
}
PUSH_ENV ();
DO_NTH_THEN (RC_COMB_SAVE_VALUE, (length + 1));
}
case TC_COMBINATION_1:
Will_Eventually_Push (CONTINUATION_SIZE + STACK_ENV_FIRST_ARG + 1);
PUSH_ENV ();
DO_NTH_THEN (RC_COMB_1_PROCEDURE, COMB_1_ARG_1);
case TC_COMBINATION_2:
Will_Eventually_Push (CONTINUATION_SIZE + STACK_ENV_FIRST_ARG + 2);
PUSH_ENV ();
DO_NTH_THEN (RC_COMB_2_FIRST_OPERAND, COMB_2_ARG_2);
case TC_COMMENT:
REDUCES_TO_NTH (COMMENT_EXPRESSION);
case TC_CONDITIONAL:
Will_Push (CONTINUATION_SIZE + 1);
PUSH_ENV ();
PUSH_NTH_THEN (RC_CONDITIONAL_DECIDE, COND_PREDICATE);
#ifdef CC_SUPPORT_P
case TC_COMPILED_ENTRY:
dispatch_code = (enter_compiled_expression ());
goto return_from_compiled_code;
#endif
case TC_DEFINITION:
Will_Push (CONTINUATION_SIZE + 1);
PUSH_ENV ();
PUSH_NTH_THEN (RC_EXECUTE_DEFINITION_FINISH, DEFINE_VALUE);
case TC_DELAY:
/* Deliberately omitted: EVAL_GC_CHECK (2); */
SET_VAL (MAKE_POINTER_OBJECT (TC_DELAYED, Free));
(Free[THUNK_ENVIRONMENT]) = GET_ENV;
(Free[THUNK_PROCEDURE]) = (MEMORY_REF (GET_EXP, DELAY_OBJECT));
Free += 2;
break;
case TC_DISJUNCTION:
Will_Push (CONTINUATION_SIZE + 1);
PUSH_ENV ();
PUSH_NTH_THEN (RC_DISJUNCTION_DECIDE, OR_PREDICATE);
case TC_EXTENDED_LAMBDA:
/* Deliberately omitted: EVAL_GC_CHECK (2); */
SET_VAL (MAKE_POINTER_OBJECT (TC_EXTENDED_PROCEDURE, Free));
(Free[PROCEDURE_LAMBDA_EXPR]) = GET_EXP;
(Free[PROCEDURE_ENVIRONMENT]) = GET_ENV;
Free += 2;
break;
case TC_IN_PACKAGE:
Will_Push (CONTINUATION_SIZE);
PUSH_NTH_THEN (RC_EXECUTE_IN_PACKAGE_CONTINUE, IN_PACKAGE_ENVIRONMENT);
case TC_LAMBDA:
case TC_LEXPR:
/* Deliberately omitted: EVAL_GC_CHECK (2); */
SET_VAL (MAKE_POINTER_OBJECT (TC_PROCEDURE, Free));
(Free[PROCEDURE_LAMBDA_EXPR]) = GET_EXP;
(Free[PROCEDURE_ENVIRONMENT]) = GET_ENV;
Free += 2;
break;
case TC_MANIFEST_NM_VECTOR:
EVAL_ERROR (ERR_EXECUTE_MANIFEST_VECTOR);
case TC_PCOMB0:
/* The argument to Will_Eventually_Push is determined by how
much will be on the stack if we back out of the primitive. */
Will_Eventually_Push (CONTINUATION_SIZE + STACK_ENV_FIRST_ARG);
Finished_Eventual_Pushing (CONTINUATION_SIZE + STACK_ENV_FIRST_ARG);
SET_EXP (OBJECT_NEW_TYPE (TC_PRIMITIVE, GET_EXP));
goto primitive_internal_apply;
case TC_PCOMB1:
Will_Eventually_Push (CONTINUATION_SIZE + STACK_ENV_FIRST_ARG + 1);
DO_NTH_THEN (RC_PCOMB1_APPLY, PCOMB1_ARG_SLOT);
case TC_PCOMB2:
Will_Eventually_Push (CONTINUATION_SIZE + STACK_ENV_FIRST_ARG + 2);
PUSH_ENV ();
DO_NTH_THEN (RC_PCOMB2_DO_1, PCOMB2_ARG_2_SLOT);
case TC_PCOMB3:
Will_Eventually_Push (CONTINUATION_SIZE + STACK_ENV_FIRST_ARG + 3);
PUSH_ENV ();
DO_NTH_THEN (RC_PCOMB3_DO_2, PCOMB3_ARG_3_SLOT);
case TC_SCODE_QUOTE:
SET_VAL (MEMORY_REF (GET_EXP, SCODE_QUOTE_OBJECT));
break;
case TC_SEQUENCE_2:
Will_Push (CONTINUATION_SIZE + 1);
PUSH_ENV ();
PUSH_NTH_THEN (RC_SEQ_2_DO_2, SEQUENCE_1);
case TC_SEQUENCE_3:
Will_Push (CONTINUATION_SIZE + 1);
PUSH_ENV ();
PUSH_NTH_THEN (RC_SEQ_3_DO_2, SEQUENCE_1);
case TC_SYNTAX_ERROR:
EVAL_ERROR (ERR_SYNTAX_ERROR);
case TC_THE_ENVIRONMENT:
SET_VAL (GET_ENV);
break;
case TC_VARIABLE:
{
SCHEME_OBJECT val = GET_VAL;
SCHEME_OBJECT name = (GET_VARIABLE_SYMBOL (GET_EXP));
long temp = (lookup_variable (GET_ENV, name, (&val)));
if (temp != PRIM_DONE)
{
/* Back out of the evaluation. */
if (temp == PRIM_INTERRUPT)
{
PREPARE_EVAL_REPEAT ();
SIGNAL_INTERRUPT (PENDING_INTERRUPTS ());
}
EVAL_ERROR (temp);
}
SET_VAL (val);
}
}
/* Now restore the continuation saved during an earlier part of the
EVAL cycle and continue as directed. */
pop_return:
#ifdef COMPILE_STEPPER
if (trapping
&& (!WITHIN_CRITICAL_SECTION_P ())
&& ((FETCH_RETURN_TRAPPER ()) != SHARP_F))
{
Will_Push (3);
trapping = false;
PUSH_VAL ();
STACK_PUSH (FETCH_RETURN_TRAPPER ());
PUSH_APPLY_FRAME_HEADER (1);
Pushed ();
goto Apply_Non_Trapping;
}
#endif /* COMPILE_STEPPER */
pop_return_non_trapping:
#ifdef POP_RETURN_UCODE_HOOK
POP_RETURN_UCODE_HOOK ();
#endif
RESTORE_CONT ();
#ifdef ENABLE_DEBUGGING_TOOLS
if (!RETURN_CODE_P (GET_RET))
{
PUSH_VAL (); /* For possible stack trace */
SAVE_CONT ();
Microcode_Termination (TERM_BAD_STACK);
}
#endif
/* Dispatch on the return code. A BREAK here will cause
a "goto pop_return" to occur, since this is the most
common occurrence.
*/
switch (OBJECT_DATUM (GET_RET))
{
case RC_COMB_1_PROCEDURE:
POP_ENV ();
PUSH_VAL (); /* Arg. 1 */
STACK_PUSH (SHARP_F); /* Operator */
PUSH_APPLY_FRAME_HEADER (1);
Finished_Eventual_Pushing (CONTINUATION_SIZE);
DO_ANOTHER_THEN (RC_COMB_APPLY_FUNCTION, COMB_1_FN);
case RC_COMB_2_FIRST_OPERAND:
POP_ENV ();
PUSH_VAL ();
PUSH_ENV ();
DO_ANOTHER_THEN (RC_COMB_2_PROCEDURE, COMB_2_ARG_1);
case RC_COMB_2_PROCEDURE:
POP_ENV ();
PUSH_VAL (); /* Arg 1, just calculated */
STACK_PUSH (SHARP_F); /* Function */
PUSH_APPLY_FRAME_HEADER (2);
Finished_Eventual_Pushing (CONTINUATION_SIZE);
DO_ANOTHER_THEN (RC_COMB_APPLY_FUNCTION, COMB_2_FN);
case RC_COMB_APPLY_FUNCTION:
END_SUBPROBLEM ();
goto internal_apply_val;
case RC_COMB_SAVE_VALUE:
{
long Arg_Number;
POP_ENV ();
Arg_Number = ((OBJECT_DATUM (STACK_REF (STACK_COMB_FINGER))) - 1);
(STACK_REF (STACK_COMB_FIRST_ARG + Arg_Number)) = GET_VAL;
(STACK_REF (STACK_COMB_FINGER))
= (MAKE_OBJECT (TC_MANIFEST_NM_VECTOR, Arg_Number));
/* DO NOT count on the type code being NMVector here, since
the stack parser may create them with #F here! */
if (Arg_Number > 0)
{
PUSH_ENV ();
DO_ANOTHER_THEN
(RC_COMB_SAVE_VALUE, ((COMB_ARG_1_SLOT - 1) + Arg_Number));
}
/* Frame Size */
STACK_PUSH (MEMORY_REF (GET_EXP, 0));
DO_ANOTHER_THEN (RC_COMB_APPLY_FUNCTION, COMB_FN_SLOT);
}
#ifdef CC_SUPPORT_P
#define DEFINE_COMPILER_RESTART(return_code, entry) \
case return_code: \
{ \
dispatch_code = (entry ()); \
goto return_from_compiled_code; \
}
DEFINE_COMPILER_RESTART
(RC_COMP_INTERRUPT_RESTART, comp_interrupt_restart);
DEFINE_COMPILER_RESTART
(RC_COMP_LOOKUP_TRAP_RESTART, comp_lookup_trap_restart);
DEFINE_COMPILER_RESTART
(RC_COMP_ASSIGNMENT_TRAP_RESTART, comp_assignment_trap_restart);
DEFINE_COMPILER_RESTART
(RC_COMP_OP_REF_TRAP_RESTART, comp_op_lookup_trap_restart);
DEFINE_COMPILER_RESTART
(RC_COMP_CACHE_REF_APPLY_RESTART, comp_cache_lookup_apply_restart);
DEFINE_COMPILER_RESTART
(RC_COMP_SAFE_REF_TRAP_RESTART, comp_safe_lookup_trap_restart);
DEFINE_COMPILER_RESTART
(RC_COMP_UNASSIGNED_TRAP_RESTART, comp_unassigned_p_trap_restart);
DEFINE_COMPILER_RESTART
(RC_COMP_LINK_CACHES_RESTART, comp_link_caches_restart);
DEFINE_COMPILER_RESTART
(RC_COMP_ERROR_RESTART, comp_error_restart);
case RC_REENTER_COMPILED_CODE:
dispatch_code = (return_to_compiled_code ());
goto return_from_compiled_code;
#endif
case RC_CONDITIONAL_DECIDE:
END_SUBPROBLEM ();
POP_ENV ();
REDUCES_TO_NTH
((GET_VAL == SHARP_F) ? COND_ALTERNATIVE : COND_CONSEQUENT);
case RC_DISJUNCTION_DECIDE:
/* Return predicate if it isn't #F; else do ALTERNATIVE */
END_SUBPROBLEM ();
POP_ENV ();
if (GET_VAL != SHARP_F)
goto pop_return;
REDUCES_TO_NTH (OR_ALTERNATIVE);
case RC_END_OF_COMPUTATION:
{
/* Signals bottom of stack */
interpreter_state_t previous_state;
previous_state = (interpreter_state -> previous_state);
if (previous_state == NULL_INTERPRETER_STATE)
{
termination_end_of_computation ();
/*NOTREACHED*/
}
else
{
dstack_position = interpreter_catch_dstack_position;
interpreter_state = previous_state;
return;
}
}
case RC_EVAL_ERROR:
/* Should be called RC_REDO_EVALUATION. */
POP_ENV ();
REDUCES_TO (GET_EXP);
case RC_EXECUTE_ACCESS_FINISH:
{
SCHEME_OBJECT val;
long code;
code = (lookup_variable (GET_VAL,
(MEMORY_REF (GET_EXP, ACCESS_NAME)),
(&val)));
if (code == PRIM_DONE)
SET_VAL (val);
else if (code == PRIM_INTERRUPT)
{
PREPARE_POP_RETURN_INTERRUPT (RC_EXECUTE_ACCESS_FINISH, GET_VAL);
SIGNAL_INTERRUPT (PENDING_INTERRUPTS ());
}
else
POP_RETURN_ERROR (code);
}
END_SUBPROBLEM ();
break;
case RC_EXECUTE_ASSIGNMENT_FINISH:
{
SCHEME_OBJECT variable = (MEMORY_REF (GET_EXP, ASSIGN_NAME));
SCHEME_OBJECT old_val;
long code;
POP_ENV ();
if (TC_VARIABLE == (OBJECT_TYPE (variable)))
code = (assign_variable (GET_ENV,
(GET_VARIABLE_SYMBOL (variable)),
GET_VAL,
(&old_val)));
else
code = ERR_BAD_FRAME;
if (code == PRIM_DONE)
SET_VAL (old_val);
else
{
PUSH_ENV ();
if (code == PRIM_INTERRUPT)
{
PREPARE_POP_RETURN_INTERRUPT
(RC_EXECUTE_ASSIGNMENT_FINISH, GET_VAL);
SIGNAL_INTERRUPT (PENDING_INTERRUPTS ());
}
else
POP_RETURN_ERROR (code);
}
}
END_SUBPROBLEM ();
break;
case RC_EXECUTE_DEFINITION_FINISH:
{
SCHEME_OBJECT name = (MEMORY_REF (GET_EXP, DEFINE_NAME));
SCHEME_OBJECT value = GET_VAL;
long result;
POP_ENV ();
result = (define_variable (GET_ENV, name, value));
if (result == PRIM_DONE)
{
END_SUBPROBLEM ();
SET_VAL (name);
break;
}
PUSH_ENV ();
if (result == PRIM_INTERRUPT)
{
PREPARE_POP_RETURN_INTERRUPT (RC_EXECUTE_DEFINITION_FINISH,
value);
SIGNAL_INTERRUPT (PENDING_INTERRUPTS ());
}
SET_VAL (value);
POP_RETURN_ERROR (result);
}
case RC_EXECUTE_IN_PACKAGE_CONTINUE:
if (ENVIRONMENT_P (GET_VAL))
{
END_SUBPROBLEM ();
SET_ENV (GET_VAL);
REDUCES_TO_NTH (IN_PACKAGE_EXPRESSION);
}
POP_RETURN_ERROR (ERR_BAD_FRAME);
case RC_HALT:
Microcode_Termination (TERM_TERM_HANDLER);
case RC_HARDWARE_TRAP:
{
/* This just reinvokes the handler */
SCHEME_OBJECT info = (STACK_REF (0));
SCHEME_OBJECT handler = SHARP_F;
SAVE_CONT ();
if (VECTOR_P (fixed_objects))
handler = (VECTOR_REF (fixed_objects, TRAP_HANDLER));
if (handler == SHARP_F)
{
outf_fatal ("There is no trap handler for recovery!\n");
termination_trap ();
/*NOTREACHED*/
}
Will_Push (STACK_ENV_EXTRA_SLOTS + 2);
STACK_PUSH (info);
STACK_PUSH (handler);
PUSH_APPLY_FRAME_HEADER (1);
Pushed ();
}
goto internal_apply;
/* internal_apply, the core of the application mechanism.
Branch here to perform a function application.
At this point the top of the stack contains an application
frame which consists of the following elements (see sdata.h):
- A header specifying the frame length.
- A procedure.
- The actual (evaluated) arguments.
No registers (except the stack pointer) are meaning full at
this point. Before interrupts or errors are processed, some
registers are cleared to avoid holding onto garbage if a
garbage collection occurs. */
case RC_INTERNAL_APPLY_VAL:
internal_apply_val:
(APPLY_FRAME_PROCEDURE ()) = GET_VAL;
case RC_INTERNAL_APPLY:
internal_apply:
#ifdef COMPILE_STEPPER
if (trapping
&& (!WITHIN_CRITICAL_SECTION_P ())
&& ((FETCH_APPLY_TRAPPER ()) != SHARP_F))
{
unsigned long frame_size = (APPLY_FRAME_SIZE ());
(* (STACK_LOC (0))) = (FETCH_APPLY_TRAPPER ());
PUSH_APPLY_FRAME_HEADER (frame_size);
trapping = false;
}
#endif /* COMPILE_STEPPER */
Apply_Non_Trapping:
if (PENDING_INTERRUPTS_P)
{
unsigned long interrupts = (PENDING_INTERRUPTS ());
PREPARE_APPLY_INTERRUPT ();
SIGNAL_INTERRUPT (interrupts);
}
perform_application:
#ifdef APPLY_UCODE_HOOK
APPLY_UCODE_HOOK ();
#endif
{
SCHEME_OBJECT Function = (APPLY_FRAME_PROCEDURE ());
apply_dispatch:
switch (OBJECT_TYPE (Function))
{
case TC_ENTITY:
{
unsigned long frame_size = (APPLY_FRAME_SIZE ());
SCHEME_OBJECT data = (MEMORY_REF (Function, ENTITY_DATA));
if ((VECTOR_P (data))
&& (frame_size < (VECTOR_LENGTH (data)))
&& ((VECTOR_REF (data, frame_size)) != SHARP_F)
&& ((VECTOR_REF (data, 0))
== (VECTOR_REF (fixed_objects, ARITY_DISPATCHER_TAG))))
{
Function = (VECTOR_REF (data, frame_size));
(APPLY_FRAME_PROCEDURE ()) = Function;
goto apply_dispatch;
}
(STACK_REF (0)) = (MEMORY_REF (Function, ENTITY_OPERATOR));
PUSH_APPLY_FRAME_HEADER (frame_size);
/* This must be done to prevent an infinite push loop by
an entity whose handler is the entity itself or some
other such loop. Of course, it will die if stack overflow
interrupts are disabled. */
STACK_CHECK (0);
goto internal_apply;
}
case TC_PROCEDURE:
{
unsigned long frame_size = (APPLY_FRAME_SIZE ());
Function = (MEMORY_REF (Function, PROCEDURE_LAMBDA_EXPR));
{
SCHEME_OBJECT formals
= (MEMORY_REF (Function, LAMBDA_FORMALS));
if ((frame_size != (VECTOR_LENGTH (formals)))
&& (((OBJECT_TYPE (Function)) != TC_LEXPR)
|| (frame_size < (VECTOR_LENGTH (formals)))))
APPLICATION_ERROR (ERR_WRONG_NUMBER_OF_ARGUMENTS);
}
if (GC_NEEDED_P (frame_size + 1))
{
PREPARE_APPLY_INTERRUPT ();
IMMEDIATE_GC (frame_size + 1);
}
{
SCHEME_OBJECT * end = (Free + 1 + frame_size);
SCHEME_OBJECT env
= (MAKE_POINTER_OBJECT (TC_ENVIRONMENT, Free));
(*Free++) = (MAKE_OBJECT (TC_MANIFEST_VECTOR, frame_size));
(void) STACK_POP ();
while (Free < end)
(*Free++) = (STACK_POP ());
SET_ENV (env);
REDUCES_TO (MEMORY_REF (Function, LAMBDA_SCODE));
}
}
case TC_CONTROL_POINT:
if ((APPLY_FRAME_SIZE ()) != 2)
APPLICATION_ERROR (ERR_WRONG_NUMBER_OF_ARGUMENTS);
SET_VAL (* (APPLY_FRAME_ARGS ()));
unpack_control_point (Function);
RESET_HISTORY ();
goto pop_return;
/* After checking the number of arguments, remove the
frame header since primitives do not expect it.
NOTE: This code must match the application code which
follows primitive_internal_apply. */
case TC_PRIMITIVE:
if (!IMPLEMENTED_PRIMITIVE_P (Function))
APPLICATION_ERROR (ERR_UNIMPLEMENTED_PRIMITIVE);
{
unsigned long n_args = (APPLY_FRAME_N_ARGS ());
/* Note that the first test below will fail for lexpr
primitives. */
if (n_args != (PRIMITIVE_ARITY (Function)))
{
if ((PRIMITIVE_ARITY (Function)) != LEXPR_PRIMITIVE_ARITY)
APPLICATION_ERROR (ERR_WRONG_NUMBER_OF_ARGUMENTS);
SET_LEXPR_ACTUALS (n_args);
}
stack_pointer = (APPLY_FRAME_ARGS ());
SET_EXP (Function);
APPLY_PRIMITIVE_FROM_INTERPRETER (Function);
POP_PRIMITIVE_FRAME (n_args);
goto pop_return;
}
case TC_EXTENDED_PROCEDURE:
{
SCHEME_OBJECT lambda;
SCHEME_OBJECT temp;
unsigned long nargs;
unsigned long nparams;
unsigned long formals;
unsigned long params;
unsigned long auxes;
long rest_flag;
long size;
long i;
SCHEME_OBJECT * scan;
nargs = (POP_APPLY_FRAME_HEADER ());
lambda = (MEMORY_REF (Function, PROCEDURE_LAMBDA_EXPR));
Function = (MEMORY_REF (lambda, ELAMBDA_NAMES));
nparams = ((VECTOR_LENGTH (Function)) - 1);
Function = (Get_Count_Elambda (lambda));
formals = (Elambda_Formals_Count (Function));
params = ((Elambda_Opts_Count (Function)) + formals);
rest_flag = (Elambda_Rest_Flag (Function));
auxes = (nparams - (params + rest_flag));
if ((nargs < formals) || (!rest_flag && (nargs > params)))
{
PUSH_APPLY_FRAME_HEADER (nargs);
APPLICATION_ERROR (ERR_WRONG_NUMBER_OF_ARGUMENTS);
}
/* size includes the procedure slot, but not the header. */
size = (params + rest_flag + auxes + 1);
if (GC_NEEDED_P
(size + 1
+ ((nargs > params)
? (2 * (nargs - params))
: 0)))
{
PUSH_APPLY_FRAME_HEADER (nargs);
PREPARE_APPLY_INTERRUPT ();
IMMEDIATE_GC
(size + 1
+ ((nargs > params)
? (2 * (nargs - params))
: 0));
}
scan = Free;
temp = (MAKE_POINTER_OBJECT (TC_ENVIRONMENT, scan));
(*scan++) = (MAKE_OBJECT (TC_MANIFEST_VECTOR, size));
if (nargs <= params)
{
for (i = (nargs + 1); (--i) >= 0; )
(*scan++) = (STACK_POP ());
for (i = (params - nargs); (--i) >= 0; )
(*scan++) = DEFAULT_OBJECT;
if (rest_flag)
(*scan++) = EMPTY_LIST;
for (i = auxes; (--i) >= 0; )
(*scan++) = UNASSIGNED_OBJECT;
}
else
{
/* rest_flag must be true. */
SCHEME_OBJECT list
= (MAKE_POINTER_OBJECT (TC_LIST, (scan + size)));
for (i = (params + 1); (--i) >= 0; )
(*scan++) = (STACK_POP ());
(*scan++) = list;
for (i = auxes; (--i) >= 0; )
(*scan++) = UNASSIGNED_OBJECT;
/* Now scan == OBJECT_ADDRESS (list) */
for (i = (nargs - params); (--i) >= 0; )
{
(*scan++) = (STACK_POP ());
(*scan) = MAKE_POINTER_OBJECT (TC_LIST, (scan + 1));
scan += 1;
}
(scan[-1]) = EMPTY_LIST;
}
Free = scan;
SET_ENV (temp);
REDUCES_TO (Get_Body_Elambda (lambda));
}
#ifdef CC_SUPPORT_P
case TC_COMPILED_ENTRY:
{
guarantee_cc_return (1 + (APPLY_FRAME_SIZE ()));
dispatch_code = (apply_compiled_procedure ());
return_from_compiled_code:
switch (dispatch_code)
{
case PRIM_DONE:
goto pop_return;
case PRIM_APPLY:
goto internal_apply;
case PRIM_INTERRUPT:
SIGNAL_INTERRUPT (PENDING_INTERRUPTS ());
case PRIM_APPLY_INTERRUPT:
PREPARE_APPLY_INTERRUPT ();
SIGNAL_INTERRUPT (PENDING_INTERRUPTS ());
case ERR_INAPPLICABLE_OBJECT:
case ERR_WRONG_NUMBER_OF_ARGUMENTS:
APPLICATION_ERROR (dispatch_code);
default:
Do_Micro_Error (dispatch_code, true);
goto internal_apply;
}
}
#endif
default:
APPLICATION_ERROR (ERR_INAPPLICABLE_OBJECT);
}
}
case RC_JOIN_STACKLETS:
unpack_control_point (GET_EXP);
break;
case RC_NORMAL_GC_DONE:
SET_VAL (GET_EXP);
/* Paranoia */
if (GC_NEEDED_P (gc_space_needed))
termination_gc_out_of_space ();
gc_space_needed = 0;
EXIT_CRITICAL_SECTION ({ SAVE_CONT (); });
break;
case RC_PCOMB1_APPLY:
END_SUBPROBLEM ();
PUSH_VAL (); /* Argument value */
Finished_Eventual_Pushing (CONTINUATION_SIZE + STACK_ENV_FIRST_ARG);
SET_EXP (MEMORY_REF (GET_EXP, PCOMB1_FN_SLOT));
primitive_internal_apply:
#ifdef COMPILE_STEPPER
if (trapping
&& (!WITHIN_CRITICAL_SECTION_P ())
&& ((FETCH_APPLY_TRAPPER ()) != SHARP_F))
{
Will_Push (3);
PUSH_EXP ();
STACK_PUSH (FETCH_APPLY_TRAPPER ());
PUSH_APPLY_FRAME_HEADER (1 + (PRIMITIVE_N_PARAMETERS (GET_EXP)));
Pushed ();
trapping = false;
goto Apply_Non_Trapping;
}
#endif /* COMPILE_STEPPER */
/* NOTE: This code must match the code in the TC_PRIMITIVE
case of internal_apply.
This code is simpler because:
1) The arity was checked at syntax time.
2) We don't have to deal with "lexpr" primitives.
3) We don't need to worry about unimplemented primitives because
unimplemented primitives will cause an error at invocation. */
{
SCHEME_OBJECT primitive = GET_EXP;
APPLY_PRIMITIVE_FROM_INTERPRETER (primitive);
POP_PRIMITIVE_FRAME (PRIMITIVE_ARITY (primitive));
break;
}
case RC_PCOMB2_APPLY:
END_SUBPROBLEM ();
PUSH_VAL (); /* Value of arg. 1 */
Finished_Eventual_Pushing (CONTINUATION_SIZE + STACK_ENV_FIRST_ARG);
SET_EXP (MEMORY_REF (GET_EXP, PCOMB2_FN_SLOT));
goto primitive_internal_apply;
case RC_PCOMB2_DO_1:
POP_ENV ();
PUSH_VAL (); /* Save value of arg. 2 */
DO_ANOTHER_THEN (RC_PCOMB2_APPLY, PCOMB2_ARG_1_SLOT);
case RC_PCOMB3_APPLY:
END_SUBPROBLEM ();
PUSH_VAL (); /* Save value of arg. 1 */
Finished_Eventual_Pushing (CONTINUATION_SIZE + STACK_ENV_FIRST_ARG);
SET_EXP (MEMORY_REF (GET_EXP, PCOMB3_FN_SLOT));
goto primitive_internal_apply;
case RC_PCOMB3_DO_1:
{
SCHEME_OBJECT Temp = (STACK_POP ()); /* Value of arg. 3 */
POP_ENV ();
STACK_PUSH (Temp); /* Save arg. 3 again */
PUSH_VAL (); /* Save arg. 2 */
DO_ANOTHER_THEN (RC_PCOMB3_APPLY, PCOMB3_ARG_1_SLOT);
}
case RC_PCOMB3_DO_2:
SET_ENV (STACK_REF (0));
PUSH_VAL (); /* Save value of arg. 3 */
DO_ANOTHER_THEN (RC_PCOMB3_DO_1, PCOMB3_ARG_2_SLOT);
case RC_POP_RETURN_ERROR:
case RC_RESTORE_VALUE:
SET_VAL (GET_EXP);
break;
/* The following two return codes are both used to restore a
saved history object. The difference is that the first does
not copy the history object while the second does. In both
cases, the GET_EXP contains the history object and the
next item to be popped off the stack contains the offset back
to the previous restore history return code. */
case RC_RESTORE_DONT_COPY_HISTORY:
{
prev_restore_history_offset = (OBJECT_DATUM (STACK_POP ()));
(void) STACK_POP ();
history_register = (OBJECT_ADDRESS (GET_EXP));
break;
}
case RC_RESTORE_HISTORY:
{
if (!restore_history (GET_EXP))
{
SAVE_CONT ();
Will_Push (CONTINUATION_SIZE);
SET_EXP (GET_VAL);
SET_RC (RC_RESTORE_VALUE);
SAVE_CONT ();
Pushed ();
IMMEDIATE_GC (HEAP_AVAILABLE);
}
prev_restore_history_offset = (OBJECT_DATUM (STACK_POP ()));
(void) STACK_POP ();
if (prev_restore_history_offset > 0)
(STACK_LOCATIVE_REFERENCE (STACK_BOTTOM,
(-prev_restore_history_offset)))
= (MAKE_RETURN_CODE (RC_RESTORE_HISTORY));
break;
}
case RC_RESTORE_INT_MASK:
SET_INTERRUPT_MASK (UNSIGNED_FIXNUM_TO_LONG (GET_EXP));
if (GC_NEEDED_P (0))
REQUEST_GC (0);
if (PENDING_INTERRUPTS_P)
{
SET_RC (RC_RESTORE_VALUE);
SET_EXP (GET_VAL);
SAVE_CONT ();
SIGNAL_INTERRUPT (PENDING_INTERRUPTS ());
}
break;
case RC_STACK_MARKER:
/* Frame consists of the return code followed by two objects.
The first object has already been popped into GET_EXP,
so just pop the second argument. */
stack_pointer = (STACK_LOCATIVE_OFFSET (stack_pointer, 1));
break;
case RC_SEQ_2_DO_2:
END_SUBPROBLEM ();
POP_ENV ();
REDUCES_TO_NTH (SEQUENCE_2);
case RC_SEQ_3_DO_2:
SET_ENV (STACK_REF (0));
DO_ANOTHER_THEN (RC_SEQ_3_DO_3, SEQUENCE_2);
case RC_SEQ_3_DO_3:
END_SUBPROBLEM ();
POP_ENV ();
REDUCES_TO_NTH (SEQUENCE_3);
case RC_SNAP_NEED_THUNK:
/* Don't snap thunk twice; evaluation of the thunk's body might
have snapped it already. */
if ((MEMORY_REF (GET_EXP, THUNK_SNAPPED)) == SHARP_T)
SET_VAL (MEMORY_REF (GET_EXP, THUNK_VALUE));
else
{
MEMORY_SET (GET_EXP, THUNK_SNAPPED, SHARP_T);
MEMORY_SET (GET_EXP, THUNK_VALUE, GET_VAL);
}
break;
default:
POP_RETURN_ERROR (ERR_INAPPLICABLE_CONTINUATION);
}
/*
* Send an already-opened file to the client with variable substitution.
*/
int
send_html_file (FILE *infile, struct conn_s *connptr)
{
char *inbuf;
char *varstart = NULL;
char *p;
const char *varval;
int in_variable = 0;
int r = 0;
inbuf = (char *) safemalloc (4096);
while (fgets (inbuf, 4096, infile) != NULL) {
for (p = inbuf; *p; p++) {
switch (*p) {
case '}':
if (in_variable) {
*p = '\0';
varval = (const char *)
lookup_variable (connptr,
varstart);
if (!varval)
varval = "(unknown)";
r = write_message (connptr->client_fd,
"%s", varval);
in_variable = 0;
} else {
r = write_message (connptr->client_fd,
"%c", *p);
}
break;
case '{':
/* a {{ will print a single {. If we are NOT
* already in a { variable, then proceed with
* setup. If we ARE already in a { variable,
* this code will fallthrough to the code that
* just dumps a character to the client fd.
*/
if (!in_variable) {
varstart = p + 1;
in_variable++;
} else
in_variable = 0;
default:
if (!in_variable) {
r = write_message (connptr->client_fd,
"%c", *p);
}
}
if (r)
break;
}
if (r)
break;
in_variable = 0;
}
safefree (inbuf);
return r;
}
exprtree*
make_function (scanner_ident_t *name_ident, exprtree *args)
{
char *name = name_ident->str;
scanner_region_t name_region = name_ident->region;
exprtree *tree = 0;
exprtree *arg;
function_arg_info_t *first, *last;
overload_entry_t *entry;
tuple_info_t info;
if (lookup_userval(the_mathmap->current_filter->userval_infos, name) != 0)
{
userval_info_t *info = lookup_userval(the_mathmap->current_filter->userval_infos, name);
return make_userval(info, args, name_region);
}
if (lookup_filter(the_mathmap->filters, name) != 0)
{
filter_t *filter = lookup_filter(the_mathmap->filters, name);
return make_filter_call(filter, args, name_region);
}
first = last = (function_arg_info_t*)malloc(sizeof(function_arg_info_t));
arg = args;
last->info = arg->result;
last->next = 0;
while (arg->next != 0)
{
arg = arg->next;
last = last->next = (function_arg_info_t*)malloc(sizeof(function_arg_info_t));
last->info = arg->result;
last->next = 0;
}
entry = resolve_function_call(name, first, &info);
if (entry != 0)
{
if (entry->type == OVERLOAD_BUILTIN)
{
int is_constant = 1;
for (arg = args; arg != 0; arg = arg->next)
if (arg->type != EXPR_TUPLE_CONST)
{
is_constant = 0;
break;
}
tree = alloc_exprtree();
tree->type = EXPR_FUNC;
tree->val.func.entry = entry;
tree->val.func.args = args;
tree->result = info;
}
else if (entry->type == OVERLOAD_MACRO)
tree = entry->v.macro(args);
else
g_assert_not_reached();
tree->region = scanner_region_merge(name_region, exprlist_region(args));
}
else if (lookup_variable(the_mathmap->current_filter->v.mathmap.variables, name, &info))
{
variable_t *var = lookup_variable(the_mathmap->current_filter->v.mathmap.variables, name, &info);
if (info.number != image_tag_number
|| info.length != 1)
{
sprintf(error_string, _("Variable %s is not an image and cannot be invoked."), name);
error_region = name_region;
JUMP(1);
}
return make_image_call(make_var_exprtree(var, info, name_region), args, name_region);
} else {
const char *op_name = get_op_name_for_func(name);
if (op_name)
sprintf(error_string, _("Unable to resolve invocation of operator `%s'."), op_name);
else
sprintf(error_string, _("Unable to resolve invocation of function `%s'."), name);
error_region = name_region;
JUMP(1);
}
return tree;
}
int
set_variable(char *variable, int on, char *val_string)
{
int value;
register struct variable_defs *var;
if (strncmp(variable, "no", 2) == 0) {
on = !on;
variable += 2;
if (variable[0] == '-')
variable++;
}
if ((var = lookup_variable(variable)) == NULL)
return 0;
if (!in_init && (var->var_flags & (V_INIT | V_SAFE))) {
if (var->var_flags & V_INIT) {
msg("'%s' can only be set in the init file", variable);
return 0;
}
if (shell_restrictions) {
msg("Restricted operation - cannot change");
return 0;
}
}
if (var->var_flags & V_LOCKED) {
msg("Variable '%s' is locked", variable);
return 0;
}
if (!on || val_string == NULL)
value = 0;
else
value = atoi(val_string);
var->var_flags |= V_MODIFIED;
switch (VAR_TYPE) {
case V_STRING:
if (on)
adjust(val_string);
switch (VAR_OP) {
case 0:
STR_VAR = (on && val_string) ? copy_str(val_string) : (char *) NULL;
break;
case 1:
strcpy(CBUF_VAR, (on && val_string) ? val_string : "");
break;
case 2:
if (on) {
char exp_buf[FILENAME];
if (val_string) {
if (expand_file_name(exp_buf, val_string, 1))
STR_VAR = home_relative(exp_buf);
}
} else
STR_VAR = (char *) NULL;
break;
case 3:
case 4:
if (!on || val_string == NULL) {
msg("Cannot unset string `%s'", variable);
break;
}
if (VAR_OP == 4) {
char exp_buf[FILENAME];
if (expand_file_name(exp_buf, val_string, 1)) {
STR_VAR = copy_str(exp_buf);
break;
}
}
STR_VAR = copy_str(val_string);
break;
case 5:
STR_VAR = (on && val_string) ? copy_str(val_string) : "";
break;
}
break;
case V_BOOLEAN:
adjust(val_string);
if (val_string && *val_string != NUL) {
if (val_string[0] == 'o')
on = val_string[1] == 'n'; /* on */
else
on = val_string[0] == 't'; /* true */
}
switch (VAR_OP) {
case 0:
BOOL_VAR = on;
break;
case 1:
BOOL_VAR = on;
return 1;
case 2:
if (BOOL_VAR) { /* don't change if already ok */
if (!on)
break;
} else if (on)
break;
BOOL_VAR = !on;
if (!in_init) {
sort_articles(BOOL_VAR ? 0 : -1);
return 1;
}
break;
case 4:
BOOL_VAR = !on;
break;
}
break;
case V_INTEGER:
switch (VAR_OP) {
case 0:
case 1:
INT_VAR = value;
break;
case 2:
case 3:
if (!on)
value = -1;
INT_VAR = value;
break;
}
return (VAR_OP & 1);
case V_KEY:
switch (VAR_OP) {
case 0:
if (val_string) {
if (*val_string)
adjust(val_string + 1); /* #N is valid */
KEY_VAR = parse_key(val_string);
}
break;
}
break;
case V_SPECIAL:
switch (VAR_OP) {
case 1:
if (val_string) {
adjust(val_string);
news_record = home_relative(val_string);
mail_record = news_record;
var->var_flags &= ~V_MODIFIED;
lookup_variable("mail-record")->var_flags |= V_MODIFIED;
lookup_variable("news-record")->var_flags |= V_MODIFIED;
}
break;
case 2:
also_read_articles = on;
article_limit = (on && value > 0) ? value : -1;
break;
case 3:
{
struct chset *csp;
struct variable_defs *dbvar;
dbvar = lookup_variable("data-bits");
if (on && val_string) {
if ((csp = getchset(val_string)) == NULL)
msg("Illegal value for `%s' variable", variable);
else {
curchset = csp;
data_bits = csp->cs_width ? csp->cs_width : 7;
dbvar->var_flags &= ~V_MODIFIED;
}
} else
msg("Cannot unset special `%s' variable", variable);
}
break;
}
break;
case V_CODES:
{
char codes[80], code[16], *sp, *cp, *vs;
if (val_string == NULL)
on = 0;
if (on) {
adjust(val_string);
if (val_string[0] == NUL)
on = 0;
}
if (on) {
sp = codes;
vs = val_string;
while (*vs) {
while (*vs && (!isascii(*vs) || isspace(*vs)))
vs++;
if (*vs == NUL)
break;
cp = code;
while (*vs && isascii(*vs) && !isspace(*vs))
*cp++ = *vs++;
*cp = NUL;
*sp++ = parse_key(code);
}
*sp = NUL;
if (codes[0] == NUL)
on = 0;
}
freeobj(code_strings[VAR_OP]);
code_strings[VAR_OP] = on ? copy_str(val_string) : NULL;
STR_VAR = on ? copy_str(codes) : (char *) NULL;
break;
}
}
return 0;
}
