/*------------------------------------------------------------------------- * 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: sym_self_set * * Purpose: Gives symbol `self' a new variable value and returns the * previous value. The new value is not copied. * * Return: Success: Previous value of variable `self'. * * Failure: NIL * * Programmer: Robb Matzke * [email protected] * Jan 13 1997 * * Modifications: * *------------------------------------------------------------------------- */ obj_t sym_self_set (obj_t newval) { obj_t oldval=NIL, selfvar=NIL; selfvar = obj_new (C_SYM, "self"); oldval = sym_vboundp (selfvar); sym_vbind (selfvar, newval); return oldval; }
/*------------------------------------------------------------------------- * 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; }
/*---------------------------------------------------------------------------
* 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;
}
/*---------------------------------------------------------------------------
* 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: 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; }
