/*======================================+
* llrpt_newfile -- Switch output to new file
* usage: newfile(STRING, BOOL) -> VOID
*=====================================*/
PVALUE
llrpt_newfile (PNODE node, SYMTAB stab, BOOLEAN *eflg)
{
PNODE argvar = builtin_args(node);
BOOLEAN aflag=FALSE;
STRING name=0;
PVALUE val = eval_and_coerce(PSTRING, argvar, stab, eflg);
if (*eflg) {
prog_var_error(node, stab, argvar, val, nonstrx, "newfile", "1");
delete_pvalue_ptr(&val);
return NULL;
}
name = pvalue_to_string(val);
if (!name || !name[0]) {
*eflg = TRUE;
prog_var_error(node, stab, argvar, val, "1st arg to newfile must be a nonempty string.");
delete_pvalue_ptr(&val);
return NULL;
}
strupdate(&outfilename, name);
delete_pvalue_ptr(&val);
val = eval_and_coerce(PBOOL, argvar=inext(argvar), stab, eflg);
if (*eflg) {
prog_var_error(node, stab, argvar, val, nonboox, "newfile", "2");
delete_pvalue_ptr(&val);
return NULL;
}
aflag = pvalue_to_bool(val);
delete_pvalue_ptr(&val);
if (!set_output_file(outfilename, aflag)) {
*eflg = TRUE;
prog_var_error(node, stab, argvar, NULL, "Failed to open output file: %s", outfilename);
}
return NULL;
}
/*===============================================+
* llrpt_difference -- Create difference of two INDISEQs
* usage: difference(SET, SET) -> SET
*==============================================*/
PVALUE
llrpt_difference (PNODE node, SYMTAB stab, BOOLEAN *eflg)
{
PNODE arg1 = builtin_args(node);
PNODE arg2 = inext(arg1);
INDISEQ op2=0, op1=0;
PVALUE val1 = eval_and_coerce(PSET, arg1, stab, eflg);
PVALUE val2=0;
if (*eflg) {
prog_var_error(node, stab, arg1, val1, nonsetx, "difference", "1");
return NULL;
}
/* NULL indiseqs are possible, because of getindiset */
op1 = pvalue_to_seq(val1);
val2 = eval_and_coerce(PSET, arg2, stab, eflg);
if (*eflg) {
prog_var_error(node, stab, arg2, val2, nonsetx, "difference", "2");
return NULL;
}
op2 = pvalue_to_seq(val2);
/* do actual difference */
op2 = difference_indiseq(op1, op2);
set_pvalue_seq(val1, op2);
/* delay to last minute lest it is a temp owning seq,
eg, difference(ancestorset(i),ancestorset(j)) */
delete_pvalue(val2);
return val1;
}
/*========================================+
* llrpt_row -- Position output to start of row
* usage: row(INT) -> VOID
*=======================================*/
PVALUE
llrpt_row (PNODE node, SYMTAB stab, BOOLEAN *eflg)
{
INT row=0;
PNODE argvar = builtin_args(node);
PVALUE val = eval_and_coerce(PINT, argvar, stab, eflg);
if (*eflg) {
prog_var_error(node, stab, argvar, val, nonint1, "row");
delete_pvalue_ptr(&val);
return NULL;
}
*eflg = TRUE;
row = pvalue_to_int(val);
delete_pvalue_ptr(&val);
if (outputmode != PAGEMODE) {
*eflg = TRUE;
prog_var_error(node, stab, argvar, val, "row only valid in page mode");
return NULL;
}
if (row < 1 || row > __rows) {
*eflg = TRUE;
prog_var_error(node, stab, argvar, val, badarg1, "row");
return NULL;
}
*eflg = FALSE;
currow = row;
curcol = 1;
return NULL;
}
/*====================================================+
* llrpt_descendentset -- Create descendent set of an INDISEQ
* usage: descendantset(SET) -> SET
*===================================================*/
PVALUE
llrpt_descendentset (PNODE node, SYMTAB stab, BOOLEAN *eflg)
{
INDISEQ seq=0;
PNODE arg1 = builtin_args(node);
PVALUE val1 = eval_and_coerce(PSET, arg1, stab, eflg);
if (*eflg) {
prog_var_error(node, stab, arg1, val1, nonset1, "descendentset");
return NULL;
}
ASSERT(seq = pvalue_to_seq(val1));
seq = descendent_indiseq(seq);
set_pvalue_seq(val1, seq);
return val1;
}
/*==========================================+
* llrpt_childset -- Create child set of an INDISEQ
* usage: childset(SET) -> SET
*=========================================*/
PVALUE
llrpt_childset (PNODE node, SYMTAB stab, BOOLEAN *eflg)
{
INDISEQ seq=0;
PNODE arg1 = builtin_args(node);
PVALUE val1 = eval_and_coerce(PSET, arg1, stab, eflg);
if (*eflg) {
prog_var_error(node, stab, arg1, val1, nonset1, "childset");
return NULL;
}
ASSERT(seq = pvalue_to_seq(val1));
/* do actual construction of child set */
seq = child_indiseq(seq);
set_pvalue_seq(val1, seq);
return val1;
}
/*===================================================+
* llrpt_gengedcomstrong -- Generate GEDCOM output from an INDISEQ
* usage: gengedcom(SET) -> VOID
* Perry 2000/11/03
*==================================================*/
PVALUE
llrpt_gengedcomstrong (PNODE node, SYMTAB stab, BOOLEAN *eflg)
{
INDISEQ seq=0;
PNODE arg1 = builtin_args(node);
PVALUE val1 = eval_and_coerce(PSET, arg1, stab, eflg);
if (*eflg) {
prog_var_error(node, stab, arg1, val1, nonset1, "gengedcomstrong");
return NULL;
}
ASSERT(seq = pvalue_to_seq(val1));
gen_gedcom(seq, GENGEDCOM_STRONG_DUMP, eflg);
/* delay to last minute lest it is a temp owning seq,
eg, gengedcom(ancestorset(i)) */
delete_pvalue(val1);
return NULL;
}
/*=========================================+
* llrpt_parentset -- Create parent set of INDISEQ
* usage: parentset(SET) -> SET
*========================================*/
PVALUE
llrpt_parentset (PNODE node, SYMTAB stab, BOOLEAN *eflg)
{
INDISEQ seq=0;
PNODE arg1 = builtin_args(node);
PVALUE val1 = eval_and_coerce(PSET, arg1, stab, eflg);
if (*eflg) {
prog_var_error(node, stab, arg1, val1, nonset1, "parentset");
return NULL;
}
/* NULL indiseqs are possible, because of getindiset */
seq = pvalue_to_seq(val1);
/* do actual construction of parent set */
seq = parent_indiseq(seq);
set_pvalue_seq(val1, seq);
return val1;
}
/*=========================================+
* llrpt_uniqueset -- Eliminate dupes from INDISEQ
* usage: uniqueset(SET) -> VOID
*========================================*/
PVALUE
llrpt_uniqueset (PNODE node, SYMTAB stab, BOOLEAN *eflg)
{
INDISEQ seq=0;
PNODE arg1 = builtin_args(node);
PVALUE val1 = eval_and_coerce(PSET, arg1, stab, eflg);
if (*eflg) {
prog_var_error(node, stab, arg1, val1, nonset1, "uniqueset");
return NULL;
}
ASSERT(seq = pvalue_to_seq(val1));
unique_indiseq(seq);
/* delay to last minute lest it is a temp owning seq,
eg, uniqueset(ancestorset(i) */
delete_pvalue(val1);
return NULL;
}
/*===========================================+
* llrpt_deletefromset -- Remove person from INDISEQ
* usage: deletefromset(SET, INDI, BOOL) -> VOID
*==========================================*/
PVALUE
llrpt_deletefromset (PNODE node, SYMTAB stab, BOOLEAN *eflg)
{
NODE indi;
STRING key=0;
BOOLEAN all, rc;
INDISEQ seq;
PNODE arg1 = builtin_args(node), arg2 = inext(arg1),
arg3 = inext(arg2);
PVALUE val1 = eval_and_coerce(PSET, arg1, stab, eflg);
PVALUE val3=0;
if (*eflg) {
prog_var_error(node, stab, arg1, val1, nonsetx, "deletefromset", "1");
goto dfs_exit;
}
ASSERT(seq = pvalue_to_seq(val1));
indi = eval_indi(arg2, stab, eflg, NULL);
if (*eflg) {
prog_var_error(node, stab, arg2, NULL, nonindx, "deletefromset", "2");
goto dfs_exit;
}
if (!indi) goto dfs_exit;
*eflg = TRUE;
if (!(key = strsave(rmvat(nxref(indi))))) {
prog_error(node, "major error in deletefromset.");
goto dfs_exit;
}
*eflg = FALSE;
val3 = eval_and_coerce(PBOOL, arg3, stab, eflg);
if (*eflg) {
prog_var_error(node, stab, arg2, NULL, nonboox, "deletefromset", "3");
goto dfs_exit;
}
all = pvalue_to_bool(val3);
delete_pvalue(val3);
do {
rc = delete_indiseq(seq, key, NULL, 0);
} while (rc && all);
dfs_exit:
/* delay delete of val1 to last minute lest it is a temp owning seq,
eg, deletefromset(ancestorset(i),j) */
if (val1) delete_pvalue(val1);
if (key) strfree(&key);
return NULL;
}
/*======================================+
* llrpt_indiset -- Declare an INDISEQ variable
* usage: indiset(VARB) -> VOID
*=====================================*/
PVALUE
llrpt_indiset (PNODE node, SYMTAB stab, BOOLEAN *eflg)
{
INDISEQ newseq=0;
PVALUE newval=0;
PNODE arg1 = builtin_args(node);
if (!iistype(arg1, IIDENT)) {
*eflg = TRUE;
prog_var_error(node, stab, arg1, NULL, nonvar1, "indiset");
return NULL;
}
*eflg = FALSE;
newseq = create_indiseq_pval();
set_indiseq_value_funcs(newseq, &pvseq_fnctbl);
newval = create_pvalue_from_seq(newseq);
assign_iden(stab, iident_name(arg1), newval);
/* gave val1 to stab, so don't clear it */
return NULL;
}
/*========================================+
* llrpt_pagemode -- Switch output to page mode
* usage: pagemode(INT, INT) -> VOID
*======================================*/
PVALUE
llrpt_pagemode (PNODE node, SYMTAB stab, BOOLEAN *eflg)
{
INT cols=0, rows=0;
PNODE argvar = builtin_args(node);
PVALUE val = eval_and_coerce(PINT, argvar, stab, eflg);
if (*eflg) {
prog_var_error(node, stab, argvar, val, nonintx, "pagemode", "1");
delete_pvalue_ptr(&val);
return NULL;
}
rows = pvalue_to_int(val);
delete_pvalue_ptr(&val);
val = eval_and_coerce(PINT, argvar=inext(argvar), stab, eflg);
if (*eflg) {
prog_var_error(node, stab, argvar, val, nonintx, "pagemode", "2");
delete_pvalue_ptr(&val);
return NULL;
}
cols = pvalue_to_int(val);
delete_pvalue_ptr(&val);
*eflg = TRUE;
if (!(cols >= 1 && cols <= MAXCOLS)) {
*eflg = TRUE;
prog_var_error(node, stab, argvar, val, badargx, "pagemode", "1");
return NULL;
}
if (!(rows >= 1 && rows <= MAXROWS)) {
*eflg = TRUE;
prog_var_error(node, stab, argvar, val, badargx, "pagemode", "2");
return NULL;
}
*eflg = FALSE;
outputmode = PAGEMODE;
__rows = rows;
__cols = cols;
if (pagebuffer) stdfree(pagebuffer);
pagebuffer = (STRING) stdalloc(__rows*__cols);
memset(pagebuffer, ' ', __rows*__cols);
return NULL;
}
/*===================================
* llrpt_valuesort -- Sort INDISEQ by value
* usage: valuesort(SET) -> VOID
*=================================*/
PVALUE
llrpt_valuesort (PNODE node, SYMTAB stab, BOOLEAN *eflg)
{
INDISEQ seq;
PNODE arg1 = builtin_args(node);
PVALUE val1 = eval_and_coerce(PSET, arg1, stab, eflg);
if (*eflg) {
prog_var_error(node, stab, arg1, val1, nonset1, "valuesort");
return NULL;
}
ASSERT(seq = pvalue_to_seq(val1));
valuesort_indiseq(seq,eflg);
if (*eflg) {
prog_error(node, _("missing or incorrect value for sort"));
return NULL;
}
/* delay to last minute lest it is a temp owning seq,
eg, valuesort(ancestorset(i) */
delete_pvalue(val1);
return NULL;
}
/*==================================+
* llrpt_addtoset -- Add person to INDISEQ
* usage: addtoset(SET, INDI, ANY) -> VOID
*=================================*/
PVALUE
llrpt_addtoset (PNODE node, SYMTAB stab, BOOLEAN *eflg)
{
NODE indi=0;
STRING key=0;
INDISEQ seq=0;
PNODE arg1 = builtin_args(node), arg2 = inext(arg1),
arg3 = inext(arg2);
PVALUE val1 = eval_and_coerce(PSET, arg1, stab, eflg);
PVALUE val2=0;
if (*eflg) {
prog_var_error(node, stab, arg1, val1, nonsetx, "addtoset", "1");
return NULL;
}
ASSERT(seq = pvalue_to_seq(val1));
indi = eval_indi(arg2, stab, eflg, NULL);
if (*eflg) {
prog_var_error(node, stab, arg2, NULL, nonindx, "addtoset","2");
goto ats_exit;
}
if (!indi) goto ats_exit;
*eflg = TRUE;
if (!(key = strsave(rmvat(nxref(indi))))) {
prog_error(node, "major error in addtoset.");
goto ats_exit;
}
*eflg = FALSE;
val2 = evaluate(arg3, stab, eflg);
if (*eflg) {
prog_error(node, "3rd arg to addtoset is in error.");
goto ats_exit;
}
append_indiseq_pval(seq, key, NULL, val2, FALSE);
ats_exit:
if (key) strfree(&key); /* append made its own copy */
/* delay to last minute val1 cleanup lest it is a temp owning seq,
eg, addtoset(ancestorset(i),j) */
if (val1) delete_pvalue(val1);
return NULL;
}
/*===============================================+
* llrpt_pos -- Position page output to row and column
* usage: pos(INT, INT) -> VOID
*==============================================*/
PVALUE
llrpt_pos (PNODE node, SYMTAB stab, BOOLEAN *eflg)
{
INT col=0, row=0;
PNODE argvar = builtin_args(node);
PVALUE val = eval_and_coerce(PINT, argvar, stab, eflg);
if (*eflg) {
prog_var_error(node, stab, argvar, val, nonintx, "pos", "1");
delete_pvalue_ptr(&val);
return NULL;
}
row = pvalue_to_int(val);
if (row < 1 || row > __rows) {
*eflg = TRUE;
prog_var_error(node, stab, argvar, val, badargx, "pos", "1");
return NULL;
}
delete_pvalue_ptr(&val);
val = eval_and_coerce(PINT, argvar=inext(argvar), stab, eflg);
if (*eflg) {
prog_var_error(node, stab, argvar, val, nonintx, "pos", "2");
delete_pvalue_ptr(&val);
return NULL;
}
col = pvalue_to_int(val);
if (col < 1 || col > __cols) {
*eflg = TRUE;
prog_var_error(node, stab, argvar, val, badargx, "pos", "2");
return NULL;
}
delete_pvalue_ptr(&val);
if (outputmode != PAGEMODE) {
*eflg = TRUE;
prog_var_error(node, stab, NULL, val, "pos only valid in page mode");
return NULL;
}
currow = row;
curcol = col;
return NULL;
}
/*==================================+
* llrpt_col -- Position output to column
* usage: col(INT) -> VOID
*=================================*/
PVALUE
llrpt_col (PNODE node, SYMTAB stab, BOOLEAN *eflg)
{
INT newcol=0;
PNODE argvar = builtin_args(node);
PVALUE val = eval_and_coerce(PINT, argvar, stab, eflg);
if (*eflg) {
prog_var_error(node, stab, argvar, val, nonint1, "col");
delete_pvalue_ptr(&val);
return NULL;
}
newcol = pvalue_to_int(val);
delete_pvalue_ptr(&val);
if (newcol < 1) newcol = 1;
if (newcol > MAXCOLS) newcol = MAXCOLS;
if (newcol == curcol) return NULL;
if (newcol < curcol)
poutput("\n", eflg);
while (curcol < newcol && !(*eflg))
poutput(" ", eflg);
return NULL;
}
/*====================================+
* llrpt_inset -- See if person is in INDISEQ
* usage: inset(SET, INDI) -> BOOL
*==========================================*/
PVALUE
llrpt_inset (PNODE node, SYMTAB stab, BOOLEAN *eflg)
{
NODE indi;
STRING key=0;
INDISEQ seq;
BOOLEAN rel;
PNODE arg1 = builtin_args(node), arg2 = inext(arg1);
PVALUE val1 = eval_and_coerce(PSET, arg1, stab, eflg);
PVALUE valr=0;
if (*eflg ||!val1 || !(seq = pvalue_to_seq(val1))) {
*eflg = TRUE;
prog_var_error(node, stab, arg1, val1, nonsetx, "inset", "1");
goto inset_exit;
}
indi = eval_indi(arg2, stab, eflg, NULL);
if (*eflg) {
prog_var_error(node, stab, arg2, NULL, nonindx, "inset", "2");
goto inset_exit;
}
if (!indi) {
rel = FALSE;
} else {
if (!(key = strsave(rmvat(nxref(indi))))) {
*eflg = TRUE;
prog_error(node, "major error in inset.");
goto inset_exit;
}
rel = in_indiseq(seq, key);
}
valr = create_pvalue_from_bool(rel);
inset_exit:
/* delay delete of val1 to last minute lest it is a temp owning seq,
eg, inset(ancestorset(i),j) */
if (val1) delete_pvalue(val1);
if (key) strfree(&key);
return valr;
}
// This is where most of the strict/lazy distinction is.
static value_t *e_fncall(env_t *env, expr_t *fn, list_t *args)
{
value_t *fnv;
eli_closure_t c;
// Call-by-need (lazy function calls): suspend (thunk-ify) each
// argument in the given environment.
c.env = env;
c.list = list_empty();
list_iterate(args, thunk_list_i, &c);
list_reverse(c.list);
// Due to C's 'break' being imperfect, use 'goto' for clarity.
loop:
// Evaluate the function to a closure/data constructor in the given
// environment.
fnv = e_expr(env, fn);
switch (fnv->type) {
case v_datacons:
// Construct a new data constructor value; we need to do this in
// case the value we got from evaluating the "function" is shared.
{
value_t *dcv = alloc_value(v_datacons);
datacons_tag(dcv) = datacons_tag(fnv);
datacons_params(dcv) = list_append_new(datacons_params(fnv), c.list);
fnv = dcv;
}
break;
case v_closure:
{
int paramsArgs;
// Bind the closure's parameters to the given arguments in a new
// environment. At this point the original environment has
// served its purpose.
env = closure_env(fnv);
env_new_scope(&env);
paramsArgs = list_zip_with(closure_params(fnv),
c.list,
e_bind_params_i, env);
// See how the number of parameters and arguments relate.
switch (paramsArgs) {
case -1:
// Didn't get enough arguments, so wait for some more by
// building a new closure.
{
value_t *fn_unsaturated = alloc_value(v_closure);
closure_params(fn_unsaturated) = list_drop_new(list_length(c.list), closure_params(fnv));
closure_body(fn_unsaturated) = closure_body(fnv);
closure_env(fn_unsaturated) = env;
fnv = fn_unsaturated;
}
break;
case 0:
// Got exactly the right number of arguments. Evaluate the
// body in the extended environment.
fnv = e_expr(env, closure_body(fnv));
break;
case 1:
// Got too many arguments for this closure. Assuming
// type-correctness, that implies the body of this closure
// reduces to a function, so let's try again. Note the
// environment has already been updated.
fn = closure_body(fnv);
c.list = list_drop_new(list_length(closure_params(fnv)), c.list);
goto loop;
}
break;
case v_builtin_fn:
{
int nArgs;
int nParams;
// See how the number of parameters and arguments relate.
nArgs = list_length(c.list);
nParams = builtin_num_params(fnv);
if (nArgs < nParams) {
// Didn't get enough arguments, so wait for some more by
// building a new closure-like thing.
value_t *fn_unsaturated = alloc_value(v_builtin_fn);
builtin_num_params(fn_unsaturated) = nParams - nArgs;
builtin_args(fn_unsaturated) = builtin_args(fnv);
list_append(&builtin_args(fn_unsaturated), &c.list);
builtin_fn(fn_unsaturated) = builtin_fn(fnv);
return fn_unsaturated;
} else if (nArgs > nParams) {
// Got too many arguments. Assuming type-correctness, that
// implies the built-in function returns a function closure,
// so let's try again.
// FIXME
error("builtin function application is over-saturated.\n");
return NULL;
// value_t *result = builtin_fn(fnv)(list_take_new(builtin_num_params(fnv), c.list));
// fncall_fn(expr) = closure_body(fnv);
// c.list = list_drop_new(nParams, c.list);
// env = fn_env;
// break; /\* Loop *\/
} else {
// Got exactly the right number of arguments.
return builtin_fn(fnv)(c.list);
}
}
break;
default:
fprintf(stdout, "e_fncall: expression:\n");
pp_expr(stdout, fn, 2);
fprintf(stdout, "\non line %d evaluated to non-function/data constructor value:\n", fn->line_num);
print_value(stdout, fnv);
error("\n");
break;
}
}
return fnv;
}