/*------------------------------------------------------------------------- * 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; }
/*------------------------------------------------------------------------- * 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; }