/*---------------------------------------------------------------------------
* Purpose: Register a documentation string with the switch.
*
* Programmer: Robb Matzke
* Wednesday, May 31, 2000
*
* Modifications:
*---------------------------------------------------------------------------
*/
void
switch_doc(switch_t *sw, const char *doc_string)
{
char *fulldoc = (char *)malloc(8192);
/* Set switch info */
if (!sw) sw = switch_latest;
if (sw->doc_string) free(sw->doc_string);
sw->doc_string = safe_strdup(doc_string);
/* Build browser documentation string */
switch_synopsis(sw, fulldoc);
strcat(fulldoc, "\n");
strcat(fulldoc, doc_string);
/* Assign browser documentation string to symbols */
if (sw->short_name) {
obj_t symbol = obj_new(C_SYM, sw->short_name);
obj_t docstr = obj_new(C_STR, fulldoc);
sym_dbind(symbol, docstr);
obj_dest(symbol);
}
if (sw->long_name) {
obj_t symbol = obj_new(C_SYM, sw->long_name);
obj_t docstr = obj_new(C_STR, fulldoc);
sym_dbind(symbol, docstr);
obj_dest(symbol);
}
free(fulldoc);
}
/*------------------------------------------------------------------------- * Function: ptr_bind * * Purpose: Binds array dimensions to numeric values. * * Return: Success: SELF * * Failure: NIL * * Programmer: Robb Matzke * [email protected] * Jan 13 1997 * * Modifications: * *------------------------------------------------------------------------- */ static obj_t ptr_bind (obj_t _self, void *mem) { obj_ptr_t *self = MYCLASS(_self); obj_t name=NIL, val=NIL, x=NIL; int i; if (C_STR==self->sub->pub.cls) { name = obj_new (C_SYM, obj_name(self->sub)); x = sym_vboundp (name); name = obj_dest (name); val = obj_copy (x, DEEP); /*so we can modify it*/ x = obj_dest (x); /* * We're being tricky here. By assigning a new value to the `sub' * field we're modifying all the expressions that share this cell. * We must insure that the correct reference count is imparted * to the new subtype. */ for (i=1; i<self->pub.ref; i++) { x = obj_copy (val, SHALLOW); assert (x==val); } if (val) self->sub = val; } return obj_bind (self->sub, mem ? *((void**)mem) : NULL); }
/*------------------------------------------------------------------------- * Function: bif * * Purpose: Installs a builtin function in the symbol table. * * Return: void * * Programmer: Robb Matzke * [email protected] * Dec 4 1996 * * Modifications: * Robb Matzke, 2000-06-06 * Added the DESC and DOC arguments. DESC is an optional * one-line description to be added to the function table of * contents. DOC is a multi-line documentation string. *------------------------------------------------------------------------- */ static void bif (const char *func_name, obj_t(*func_ptr)(int x, obj_t y[]), int flags, const char *desc, const char *doc) { obj_t name = func_name?obj_new(C_SYM, func_name):NIL; obj_t func = func_ptr?obj_new(C_BIF, func_ptr, flags):NIL; /* Bind the function to the symbol */ if (name) sym_fbind(name, func); /* Function table of contents */ if (name && desc) { HelpFuncToc[NHelpFuncToc].name = safe_strdup(func_name); HelpFuncToc[NHelpFuncToc].desc = safe_strdup(desc); NHelpFuncToc++; } /* Operator table of contents. Operators are added to the operator * table of contents if the description contains the string `operator' * and the operators are listed in quotes like `this'. */ if (desc && strstr(desc, "operator")) { const char *s=desc, *first, *last; while ((first=strchr(s, '`')) && (last=strchr(++first, '\''))) { char opname[64]; strcpy(opname, "op"); strncpy(opname+2, first, last-first); opname[2+last-first] = '\0'; if (opname[2]) { if (doc) { obj_t sym = obj_new(C_SYM, opname); obj_t docval = obj_new(C_STR, doc); sym_dbind(sym, docval); obj_dest(sym); } strcpy(opname, "\"op"); strncpy(opname+3, first, last-first); strcpy(opname+(3+last-first), "\""); HelpOpToc[NHelpOpToc].name = safe_strdup(opname); HelpOpToc[NHelpOpToc].desc = safe_strdup(desc); NHelpOpToc++; } s = last+1; } } /* Bind the documentation string to the symbol */ if (name && doc) { obj_t docval = obj_new(C_STR, doc); sym_dbind(name, docval); } if (name) obj_dest (name); /*dont destroy func or doc*/ }
/*------------------------------------------------------------------------- * Function: sym_eval * * Purpose: Returns the variable value of a symbol if it has one. * * Return: Success: Ptr to a copy of the variable value. * * Failure: NIL * * Programmer: Robb Matzke * [email protected] * Dec 4 1996 * * Modifications: * Robb Matzke, 4 Feb 1997 * Fixed the arguments for the obj_deref() call. * * Robb Matzke, 2000-07-03 * The symbol `$*' evaluates to a list of all $N files for * consecutive N beginning at 1. *------------------------------------------------------------------------- */ static obj_t sym_eval (obj_t _self) { obj_t name_1=NIL, file_1=NIL, retval=NIL; obj_sym_t *self = MYCLASS(_self); /* If the symbol has a variable value then return it. */ if (MYCLASS(_self)->sym->var) { return obj_copy (MYCLASS(_self)->sym->var, SHALLOW); } /* The symbol `$*' evaluates to a list of the first consecutive files * bound to the $N symbols. */ if (!strcmp(self->sym->name, "$*")) { obj_t opands[1024], retval; int nopands, i; for (nopands=0; nopands<NELMTS(opands); nopands++) { obj_t symbol; char tmp[32]; sprintf(tmp, "$%d", nopands+1); symbol = obj_new(C_SYM, tmp); opands[nopands] = sym_vboundp(symbol); obj_dest(symbol); if (!opands[nopands] || C_FILE!=opands[nopands]->pub.cls) { /* We reached the last file or something isn't a file */ obj_dest(opands[nopands]); break; } } retval = V_make_list(nopands, opands); for (i=0; i<nopands; i++) { obj_dest(opands[i]); } return retval; } /* If the symbol exists in the first data file, then return * that SDO. */ name_1 = obj_new (C_SYM, "$1"); file_1 = MYCLASS(name_1)->sym->var; name_1 = obj_dest (name_1); if (file_1 && C_FILE==file_1->pub.cls) { retval = obj_deref (file_1, 1, &_self); return retval; } /* Symbol has no value. */ out_errorn ("eval: variable `%s' has no value", obj_name(_self)); return NIL; }
/*------------------------------------------------------------------------- * Function: parse_assignment * * Purpose: Parses an assignment statement of the form * * LVALUE = RVALUE * * Return: Success: the resulting parse tree. * * Failure: &ErrorCell * * Programmer: Robb Matzke * [email protected] * Feb 7 1997 * * Modifications: * *------------------------------------------------------------------------- */ static obj_t parse_assignment (lex_t *f, int skipnl) { obj_t rt=NIL, retval=NIL; retval = parse_selection (f, skipnl); if (&ErrorCell==retval) return &ErrorCell; if (TOK_EQ==lex_token (f, NULL, skipnl)) { lex_consume (f); rt = parse_selection (f, skipnl); if (&ErrorCell==rt) { obj_dest(retval); return &ErrorCell; } retval = obj_new (C_CONS, obj_new (C_SYM, "Assign"), obj_new (C_CONS, retval, obj_new (C_CONS, rt, NIL))); } return retval; }
/*------------------------------------------------------------------------- * Function: parse_dot * * Purpose: Tries to parse an expression followed by the dot operator * followed by another expression. If the dot is not present * then just the left operand is returned. * * Return: Success: The expression. * * Failure: &ErrorCell * * Programmer: Robb Matzke * [email protected] * Dec 5 1996 * * Modifications: * *------------------------------------------------------------------------- */ static obj_t parse_dot (lex_t *f, int skipnl) { obj_t rt=NIL, retval=NIL; retval = parse_range (f, skipnl); if (&ErrorCell==retval) return &ErrorCell; while (TOK_DOT==lex_token(f, NULL, skipnl)) { lex_consume (f); rt = parse_range (f, skipnl); if (&ErrorCell==rt) { obj_dest (retval); return &ErrorCell; } retval = obj_new (C_CONS, obj_new (C_SYM, "Dot"), obj_new (C_CONS, retval, obj_new (C_CONS, rt, NIL))); } return retval; }
/*---------------------------------------------------------------------------
* Purpose: Binds a documentation value to a symbol w/o copying the
* value. Any previous documentation is destroyed.
*
* Programmer: Robb Matzke
* Friday, June 2, 2000
*
* Modifications:
*---------------------------------------------------------------------------
*/
void
sym_dbind(obj_t _self, obj_t value)
{
obj_sym_t *self = MYCLASS(_self);
assert(C_SYM==self->pub.cls);
if (self->sym->doc) obj_dest(self->sym->doc);
self->sym->doc = value;
}
/*------------------------------------------------------------------------- * Function: sym_vbind * * Purpose: Binds a value to a symbol w/o copying the value. Any * previous value is destroyed. * * Return: void * * Programmer: Robb Matzke * [email protected] * Dec 4 1996 * * Modifications: * *------------------------------------------------------------------------- */ void sym_vbind (obj_t _self, obj_t value) { obj_sym_t *self = MYCLASS(_self); if (self->sym->var) obj_dest (self->sym->var); self->sym->var = value; }
/*------------------------------------------------------------------------- * Function: sym_fbind * * Purpose: Binds a function to a symbol. * * Return: void * * Programmer: Robb Matzke * [email protected] * Dec 4 1996 * * Modifications: * *------------------------------------------------------------------------- */ void sym_fbind (obj_t _self, obj_t func) { obj_sym_t *self = MYCLASS(_self); if (self->sym->func) obj_dest (self->sym->func); self->sym->func = func; }
/*------------------------------------------------------------------------- * Function: ptr_dest * * Purpose: Destroys a pointer type object. * * Return: Success: NIL * * Failure: NIL * * Programmer: Robb Matzke * [email protected] * Dec 6 1996 * * Modifications: * *------------------------------------------------------------------------- */ static obj_t ptr_dest (obj_t _self) { obj_ptr_t *self = MYCLASS(_self); obj_dest (self->sub); if (0==self->pub.ref) memset (self, 0, sizeof(obj_ptr_t)); return NIL; }
/*------------------------------------------------------------------------- * Function: parse_range * * Purpose: Tries to parse a range expression of the form `I1:I2' * where I1 and I2 are integer constants. * * Return: Success: A range object. * * Failure: &ErrorCell * * Programmer: Robb Matzke * [email protected] * Jan 3 1997 * * Modifications: * *------------------------------------------------------------------------- */ static obj_t parse_range (lex_t *f, int skipnl) { obj_t lt=NIL, rt=NIL, retval=NIL; int lo, hi; lt = parse_term (f, skipnl); if (&ErrorCell==lt) return &ErrorCell; if (TOK_COLON==lex_token (f, NULL, skipnl)) { lex_consume (f); rt = parse_term (f, skipnl); if (&ErrorCell==rt) { obj_dest (rt); return &ErrorCell; } /* * Both arguments must be integer constants. */ if (!num_isint(lt)) { out_error ("Range: left limit is not an integer constant: ", lt); obj_dest (lt); obj_dest (rt); return &ErrorCell; } if (!num_isint(rt)) { out_error ("Range: right limit is not an integer constant: ", rt); obj_dest (lt); obj_dest (rt); return &ErrorCell; } /* * The constants must be in a reasonable order. */ lo = num_int (lt); hi = num_int (rt); if (hi<lo) { out_errorn ("Range: inverted range %d:%d changed to %d:%d", lo, hi, hi, lo); lo = num_int (rt); hi = num_int (lt); } /* * Create the range object. */ lt = obj_dest (lt); rt = obj_dest (rt); retval = obj_new (C_RANGE, lo, hi); } else { retval = lt; } return retval; }
/*---------------------------------------------------------------------------
* Purpose: Return the string value of a builtin symbol.
*
* Return: Copy of the string value or NULL
*
* Programmer: Robb Matzke
* Friday, June 2, 2000
*
* Modifications:
*---------------------------------------------------------------------------
*/
char *
sym_bi_gets(const char *name)
{
char fullname[1024], *retval;
obj_t var, val;
/* Add built-in prefix */
if (*name!='$') {
fullname[0] = '$';
strcpy(fullname+1, name);
name = fullname;
}
var = obj_new(C_SYM, name);
val = sym_vboundp(var);
var = obj_dest(var);
retval = safe_strdup(obj_name(val));
obj_dest(val);
return retval;
}
/*------------------------------------------------------------------------- * Function: sym_truth * * Purpose: Returns true if the symbol has a variable value which * is true. * * Return: Success: true * * Failure: false * * Programmer: Robb Matzke * [email protected] * Feb 7 1997 * * Modifications: * *------------------------------------------------------------------------- */ int sym_truth (char *name) { obj_sym_t *self=NULL; int retval; if (!name || !*name) return false; self = (obj_sym_t *)obj_new (C_SYM, name); retval = obj_truth (self->sym->var); obj_dest ((obj_t)self); return retval; }
/*---------------------------------------------------------------------------
* Purpose: Convenience function for setting the documentation string
* of some symbol.
*
* Programmer: Robb Matzke
* Tuesday, June 6, 2000
*
* Modifications:
*---------------------------------------------------------------------------
*/
void
sym_doc(const char *symname, const char *docstr)
{
obj_t sym = obj_new(C_SYM, symname);
if (docstr) {
obj_t doc = obj_new(C_STR, docstr);
sym_dbind(sym, doc);
} else {
sym_dbind(sym, NIL);
}
obj_dest(sym);
}
/*---------------------------------------------------------------------------
* Purpose: Invokes function FUNC on each defined symbol.
*
* Programmer: Robb Matzke
* Wednesday, June 7, 2000
*
* Modifications:
*---------------------------------------------------------------------------
*/
int
sym_map(int(*func)(obj_t, void*), void *cdata)
{
int i, retval=0;
for (i=0; i<NSymbols; i++) {
if (Symbol[i].name) {
obj_t sym = obj_new(C_SYM, Symbol[i].name);
retval += (func)(sym, cdata);
obj_dest(sym);
}
}
return retval;
}
/*---------------------------------------------------------------------------
* Purpose: Returns the integer value of a built-in symbol. If the
* symbol is set to something not an integer then return 1.
*
* Programmer: Robb Matzke
* Thursday, June 1, 2000
*
* Modifications:
*---------------------------------------------------------------------------
*/
int
sym_bi_true(const char *name)
{
char fullname[1024];
int retval;
obj_t var_name, val;
/* Add built-in prefix */
if (*name!='$') {
fullname[0] = '$';
strcpy(fullname+1, name);
name = fullname;
}
/* Get value */
var_name = obj_new(C_SYM, name);
val = sym_vboundp(var_name);
var_name = obj_dest(var_name);
if (num_isint(val)) retval = num_int(val);
else retval = val ? 1 : 0;
val = obj_dest (val);
return retval;
}
/*------------------------------------------------------------------------- * Function: ptr_apply * * Purpose: Applying a pointer type to an argument list consisting of * a single SILO database object (SDO) causes the object to * be cast to that type. * * Return: Success: Ptr to a new SDO object with the appropriate * type. * * Failure: NIL * * Programmer: Robb Matzke * [email protected] * Dec 6 1996 * * Modifications: * *------------------------------------------------------------------------- */ static obj_t ptr_apply (obj_t _self, obj_t args) { obj_t sdo=NIL, retval=NIL; if (1!=F_length(args)) { out_errorn ("typecast: wrong number of arguments"); return NIL; } sdo = obj_eval (cons_head (args)); retval = sdo_cast (sdo, _self); obj_dest (sdo); return retval; }
/*---------------------------------------------------------------------------
* Purpose: Set a builtin symbol to the specified value. If VALUE
* looks like a number then it is treated as such, otherwise
* the symbol is assigned a string value.
*
* If NAME does not begin with the standard prefix used for
* builtin variables then it will be automatically added.
*
* Programmer: Robb Matzke
* Thursday, June 1, 2000
*
* Modifications:
*---------------------------------------------------------------------------
*/
void
sym_bi_set(const char *name, const char *value, const char *desc,
const char *doc)
{
char fullname[1024], *rest;
obj_t symbol;
/* Add built-in prefix */
if (*name!='$') {
fullname[0] = '$';
strcpy(fullname+1, name);
name = fullname;
}
symbol = obj_new(C_SYM, name);
/* Does value look like a number or a string? */
if (!value || !*value) {
sym_vbind(symbol, NIL);
} else {
strtod(value, &rest);
if (rest && *rest) {
sym_vbind(symbol, obj_new(C_STR, value));
} else {
sym_vbind(symbol, obj_new(C_NUM, value));
}
}
/* Description for var table of contents */
if (desc) {
HelpVarToc[NHelpVarToc].name = safe_strdup(name);
HelpVarToc[NHelpVarToc].desc = safe_strdup(desc);
NHelpVarToc++;
}
/* The documentation string */
if (doc) sym_dbind(symbol, obj_new(C_STR, doc));
obj_dest(symbol);
}
/*------------------------------------------------------------------------- * Function: lex_token * * Purpose: Figures out what token is next on the input stream. If * skipnl is non-zero then the new-line token is skipped. * * Return: Success: Token number, optional lexeme returned * through the LEXEME argument. * * Failure: TOK_INVALID * * Programmer: Robb Matzke * [email protected] * Dec 4 1996 * * Modifications: * * Robb Matzke, 3 Feb 1997 * Cleaned up error messages. * * Robb Matzke, 7 Feb 1997 * Added the `=' token. * * Robb Matzke, 7 Feb 1997 * The `*' and `?'characters are now legal as part of a symbol name * so we can give those pattern matching characters to the `ls' * command. * * Robb Matzke, 12 Mar 1997 * Since we don't have mathematical expressions yet, a numeric * constant is allowed to begin with a `-'. * * Robb Matzke, 2000-06-06 * Symbol names may include `-'. Something that starts with a `-' is * only a number if it's followed by a digit. * * Mark C. Miller, Mon Nov 9 18:08:05 PST 2009 * Added logic to support parsing of '#nnnnnn' dataset names, * but only when in '/.silo' dir. *------------------------------------------------------------------------- */ int lex_token(lex_t *f, char **lexeme, int skipnl) { int c, at, quote, inDotSiloDir=0; static const char *symcharsA = "_$/*?"; static const char *symcharsB = "_$/*?#"; const char *symchars = symcharsA; /* Return the current token if appropriate. */ if (f->tok && (!skipnl || TOK_EOL!=f->tok)) { if (lexeme) *lexeme = f->lexeme; return f->tok; } /* Skip leading space. */ f->prompt = skipnl ? LEX_PROMPT2 : LEX_PROMPT; while (EOF!=(c=lex_getc(f)) && '\n'!=c && isspace(c)) /*void*/; /* handle special case of leading '#' and see if we're in .silo dir */ if ('#'==c) { obj_t f1, val; DBfile *file; char cwd[1024]; f1 = obj_new (C_SYM, "$1"); val = sym_vboundp (f1); f1 = obj_dest (f1); if (NULL!=(file=file_file(val)) && DBGetDir(file, cwd)>=0 && !strncmp(cwd,"/.silo",6)) { inDotSiloDir = 1; symchars = symcharsB; } } /* Store the next token. */ if (EOF==c) { f->lexeme[0] = '\0'; f->tok = EOF; } else if ('\n'==c) { if (skipnl) { f->tok = lex_token(f, NULL, true); } else { f->lexeme[0] = '\n'; f->lexeme[1] = '\0'; f->tok = TOK_EOL; } } else if ('#'==c && !inDotSiloDir) { while (EOF!=(c=lex_getc(f)) && '\n'!=c) /*void*/; lex_ungetc(f, c); return lex_token(f, lexeme, skipnl); } else if ('>'==c) { c = lex_getc(f); if ('>'==c) { strcpy(f->lexeme, ">>"); f->tok = TOK_RTRT; } else { lex_ungetc(f, c); strcpy(f->lexeme, ">"); f->tok = TOK_RT; } } else if (strchr("|.()[]{}:,=", c)) { f->lexeme[0] = c; f->lexeme[1] = '\0'; f->tok = c; } else if (isalpha(c) || strchr(symchars,c)) { /* A symbol. */ f->lexeme[0] = c; f->lexeme[1] = '\0'; at = 1; while (EOF!=(c=lex_getc(f)) && (isalpha(c) || isdigit(c) || strchr(symchars, c))) { if (at+1<sizeof(f->lexeme)) { f->lexeme[at++] = c; f->lexeme[at] = '\0'; } } lex_ungetc(f, c); f->tok = TOK_SYM; } else if ('-'==c) { /* Could be a number or a symbol */ f->lexeme[0] = c; f->lexeme[1] = '\0'; if (EOF!=(c=lex_getc(f)) && ('.'==c || isdigit(c))) { f->lexeme[1] = c; f->lexeme[2] = '\0'; at = 2; while (EOF!=(c=lex_getc(f)) && (isdigit(c) || strchr("+-.eE", c))) { if (at+1<sizeof(f->lexeme)) { f->lexeme[at++] = c; f->lexeme[at] = '\0'; } } lex_ungetc(f, c); f->tok = TOK_NUM; } else { at=1; while (EOF!=c && (isalpha(c) || isdigit(c) || strchr("_$/*?-", c))) { if (at+1<sizeof(f->lexeme)) { f->lexeme[at++] = c; f->lexeme[at] = '\0'; } c = lex_getc(f); } lex_ungetc(f, c); f->tok = TOK_SYM; } } else if ('-'==c || isdigit(c)) { /* A number */ f->lexeme[0] = c; f->lexeme[1] = '\0'; at = 1; while (EOF!=(c=lex_getc(f)) && (isdigit(c) || strchr("+-.eE", c))) { if (at+1<sizeof(f->lexeme)) { f->lexeme[at++] = c; f->lexeme[at] = '\0'; } } lex_ungetc(f, c); f->tok = TOK_NUM; } else if ('"'==c || '\''==c) { /* A string */ quote = c; at = 0; f->lexeme[0] = '\0'; while (EOF!=(c=lex_getc(f)) && quote!=c && '\n'!=c) { if ('\\'==c) { switch ((c=lex_getc(f))) { case 'b': c = '\b'; break; case 'n': c = '\n'; break; case 'r': c = '\r'; break; case 't': c = '\t'; break; case EOF: c = '\\'; break; default: if (c>='0' && c<='7') { int c2 = lex_getc(f); if (c2>='0' && c2<='7') { int c3 = lex_getc(f); if (c3>='0' && c3<='7') { c = ((c-'0')*8+c2-'0')*8+c3-'0'; } else { lex_ungetc(f, c3); c = (c-'0')*8+c2-'0'; } } else { lex_ungetc(f, c2); c -= '0'; } } break; } } if (at+1<sizeof(f->lexeme)) { f->lexeme[at++] = c; f->lexeme[at] = '\0'; } } if ('\n'==c) { out_errorn("linefeed inside string constant (truncated at EOL)"); lex_ungetc(f, c); } else if (c<0) { out_errorn("EOF inside string constant (truncated at EOF)"); } f->tok = TOK_STR; } else { /* Invalid character. Don't print an error message since a * syntax error will result in the parser anyway. */ f->lexeme[0] = c; f->lexeme[1] = '\0'; f->tok = TOK_INVALID; } if (lexeme) *lexeme = f->lexeme; return f->tok; }
/*------------------------------------------------------------------------- * Function: parse_subscripts * * Purpose: Parses a subscripted expression. The subscript is * enclosed in `[' and `]' after the main expression. * * Return: Success: Ptr to the expression. * * Failure: &ErrorCell * * Programmer: Robb Matzke * [email protected] * Jan 3 1997 * * Modifications: * * Robb Matzke, 4 Feb 1997 * The contents of the `[]' can now be a comma-separated list * of expressions. * *------------------------------------------------------------------------- */ static obj_t parse_selection (lex_t *f, int skipnl) { obj_t retval=NIL; /*first argument, left of `[' */ obj_t tmp=NIL; /*a subscript argument */ obj_t operands=NIL; /*operand list */ int septok; /*separator token */ retval = parse_dot (f, skipnl); if (&ErrorCell==retval) return &ErrorCell; /* * Zero or more array selectors. */ while ('['==lex_token (f, NULL, skipnl)) { lex_consume (f); operands = obj_new (C_CONS, retval, NIL); retval = NIL; /* * One or more comma-separated expressions per selection. */ for (;;) { tmp = parse_expr (f, skipnl); if (&ErrorCell==tmp) { obj_dest (retval); return &ErrorCell; } operands = obj_new (C_CONS, tmp, operands); /*push*/ septok = lex_token (f, NULL, skipnl); if (','==septok) { lex_consume (f); } else if (']'==septok) { lex_consume (f); break; } else { out_errorn ("expected ']'"); obj_dest (operands); return &ErrorCell; } } /* * Put the operands in the correct order. */ tmp = F_reverse (operands); obj_dest (operands); operands = tmp; tmp = NIL; /* * Add the function name `Dot' to the beginning of the * list. */ retval = obj_new (C_CONS, obj_new (C_SYM, "Dot"), operands); } return retval; }
/*------------------------------------------------------------------------- * Function: parse_term * * Purpose: Parses a term which is a symbol, a string, or a number. * * Return: Success: Ptr to the term object or NIL * * Failure: &ErrorCell * * Programmer: Robb Matzke * [email protected] * Dec 4 1996 * * Modifications: * * Robb Matzke, 7 Feb 1997 * If the first thing after a parenthesis is a symbol which has a * built in function (BIF) as its f-value, and the BIF has the * lex_special property, then we call lex_special() to prepare the * next token. * * Robb Matzke, 26 Aug 1997 * The term `.' means current working directory. *------------------------------------------------------------------------- */ static obj_t parse_term (lex_t *f, int skipnl) { char *lexeme; obj_t retval=&ErrorCell, opstack=NIL, tmp=NIL, fval=NIL; int tok, nargs; switch ((tok=lex_token(f, &lexeme, skipnl))) { case TOK_DOT: retval = obj_new (C_SYM, lexeme); lex_consume (f); break; case TOK_SYM: if (!strcmp (lexeme, "nil")) { retval = NIL; } else { retval = obj_new (C_SYM, lexeme); } lex_consume (f); break; case TOK_NUM: retval = obj_new (C_NUM, lexeme); lex_consume (f); break; case TOK_STR: retval = obj_new (C_STR, lexeme); lex_consume (f); break; case TOK_LTPAREN: nargs = 0; lex_consume (f); while (TOK_RTPAREN!=(tok=lex_token(f, NULL, true)) && TOK_EOF!=tok) { /* * If the first token after the left paren is a symbol, and * the symbol has a BIF f-value, and the BIF has the lex_special * attribute, then call lex_special(). */ if (0==nargs++ && TOK_SYM==tok) { tmp = obj_new (C_SYM, f->lexeme); lex_consume (f); fval = sym_fboundp (tmp); if (bif_lex_special (fval)) lex_special (f, true); fval = obj_dest (fval); } else { tmp = parse_expr (f, true); } if (&ErrorCell==tmp) { opstack = obj_dest (opstack); goto done; } opstack = obj_new (C_CONS, tmp, opstack); } if (TOK_RTPAREN!=tok) { out_errorn ("right paren expected near end of input"); opstack = obj_dest (opstack); goto done; } lex_consume (f); retval = F_reverse (opstack); opstack = obj_dest (opstack); break; case TOK_LTCURLY: /* * A list of items inside curly braces `{A B ... Z}' is just short for * `(Quote A B ... Z)' and `Quote' is like the LISP `quote' function in * that (Quote X) returns X without trying to evaluate it. People tend * to use commas, so we accept commas between items. */ lex_consume (f); while (TOK_RTCURLY!=(tok=lex_token(f, NULL, true)) && TOK_EOF!=tok) { tmp = parse_expr (f, true); if (&ErrorCell==tmp) { opstack = obj_dest (opstack); goto done; } opstack = obj_new (C_CONS, tmp, opstack); if (TOK_COMMA==lex_token(f, NULL, true)) lex_consume (f); } if (TOK_RTCURLY!=tok) { out_errorn ("right curly brace expected near end of input"); opstack = obj_dest (opstack); goto done; } lex_consume (f); retval = F_reverse (opstack); opstack = obj_dest (opstack); retval = obj_new (C_CONS, obj_new (C_SYM, "Quote"), retval); break; } done: return retval; }
/*------------------------------------------------------------------------- * Function: parse_stmt * * Purpose: Parses a statement which is a function name followed by * zero or more arguments. * * Return: Success: Ptr to parse tree. * * Failure: NIL, input consumed through end of line. * * Programmer: Robb Matzke * [email protected] * Dec 4 1996 * * Modifications: * * Robb Matzke, 11 Dec 1996 * If IMPLIED_PRINT is true then wrap the input in a call to the * `print' function if it isn't already obviously a call to `print'. * * Robb Matzke, 20 Jan 1997 * Turn off handling of SIGINT during parsing. * * Robb Matzke, 7 Feb 1997 * If the first thing on the line is a symbol which has a built in * function (BIF) as its f-value, and the BIF has the lex_special * property, then we call lex_special() to prepare the next token. * * Robb Matzke, 2000-06-28 * Signal handlers are registered with sigaction() since its behavior * is more consistent. * *------------------------------------------------------------------------- */ obj_t parse_stmt (lex_t *f, int implied_print) { char *lexeme, buf[1024], *s, *fmode; int tok, i; obj_t head=NIL, opstack=NIL, b1=NIL, retval=NIL, tmp=NIL; struct sigaction new_action, old_action; /* SIGINT should have the default action while we're parsing */ new_action.sa_handler = SIG_DFL; sigemptyset(&new_action.sa_mask); new_action.sa_flags = SA_RESTART; sigaction(SIGINT, &new_action, &old_action); tok = lex_token (f, &lexeme, false); /* * At the end of the file, return `(exit)'. */ if (TOK_EOF==tok) { lex_consume (f); if (f->f && isatty (fileno (f->f))) { printf ("exit\n"); retval = obj_new (C_CONS, obj_new (C_SYM, "exit"), NIL); goto done; } else { retval = obj_new (C_SYM, "__END__"); goto done; } } /* * For an empty line, eat the linefeed token and try again. */ if (TOK_EOL==tok) { lex_consume (f); retval = parse_stmt (f, implied_print); goto done; } /* * A statement begins with a function name. If the first token * is not a symbol then assume `print'. */ if (implied_print && TOK_SYM==tok) { head = obj_new (C_SYM, lexeme); if ((tmp=sym_fboundp (head))) { tmp = obj_dest (tmp); lex_consume (f); } else { obj_dest (head); head = obj_new (C_SYM, "print"); } } else if (implied_print) { head = obj_new (C_SYM, "print"); } else { head = &ErrorCell ; /*no function yet*/ } /* * Some functions take a weird first argument that isn't really a * normal token. Like `open' which wants the name of a file. We * call lex_special() to try to get such a token if it appears * next. */ if (head && &ErrorCell!=head && (tmp=sym_fboundp(head))) { if (bif_lex_special (tmp)) lex_special (f, false); tmp = obj_dest (tmp); } /* * Read the arguments... */ while (&ErrorCell!=(b1=parse_expr(f, false))) { opstack = obj_new(C_CONS, b1, opstack); } /* * Construct a function call which is the HEAD applied to the * arguments on the operand stack. */ b1 = F_reverse (opstack); opstack = obj_dest (opstack); if (&ErrorCell==head) { head = NIL; if (1==F_length(b1)) { retval = obj_copy (cons_head (b1), SHALLOW); b1 = obj_dest (b1); } else { retval = b1; b1 = NIL; } } else { retval = F_cons (head, b1); head = obj_dest (head); b1 = obj_dest (b1); } /* * A statement can end with `>' or `>>' followed by the name of * a file, or `|' followed by an unquoted shell command. Leading * and trailing white space is stripped from the file or command. */ tok = lex_token (f, &lexeme, false); if (TOK_RT==tok || TOK_RTRT==tok || TOK_PIPE==tok) { lex_consume (f); if (NULL==lex_gets (f, buf, sizeof(buf))) { out_errorn ("file name required after `%s' operator", lexeme); goto error; } lex_set (f, TOK_EOL, "\n"); for (s=buf; isspace(*s); s++) /*void*/; for (i=strlen(s)-1; i>=0 && isspace(s[i]); --i) s[i] = '\0'; if (!*s) { out_errorn ("file name required after `%s' operator", lexeme); goto error; } switch (tok) { case TOK_RT: lexeme = "Redirect"; fmode = "w"; break; case TOK_RTRT: lexeme = "Redirect"; fmode = "a"; break; case TOK_PIPE: lexeme = "Pipe"; fmode = "w"; break; default: abort(); } retval = obj_new (C_CONS, obj_new (C_SYM, lexeme), obj_new (C_CONS, retval, obj_new (C_CONS, obj_new (C_STR, s), obj_new (C_CONS, obj_new (C_STR, fmode), NIL)))); } /* * We should be at the end of a line. */ tok = lex_token (f, &lexeme, false); if (TOK_EOL!=tok && TOK_EOF!=tok) { s = lex_gets (f, buf, sizeof(buf)); if (s && strlen(s)>0 && '\n'==s[strlen(s)-1]) s[strlen(s)-1] = '\0'; out_errorn ("syntax error before: %s%s", lexeme, s?s:""); lex_consume(f); goto error; } else { lex_consume(f); } done: sigaction(SIGINT, &old_action, NULL); return retval; error: if (head) head = obj_dest (head); if (opstack) opstack = obj_dest (opstack); if (retval) retval = obj_dest (retval); sigaction(SIGINT, &old_action, NULL); return NIL; }
/*------------------------------------------------------------------------- * Function: sym_init * * Purpose: Initializes browser variables. * * Return: void * * Programmer: Robb Matzke * [email protected] * Jan 20 1997 * * Modifications: * * Robb Matzke, 3 Feb 1997 * Removed the C_print_DBobject symbol. * * Robb Matzke, 2 Apr 1997 * Added the `$rdonly' variable. * * Robb Matzke, 11 Jun 1997 * Added the `doc_url' variable. * * Robb Matzke, 29 Jul 1997 * Added the `html_browsers' and `$trapfpe' symbols. * * Robb Matzke, 2 Sep 1997 * Added symbols for the new `int8' datatype. * * Robb Matzke, 2000-06-01 * Calls sym_bi_set() for numbers and strings. Added documentation. * * Robb Matzke, 2000-06-02 * Removed initialization of $truncate; added $height and $width. * * Robb Matzke, 2000-06-27 * The $fmt_float and $fmt_double formats are based on FLT_DIG and * DBL_DIG, which according to POSIX are `the number of decimal * digits in the fraction'. * * Robb Matzke, 2000-06-27 * Added the `$exclude' variable. * * Robb Matzke, 2000-10-19 * Added the `$obase' variable. * * Mark C. Miller, Wed Sep 23 11:53:59 PDT 2009 * Added $fmt_llong for long long data. * * Mark C. Miller, Wed Nov 11 22:18:17 PST 2009 * Added suppot for alternate relative diff option using epsilon. * * Mark C. Miller, Fri Nov 13 15:38:07 PST 2009 * Changed name of "long long" type to "longlong" as PDB is sensitive * * Mark C. Miller, Tue Nov 17 22:30:30 PST 2009 * Changed name of long long datatype to match PDB proper. * * Mark C. Miller, Tue Dec 15 10:14:32 PST 2009 * Fixed problem with default format for long type being '%d'. It * should really be '%ld' * * Mark C. Miller, Mon Jan 11 16:14:51 PST 2010 * Fixed default formats for int8, short and long long. Added * initialization of diffing parameters for long long. * * Mark C. Miller, Fri Feb 12 08:41:39 PST 2010 * Added $splitvfdexts variable. * * Mark C. Miller, Fri Mar 12 01:23:15 PST 2010 * Replaced splitvfdexts with $hdf5_vfd_opts * * Kathleen Bonnell, Thu Dec 9 09:40:03 PST 2010 * Surround use of PUBLIC_INIT_FILE with ifdef for its existence. *------------------------------------------------------------------------- */ void sym_init (void) { obj_t name=NIL; char tmp[64]; obj_t list[2], symbol, value; const char *diff_abs = "This variable controls how the `diff' function " "determines whether two numeric values are the same " "or different. The `diff' function considers two " "values, A and B, to be different if |A-B|>N where " "N is the value of this variable. If this variable " "does not have a positive value then this test is " "not performed (if the relative difference test is " "also not performed then the browser will use an " "exact match instead). This variable, which " "defaults to zero, is set by the -A and " "--absolute command-line switches."; const char *diff_rel = "This variable controls how the `diff' function " "determines whether two numeric values are the same " "or different. The `diff' function considers two " "values, A and B, to be different if " "|A-B|/|A+B|>N/2 where N is the value of this " "variable. If this variable does not have a " "positive value then this test is not performed (if " "the absolute difference test is also not performed " "then the browser will use an exact match instead.) " "This variable, which defaults to zero, is set by " "the -R and --relative command-line switches."; const char *diff_eps = "When non-negative, this variable triggers an " "alternative relative `diff' algorithm where two " "values, A and B, are different if " "|A-B|/(|A|+|B|+EPS)>N where EPS is the value of " "this variable and N is the value of the associated " "relative difference tolerance variable. This " "variable, which defaults to -1, is set by the " "-x and --epsilon command-line switches."; /* Command-line options */ sym_bi_set("lowlevel", "0", "Act more like pdbdiff.", "If this variable has any true value (nil, zero, and the empty " "string are considered false) then the browser reads objects as " "type DBobject even if that object has some other datatype such " "as DBquadvar. This variable is set by the --lowlevel and -l " "command-line switches.\n" "\n" "If the value is two or higher then the SILO definition of " "`DBobject is used and the values of the `comp_names' and " "`pdb_names' arrays become part of the object.\n" "\n" "If the value is one or two then the browser translates the " "SILO DBobject structure into a structure which is more " "user friendly by adding additional members to the object " "datatype. Each new member has a name from the `comp_names' " "array and a value based on the corresponding member of the " "`pdb_names' array. Changes should not be made to the " "`comp_names' or `pdb_names' arrays since the SILO DBobject " "is regenerated from the user-friendly fields before being " "saved back to the file."); sym_bi_set("writeable", "0", "Open files for write access.", "If this variable has any true value (nil, zero, and the empty " "string are considered false) then the browser opens files in " "write mode if the file permissions allow it. Editing " "objects in a writeable file is allowed."); sym_bi_set("diff", NULL, "Influence behavior of `diff' function.", "This variable controls the details of the `diff' function. It " "should be a list of words from the set: detail, brief, " "summary, ignore_additions, ignore_deletions, and two_column. " "The word `detail' indicates that all details of the " "differences are to be shown (the default), while `brief' " "means one line of output per difference and `summary' means " "one line of output total. No output is generated if the " "objects do not differ. The words `ignore_additions' and " "`ignore_deletions' mean to consider things which appear in " "object B but not A (or vice versa) as being not-different. " "For detailed output, the word `two_column' causes the diff " "function to display the differences side by side (like " "pdbdiff) instead of one above the other (like Unix diff)."); sym_bi_set("exclude", NULL, "Exclude certain objects from recursive diff.", "The value of this variable should be a list of object names " "which will be excluded from a recursive diff operation. Each " "name should be a string which may contain file name wildcards " "similar to the Bourne Shell. If an exclude name begins with a " "slash then the name is matched against the full name of the " "object, otherwise the matching function only looks at the " "basename of the object. If the name is of the form `type:X' " "where `X' is one of the headings printed by the `ls' function " "(such as `dir' or `ucdmesh') then all objects of the specified " "type will be excluded. When $verbosity>=2 the excluded " "object names are displayed."); sym_bi_set("checksums", "0", "Do checksum checks on read when database has checksums.", "If this variable has any true value (nil, zero, and the empty " "string are considered false) then the browser will enable " "checksum checks during subsequent read operations. " "This variable is set by the --checksums and -c " "command-line switches.\n"); sym_bi_set("h5vfdopts", NULL, "Specify hdf5 (vfd) options sets when attempting to open files.", "The value of this variable should be a list of OPTION=VALUE " "strings. The keyword '_NEWSET_' can be used to separate one " "group of OPTION=VALUE strings from another, each group forming " "one set of options to be used to open files. Browser will try " "Them in order when attempting to open a file.\n"); /* Name of public init file */ #ifdef PUBLIC_INIT_FILE sym_bi_set("pubinit", PUBLIC_INIT_FILE, "Name of public initialization file.", "The name of the public initialization file is stored in this " "variable regardless of whether that file has actually been " "read. Its primary purpose is to be used as the argument to " "the `include' function in a user-local startup file."); #endif /* Set $diff to something reasonable */ list[0] = obj_new(C_SYM, "detail"); list[1] = obj_new(C_SYM, "two_column"); value = V_make_list(2, list); obj_dest(list[0]); obj_dest(list[1]); symbol = obj_new(C_SYM, "$diff"); sym_vbind(symbol, value); value = NIL; symbol = obj_dest(symbol); sprintf(tmp, "%d", OUT_NROWS); sym_bi_set("height", tmp, "Lines per page of output.", "The height of the output terminal in lines. If set to a " "positive value then the browser will pause after each " "screenful of interactive output (redirected output is " "unaffected by this setting). This variable is set by the " "--height command-line switch and is reset whenever the " "browser receives a window size change signal (SIGWINCH)."); sprintf(tmp, "%d", OUT_NCOLS); sym_bi_set("width", tmp, "Characters per line of output.", "The width of the output terminal in characters. The browser " "will try not to print data which would wrap from one line to " "the next. This variable is set by the --width command-line " "switch and is reset whenever the browser receives a window " "size change signal (SIGWINCH)."); sym_bi_set("verbosity", "1", "How much chatter is produced by the browser.", "This variable is set by the --quiet and --verbose switches. " "The --quiet sets it to zero while --verbose sets it to two " "(the default is one). Changing its value at runtime changes " "the amount of chatter produced by the browser."); /* Documentation category defaults */ sym_doc("delta", "Documentation is initialized in the browser system startup file."); sym_doc("faq", "Documentation is initialized in the browser system startup file."); sym_doc("syntax", "Documentation is initialized in the browser system startup file."); sym_doc("formats", "Documentation is initialized in the browser system startup file."); sym_doc("paging", "Documentation is initialized in the browser system startup file."); sym_doc("redirection", "Documentation is initialized in the browser system startup file."); sym_doc("traps", "Documentation is initialized in the browser system startup file."); sym_doc("run", NULL); /*do not document this -- it's special in V_help()*/ /* Variables for formatting output */ sym_bi_set("truncate", NULL, "Max elmts to print", "If this is set to a positive integer N then at most N " "elements of each array are displayed. Depending on the " "value of $trailing, some of those elements will come from " "the beginning of the array and others will come from the " "end. The browser prints `...(2000 values omitted)...' at " "the point where the values are omitted. Truncation is " "disabled (all values are printed) by setting this variable " "to nil (its default)."); sym_bi_set("trailing", "0", "Trailing elmts to print", "If array output truncation is turned on (see $truncate) and " "this variable has a positive integer value N, then up to N of " "the displayed values will be taken from the end of the array " "instead of the beginning. If $trailing is smaller than " "$truncate then the difference is the number of elements " "displayed at the beginning of the array; otherwise all " "elements displayed are from the end of the array."); sym_bi_set("fmt_string", "\"%s\"", "String format", "This is a C printf() format string used to render string " "values in the browser output."); sym_bi_set("fmt_null", "(null)", "Null format", "This is a C printf() format string used to render null " "pointers in the browser output."); sym_bi_set("fmt_int8", "%hhd", "Byte format", "This is a C printf() format string used to render byte " "values in the browser output."); sym_bi_set("fmt_short", "%hd", "Short format", "This is a C printf() format string used to render short " "integer values in the browser output."); sym_bi_set("fmt_int", "%d", "Integer format", "This is a C printf() format string used to render integer " "values in the browser output."); sym_bi_set("fmt_long", "%ld", "Long format", "This is a C printf() format string used to render long " "integer values in the browser output."); sym_bi_set("fmt_long_long", "%lld", "Long long format", "This is a C printf() format string used to render long " "long integer values in the browser output."); sprintf(tmp, "%%1.%dg", FLT_DIG); sym_bi_set("fmt_float", tmp, "Float format", "This is a C printf() format string used to render `float' " "values in the browser output."); sprintf(tmp, "%%1.%dg", DBL_DIG); sym_bi_set("fmt_double", tmp, "Double format", "This is a C printf() format string used to render `double' " "values in the browser output."); sym_bi_set("obase", NULL, "Output style", "Output of primitive data (integer, character, string, and " "floating-point) uses the $fmt_* variables by default. " "However, it is also possible to display data in hexadecimal, " "octal, or binary format as well by setting this variable " "to 16, 8, or 2 (default is anything else)."); /* Difference tolerances are all set to zero, eps to -1. */ sym_bi_set("diff_int8_abs", "0", "Absolute diff tolerance for byte", diff_abs); sym_bi_set("diff_int8_rel", "0", "Relative diff tolerance for byte", diff_rel); sym_bi_set("diff_int8_eps", "-1", "Epsilon for alternate relative diff for byte", diff_eps); sym_bi_set("diff_short_abs", "0", "Absolute diff tolerance for short", diff_abs); sym_bi_set("diff_short_rel", "0", "Relative diff tolerance for short", diff_rel); sym_bi_set("diff_short_eps", "-1", "Epsilon for alternate relative diff for short", diff_eps); sym_bi_set("diff_int_abs", "0", "Absolute diff tolerance for int", diff_abs); sym_bi_set("diff_int_rel", "0", "Relative diff tolerance for int", diff_rel); sym_bi_set("diff_int_eps", "-1", "Epsilon for alternate relative diff for int", diff_eps); sym_bi_set("diff_long_abs", "0", "Absolute diff tolerance for long", diff_abs); sym_bi_set("diff_long_rel", "0", "Relative diff tolerance for long", diff_rel); sym_bi_set("diff_long_eps", "-1", "Epsilon for alternate relative diff for long", diff_eps); sym_bi_set("diff_float_abs", "0", "Absolute diff tolerance for float", diff_abs); sym_bi_set("diff_float_rel", "0", "Relative diff tolerance for float", diff_rel); sym_bi_set("diff_float_eps", "-1", "Epsilon for alternate relative diff for float", diff_eps); sym_bi_set("diff_double_abs","0", "Absolute diff tolerance for double", diff_abs); sym_bi_set("diff_double_rel","0", "Relative diff tolerance for double", diff_rel); sym_bi_set("diff_double_eps","-1", "Epsilon for alternate relative diff for double", diff_eps); sym_bi_set("diff_llong_abs", "0", "Absolute diff tolerance for long long", diff_abs); sym_bi_set("diff_llong_rel", "0", "Relative diff tolerance for long long", diff_rel); sym_bi_set("diff_llong_eps", "-1", "Epsilon for alternate relative diff for long long", diff_eps); /* * Primitive types. */ name = obj_new (C_SYM, "string"); sym_vbind (name, obj_new (C_PRIM, "string")); name = obj_dest (name); name = obj_new (C_SYM, "int8"); sym_vbind (name, obj_new (C_PRIM, "int8")); name = obj_dest (name); name = obj_new (C_SYM, "short"); sym_vbind (name, obj_new (C_PRIM, "short")); name = obj_dest (name); name = obj_new (C_SYM, "int"); sym_vbind (name, obj_new (C_PRIM, "int")); name = obj_dest (name); name = obj_new (C_SYM, "long"); sym_vbind (name, obj_new (C_PRIM, "long")); name = obj_dest (name); name = obj_new (C_SYM, "float"); sym_vbind (name, obj_new (C_PRIM, "float")); name = obj_dest (name); name = obj_new (C_SYM, "double"); sym_vbind (name, obj_new (C_PRIM, "double")); name = obj_dest (name); /* File symbols */ sym_doc("_1", "Symbols of the form _N are deprecated. Use $N instead."); sym_doc("$1", "Browser variables of the form $N where N is an integer " "are reserved for SILO files that are opened by the browser. " "The files listed on the browser command-line are opened and " "assigned to browser variables $1, $2, etc. Most browser commands " "that operate on files use the file bound to $1 by default. " "You can obtain the name and current working directory of the " "file bound to a symbol by printing the symbol."); sym_doc("$*", "This special variable always evaluates to a list of files " "opened on the browser command-line. Or more specifically, to the " "list of files represented by the first consecutive $N symbols."); }
