/********************************************
fcall.c
libmawk changes (C) 2009-2010, Tibor 'Igor2' Palinkas;
based on mawk code coming with the below copyright:
copyright 1991, Michael D. Brennan
This is a source file for mawk, an implementation of
the AWK programming language.
Mawk is distributed without warranty under the terms of
the GNU General Public License, version 2, 1991.
********************************************/
#include "mawk.h"
#include "symtype.h"
#include "code.h"
/* This file has functions involved with type checking of
function calls
*/
static FCALL_REC *first_pass(mawk_state_t *, FCALL_REC *);
static CA_REC *call_arg_check(mawk_state_t *, FBLOCK *, CA_REC *, INST *, unsigned);
static int arg_cnt_ok(mawk_state_t *, FBLOCK *, CA_REC *, unsigned);
static void relocate_arglist(CA_REC *, int, unsigned, int);
/* type checks a list of call arguments,
returns a list of arguments whose type is still unknown
*/
static CA_REC *call_arg_check(mawk_state_t *MAWK, FBLOCK *callee, CA_REC *entry_list, INST *start, unsigned line_no)
{
/* start -> to locate patch */
/* line_no -> for error messages */
register CA_REC *q;
CA_REC *exit_list = (CA_REC *) 0;
MAWK->check_progress = 0;
/* loop :
take q off entry_list
mawk_test it
if OK mawk_zfree(MAWK, q) else put on exit_list */
while ((q = entry_list)) {
entry_list = q->link;
if (q->type == ST_NONE) {
/* try to infer the type */
/* it might now be in symbol table */
if (q->sym_p->type == ST_VAR) {
/* set type and patch */
q->type = CA_EXPR;
start[q->call_offset + 1].ptr = (PTR) q->sym_p->stval.cp;
}
else if (q->sym_p->type == ST_ARRAY) {
q->type = CA_ARRAY;
start[q->call_offset].op = A_PUSHA;
start[q->call_offset + 1].ptr = (PTR) q->sym_p->stval.array;
}
else { /* try to infer from callee */
switch (callee->typev[q->arg_num]) {
case ST_LOCAL_VAR:
q->type = CA_EXPR;
q->sym_p->type = ST_VAR;
q->sym_p->stval.cp = MAWK_ZMALLOC(MAWK, mawk_cell_t);
q->sym_p->stval.cp->type = C_NOINIT;
start[q->call_offset + 1].ptr = (PTR) q->sym_p->stval.cp;
break;
case ST_LOCAL_ARRAY:
q->type = CA_ARRAY;
q->sym_p->type = ST_ARRAY;
q->sym_p->stval.array = mawk_array_new(MAWK, NULL);
start[q->call_offset].op = A_PUSHA;
start[q->call_offset + 1].ptr = (PTR) q->sym_p->stval.array;
break;
}
}
}
else if (q->type == ST_LOCAL_NONE) {
/* try to infer the type */
if (*q->type_p == ST_LOCAL_VAR) {
/* set type , don't need to patch */
q->type = CA_EXPR;
}
else if (*q->type_p == ST_LOCAL_ARRAY) {
q->type = CA_ARRAY;
start[q->call_offset].op = LA_PUSHA;
/* offset+1 op is OK */
}
else { /* try to infer from callee */
switch (callee->typev[q->arg_num]) {
case ST_LOCAL_VAR:
q->type = CA_EXPR;
*q->type_p = ST_LOCAL_VAR;
/* do not need to patch */
break;
case ST_LOCAL_ARRAY:
q->type = CA_ARRAY;
*q->type_p = ST_LOCAL_ARRAY;
start[q->call_offset].op = LA_PUSHA;
break;
}
}
}
/* if we still do not know the type put on the new list
else type check */
if (q->type == ST_NONE || q->type == ST_LOCAL_NONE) {
q->link = exit_list;
exit_list = q;
}
else { /* type known */
if (callee->typev[q->arg_num] == ST_LOCAL_NONE)
callee->typev[q->arg_num] = q->type;
else if (q->type != callee->typev[q->arg_num])
mawk_compile_error(MAWK, "type error in arg(%d) in call to %s", q->arg_num + 1, callee->name);
MAWK_ZFREE(MAWK, q);
MAWK->check_progress = 1;
}
} /* while */
return exit_list;
}
static int arg_cnt_ok(mawk_state_t *MAWK, FBLOCK *fbp, CA_REC *q, unsigned line_no)
{
if ((int) q->arg_num >= (int) fbp->nargs)
/* casts shutup stupid warning from solaris sun cc */
{
mawk_compile_error(MAWK, "too many arguments in call to %s", fbp->name);
return 0;
}
else
return 1;
}
static INST *update_start(mawk_state_t *MAWK, register FCALL_REC *p)
{
switch (p->call_scope) {
case SCOPE_MAIN:
p->call_start = MAWK->main_start;
break;
case SCOPE_BEGIN:
p->call_start = MAWK->begin_start;
break;
case SCOPE_END:
p->call_start = MAWK->end_start;
break;
case SCOPE_FUNCT:
p->call_start = p->call->code;
break;
}
return p->call_start;
}
/* function calls whose arg types need checking
are stored on this list */
/* Corner case: a c function call with an argument referring to a global
variable that has not yet been seen. In this case we should create that
var, but because we can't look into the C code, we don't know if it's an
array or not. So instead we delay resolving the symbol until the whole
script is parsed and expect one of 3 cases:
- the script references the var elsewhere as non-array -> it's not an array
- the script references the var elsewhere as array -> it's an array
- no reference elsewhere -> safe to pass NIL without even creating it
(but throw an error because this is very likely a bug in the script)
*/
static void ccall_finalize_call(mawk_state_t *MAWK, register FCALL_REC *p)
{
CA_REC *n;
INST *start = update_start(MAWK, p);
for(n = p->arg_list; n != NULL; n = n->link) {
if ((n->type != ST_NONE) || (n->sym_p == NULL)) /* care only about unbound globals */
continue;
switch(n->sym_p->type) {
case ST_NONE:
mawk_errmsg(MAWK, 0, "uninitialized variable in C call %s()", p->callee->name);
break;
case ST_VAR:
start[n->call_offset + 1].ptr = (PTR)n->sym_p->stval.cp;
break;
case ST_ARRAY:
start[n->call_offset].op = A_PUSHA;
start[n->call_offset + 1].ptr = (PTR)n->sym_p->stval.array;
break;
default:
mawk_errmsg(MAWK, 0, "internal error: unknown argument symbol type %d in C call %s()", n->sym_p->type, p->callee->name);
break;
}
}
}
/* on first pass thru the resolve list
we check :
if forward referenced functions were really defined
if right number of arguments
and compute call_start which is now known
*/
static FCALL_REC *first_pass(mawk_state_t *MAWK, register FCALL_REC *p)
{
FCALL_REC dummy;
register FCALL_REC *q = &dummy; /* trails p */
q->link = p;
while (p) {
if (!p->callee->code) {
/* callee never defined - could be a C call*/
ccall_finalize_call(MAWK, p);
if (!MAWK->suppress_undefined_function_warning)
mawk_compile_error(MAWK, "function %s never defined", p->callee->name);
/* delete p from list */
q->link = p->link;
MAWK_ZFREE(MAWK, p);
}
/* note p->arg_list starts with last argument */
else if (!p->arg_list /* nothing to do */ ||
(!p->arg_cnt_checked && !arg_cnt_ok(MAWK, p->callee, p->arg_list, p->line_no))) {
q->link = p->link; /* delete p */
/* the ! arg_list case is not an error so free memory */
MAWK_ZFREE(MAWK, p);
}
else {
/* keep p and set call_start */
q = p;
update_start(MAWK, p);
}
p = q->link;
}
return dummy.link;
}
/* continuously walk the resolve_list making type deductions
until this list goes empty or no more progress can be made
(An example where no more progress can be made is at end of file
*/
void mawk_resolve_fcalls(mawk_state_t * MAWK)
{
register FCALL_REC *p, *old_list, *new_list;
int progress; /* a flag */
old_list = first_pass(MAWK, MAWK->resolve_list);
new_list = (FCALL_REC *) 0;
progress = 0;
while (1) {
if (!old_list) {
/* flop the lists */
old_list = new_list;
if (!old_list /* nothing left */
|| !progress /* can't do any more */ )
return;
new_list = (FCALL_REC *) 0;
progress = 0;
}
p = old_list;
old_list = p->link;
if ((p->arg_list = call_arg_check(MAWK, p->callee, p->arg_list, p->call_start, p->line_no))) {
/* still have work to do , put on new_list */
progress |= MAWK->check_progress;
p->link = new_list;
new_list = p;
}
else {
/* done with p */
progress = 1;
MAWK_ZFREE(MAWK, p);
}
}
}
/* the mawk_parser has just reduced a function call ;
the info needed to type check is passed in. If type checking
can not be done yet (most common reason -- function referenced
but not defined), a node is added to the resolve list.
*/
void mawk_check_fcall(mawk_state_t *MAWK, FBLOCK *callee, int call_scope, int move_level, FBLOCK *call, CA_REC *arg_list, unsigned line_no)
{
FCALL_REC *p;
if (!callee->code) {
/* forward reference to a function to be defined later */
p = MAWK_ZMALLOC(MAWK, FCALL_REC);
p->callee = callee;
p->call_scope = call_scope;
p->move_level = move_level;
p->call = call;
p->arg_list = arg_list;
p->arg_cnt_checked = 0;
p->line_no = line_no;
/* add to resolve list */
p->link = MAWK->resolve_list;
MAWK->resolve_list = p;
}
else if (arg_list && arg_cnt_ok(MAWK, callee, arg_list, line_no)) {
/* usually arg_list disappears here and all is well
otherwise add to resolve list */
if ((arg_list = call_arg_check(MAWK, callee, arg_list, mawk_code_base, line_no))) {
p = MAWK_ZMALLOC(MAWK, FCALL_REC);
p->callee = callee;
p->call_scope = call_scope;
p->move_level = move_level;
p->call = call;
p->arg_list = arg_list;
p->arg_cnt_checked = 1;
p->line_no = line_no;
/* add to resolve list */
p->link = MAWK->resolve_list;
MAWK->resolve_list = p;
}
}
}
void mawk_check_ccall(mawk_state_t *MAWK, FBLOCK *callee, int call_scope, int move_level, FBLOCK *call, CA_REC *arg_list, unsigned line_no)
{
FCALL_REC *p;
p = MAWK_ZMALLOC(MAWK, FCALL_REC);
p->callee = callee;
p->call_scope = call_scope;
p->move_level = move_level;
p->call = call;
p->arg_list = arg_list;
p->arg_cnt_checked = 1;
p->line_no = line_no;
/* add to resolve list */
p->link = MAWK->resolve_list;
MAWK->resolve_list = p;
}
/* code_pop() has just moved some code. If this code contains
a function call, it might need to be relocated on the
resolve list too. This function does it.
*/
void mawk_relocate_resolve_list(mawk_state_t *MAWK, int scope, int move_level, FBLOCK *fbp, int orig_offset, unsigned len, int delta)
{
/* delta -> relocation distance */
FCALL_REC *p = MAWK->resolve_list;
while (p) {
if (scope == p->call_scope && move_level == p->move_level && (scope == SCOPE_FUNCT ? fbp == p->call : 1)) {
relocate_arglist(p->arg_list, orig_offset, len, delta);
}
p = p->link;
}
}
static void relocate_arglist(CA_REC *arg_list, int offset, unsigned len, int delta)
{
register CA_REC *p;
if (!arg_list)
return;
p = arg_list;
/* all nodes must be relocated or none, so mawk_test the
first one */
/* Note: call_offset is always set even for args that don't need to
be patched so that this check works. */
if (p->call_offset < offset || p->call_offset >= offset + len)
return;
/* relocate the whole list */
do {
p->call_offset += delta;
p = p->link;
}
while (p);
}
/* example where typing cannot progress
{ f(z) }
function f(x) { print NR }
# this is legal, does something useful, but absurdly written
# We have to design so this works
*/