R-alpha: Loss of workspace

Ross Ihaka (ihaka@stat.auckland.ac.nz)
Mon, 9 Sep 1996 11:08:40 +1200


Date: Mon, 9 Sep 1996 11:08:40 +1200
From: Ross Ihaka <ihaka@stat.auckland.ac.nz>
Message-Id: <199609082308.LAA09604@stat.auckland.ac.nz>
To: Martyn Plummer <plummer@iarc.fr>
Subject: R-alpha: Loss of workspace
In-Reply-To: <199609061305.PAA23932@hypatia.math.ethz.ch>

Martyn Plummer writes:
 > Yesterday I managed to erase my whole workspace after an escalating
 > sequence of errors (see below).

Here is a fix to the editing problem which began the error cascade.
I will also look at making the saving of images behave better
if there are problems during the save.

The editor fix will be in 0.11 which is almost ready to ship.  Fixes
to "save" will have to wait for 0.12.
	Ross


The code below should be used to relace RHOME/src/main/builtin.c
in release 0.10.

- - - s n i p - - s n i p - - -
/*
 *  R : A Computer Langage for Statistical Data Analysis
 *  Copyright (C) 1995, 1996  Robert Gentleman and Ross Ihaka
 *
 *  This program is free software; you can redistribute it and/or modify
 *  it under the terms of the GNU General Public License as published by
 *  the Free Software Foundation; either version 2 of the License, or
 *  (at your option) any later version.
 *
 *  This program is distributed in the hope that it will be useful,
 *  but WITHOUT ANY WARRANTY; without even the implied warranty of
 *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 *  GNU General Public License for more details.
 *
 *  You should have received a copy of the GNU General Public License
 *  along with this program; if not, write to the Free Software
 *  Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
 */

#include "Defn.h"
#include "Print.h"

static char EdFiLeName[100];

SEXP parse(FILE *, int);

SEXP do_onexit(SEXP call, SEXP op, SEXP args, SEXP rho)
{
	RCNTXT *ctxt;
	SEXP code;

	switch (length(args)) {
	case 0:
		code = R_NilValue;
		break;
	case 1:
		code = CAR(args);
		break;
	default:
		errorcall(call, "invalid number of arguments\n");
	}
	ctxt = R_GlobalContext;
	while (ctxt != R_ToplevelContext && ctxt->callflag != CTXT_RETURN)
		ctxt = ctxt->nextcontext;
	if (ctxt->callflag == CTXT_RETURN)
		ctxt->conexit = code;
	return R_NilValue;
}

SEXP do_args(SEXP call, SEXP op, SEXP args, SEXP rho)
{
	SEXP s;

	checkArity(op,args);

	if (TYPEOF(CAR(args)) == STRSXP && length(CAR(args))==1) {
		PROTECT(s = install(CHAR(STRING(CAR(args))[0])));
		CAR(args) = findFun(s, rho);
		UNPROTECT(1);
	}

	if (TYPEOF(CAR(args)) == CLOSXP) {
		s=allocSExp(CLOSXP);
		FORMALS(s)=FORMALS(CAR(args));
		BODY(s)=R_NilValue;
		CLOENV(s)=R_GlobalEnv;
		return(s);
	}

	return R_NilValue;
}

SEXP do_formals(SEXP call, SEXP op, SEXP args, SEXP rho)
{
	checkArity(op, args);

	if( TYPEOF(CAR(args)) == CLOSXP )
		return duplicate(FORMALS(CAR(args)));
	else
		return R_NilValue;
}

SEXP do_envir(SEXP call, SEXP op, SEXP args, SEXP rho)
{
	checkArity(op, args);

	if (TYPEOF(CAR(args)) == CLOSXP)
		return CLOENV(CAR(args));
	else if (CAR(args) == R_NilValue)
		return R_GlobalContext->sysparent;
	return R_NilValue;
}

SEXP do_envirgets(SEXP call, SEXP op, SEXP args, SEXP rho)
{
	checkArity(op, args);

	if (TYPEOF(CAR(args)) == CLOSXP && TYPEOF(CADR(args)) == ENVSXP)
		CLOENV(CAR(args)) = CADR(args);
	else
		errorcall(call, "invalid arguments\n");
	return CAR(args);
}

static void cat_newline(SEXP labels, int * width, int lablen, int ntot)
{
	Rprintf("\n");
	*width = 0;
	if (labels != R_NilValue) {
		Rprintf("%s ", EncodeString(CHAR(STRING(labels)[ntot % lablen]), 1, 0));
		*width += Rstrlen(CHAR(STRING(labels)[ntot % lablen])) + 1;
	}
}

static void cat_sepwidth(SEXP sep, int * width, int ntot)
{
	if (sep == R_NilValue || LENGTH(sep) == 0)
		*width = 0;
	else
		*width = Rstrlen(CHAR(STRING(sep)[ntot % LENGTH(sep)]));
}

static void cat_printsep(SEXP sep, int ntot)
{
	char *sepchar;

	if (sep == R_NilValue || LENGTH(sep) == 0)
		return;

	sepchar = CHAR(STRING(sep)[ntot % LENGTH(sep)]);
	Rprintf("%s",sepchar);
	return;
}


SEXP do_cat(SEXP call, SEXP op, SEXP args, SEXP rho)
{
	SEXP a, objs, file, fill, sepr, labs, s, levels;
	FILE *savefp;
	int havefile, append;
	int w, i, n, pwidth, width, sepw, lablen, ntot, nlsep;
	char *p;

	checkArity(op, args);
	
		/* Use standard printing defaults */

	PrintDefaults();

	objs = CAR(args); args = CDR(args);

	file = CAR(args); args = CDR(args);
	if(!isString(file) || length(file) != 1)
		errorcall(call, "invalid file= specification\n");

	sepr = CAR(args); args = CDR(args);
	if (!isString(sepr))
		errorcall(call, "invalid sep= specification\n");
	nlsep = 0;
	for (i = 0; i < LENGTH(sepr); i++)
		if (streql(CHAR(STRING(sepr)[i]), "\n")) nlsep = 1;

	fill = CAR(args); args = CDR(args);
	if ((!isNumeric(fill) && !isLogical(fill)) || (length(fill) != 1))
		errorcall(call, "invalid fill argument\n");
	if (isLogical(fill)) {
		if (asLogical(fill) == 1)
			pwidth = PRINT_WIDTH;
		else
			pwidth = INT_MAX;
	}
	else pwidth = asInteger(fill);

	labs = CAR(args); args = CDR(args);
	if (!isString(labs) && labs != R_NilValue)
		errorcall(call, "invalid label argument\n");
	lablen = length(labs);

	append = asLogical(CAR(args));
	if(append == NA_LOGICAL)
		errorcall(call, "invalid append specification\n");

	if (strlen(CHAR(STRING(file)[0])) > 0) {
		savefp = R_Outputfile;
		if (append)
			R_Outputfile = fopen(CHAR(STRING(file)[0]), "a");
		else
			R_Outputfile = fopen(CHAR(STRING(file)[0]), "w");
		if (!R_Outputfile) {
			R_Outputfile = savefp;
			errorcall(call, "unable to open file\n");
		}
		havefile = 1 ;
	}
	else havefile = 0;

	n = 0;
	for (a = objs; a != R_NilValue; a = CDR(a)) {
		if (!isVector(CAR(a)))
			errorcall(call, "argument %d has invalid type\n", n+1);
		n += 1;
	}
	width = 0;
	ntot = 0;
	for (a = objs; a != R_NilValue; a = CDR(a)) {
		s = CAR(a);
		if (a != objs)
			cat_printsep(sepr, 0);
		n = LENGTH(s);
		if (n > 0) {
			if (labs != R_NilValue && a == objs) {
				Rprintf("%s ", CHAR(STRING(labs)[0]));
				width += strlen(CHAR(STRING(labs)[ntot % lablen])) + 1;
				ntot++;
			}
			if(isString(s))
				p = CHAR(STRING(s)[0]);
			else
				p = EncodeElement(s, 0, 0);
			w = strlen(p);
			cat_sepwidth(sepr, &sepw, ntot);
			if (a != objs && (width + w + sepw > pwidth))
				cat_newline(labs, &width, lablen, ntot);
			for (i = 0; i < n; i++, ntot++) {
				Rprintf("%s", p);
				width += w + sepw;
				if (i < (n - 1)) {
					cat_printsep(sepr, ntot);
					if(isString(s))
						p = CHAR(STRING(s)[i+1]);
					else
						p = EncodeElement(s, i+1, 0);
					cat_sepwidth(sepr, &sepw, ntot);
					if ((width + w + sepw > pwidth) && pwidth)
						cat_newline(labs, &width, lablen, ntot);
				}
			}
		}
	}
	if ((pwidth != INT_MAX) || nlsep)
		Rprintf("\n");
	if (havefile) {
		fclose(R_Outputfile);
		R_Outputfile = savefp;
	}
	else
		fflush(stdout);
	return R_NilValue;
}


SEXP do_makelist(SEXP call, SEXP op, SEXP args, SEXP rho)
{
	SEXP s = args;
	while (s != R_NilValue) {
		if (NAMED(CAR(s)))
			CAR(s) = duplicate(CAR(s));
		s = CDR(s);
	}
	return args;
}


SEXP do_makefactor(SEXP call, SEXP op, SEXP args, SEXP rho)
{
	SEXP x, y;
	int i, j, nx, nl, ord;

	checkArity(op, args);
	x = CAR(args) = coerceVector(CAR(args), INTSXP);
	nl = asInteger(CADR(args));
	if (nl == NA_INTEGER || nl < 1)
		errorcall(call, "invalid number of factor levels\n");
	ord = asLogical(CADDR(args));
	if(ord == NA_LOGICAL) ord = 0;
	nx = LENGTH(x);
	y = allocVector(ord ? ORDSXP : FACTSXP, nx);
	LEVELS(y) = nl;
	for (i = 0; i < nx; i++) {
		j = INTEGER(x)[i];
		if (1 <= j && j <= nl)
			FACTOR(y)[i] = j;
		else
			FACTOR(y)[i] = NA_INTEGER;
	}
	return y;
}

SEXP do_makevector(SEXP call, SEXP op, SEXP args, SEXP rho)
{
	int len, i;
	SEXP s;
	SEXPTYPE mode;

	checkArity(op, args);

	len = asInteger(CADR(args));
	s = coerceVector(CAR(args), STRSXP);
	mode = str2type(CHAR(STRING(s)[0]));
	if (mode == -1 && streql(CHAR(STRING(s)[0]), "double"))
		mode = REALSXP;
	if ((CHARSXP < mode) && (mode <= STRSXP))
		s = allocVector(mode, len);
	else if (mode == LISTSXP)
		s = allocList(len);
	else
		error("vector: cannot make a vector of the type specified\n");
	if (mode == INTSXP)
		for (i = 0; i < len; i++)
			INTEGER(s)[i] = 0;
	else if (mode == REALSXP)
		for (i = 0; i < len; i++)
			REAL(s)[i] = 0.0;
	return s;
}


	/* do_lengthgets: assign a length to a vector or a list */
	/* (if it is vectorizable). We could probably be fairly */
	/* clever with memory here if we wanted to. */

SEXP do_lengthgets(SEXP call, SEXP op, SEXP args, SEXP rho)
{
	int len, lenx, i;
	SEXP rval, x, names, xnames, t;

	checkArity(op, args);
	x = CAR(args);

	if (!isVector(x) && !isVectorizable(x))
		error("length<- invalid first argument\n");

	if (length(CADR(args)) != 1)
		error("length<- invalid second argument\n");

	len = asInteger(CADR(args));
	if (len == NA_INTEGER)
		error("length<- missing value for length\n");

	lenx = length(x);
	if (lenx == len)
		return (x);

	rval = allocVector(TYPEOF(x), len);

	PROTECT(xnames = getAttrib(x, R_NamesSymbol));
	if (xnames != R_NilValue)
		names = allocVector(STRSXP, len);

	switch (TYPEOF(x)) {
	case LGLSXP:
	case FACTSXP:
	case ORDSXP:
	case INTSXP:
		for (i = 0; i < len; i++)
			if (i < lenx) {
				INTEGER(rval)[i] = INTEGER(x)[i];
				if (xnames != R_NilValue)
					STRING(names)[i] = STRING(xnames)[i];
			}
			else
				INTEGER(rval)[i] = NA_INTEGER;
		break;
	case REALSXP:
		for (i = 0; i < len; i++)
			if (i < lenx) {
				REAL(rval)[i] = REAL(x)[i];
				if (xnames != R_NilValue)
					STRING(names)[i] = STRING(xnames)[i];
			}
			else
				REAL(rval)[i] = NA_REAL;
		break;
	case STRSXP:
		for (i = 0; i < len; i++)
			if (i < lenx) {
				STRING(rval)[i] = STRING(x)[i];
				if (xnames != R_NilValue)
					STRING(names)[i] = STRING(xnames)[i];
			}
			else
				STRING(rval)[i] = NA_STRING;
		break;
	case LISTSXP:
		for (t = rval; t != R_NilValue; t = CDR(t), x = CDR(x)) {
			CAR(t) = CAR(x);
			TAG(t) = TAG(x);
		}
	}
	if (isVector(x) && xnames != R_NilValue)
		setAttrib(rval, R_NamesSymbol, names);
	UNPROTECT(1);
	return rval;
}

SEXP do_assign(SEXP call, SEXP op, SEXP args, SEXP rho)
{
	SEXP name, val, aenv;
	int ginherits;

	checkArity(op, args);
	name = findVar(CAR(args), rho);

	PROTECT(args = evalList(args, rho));

	if (!isString(CAR(args)))
		error("assign: invalid argument\n");
	else
		name = install(CHAR(STRING(CAR(args))[0]));
	PROTECT(val = eval(CADR(args), rho));

	R_Visible = 0;

	aenv = CAR(CDDR(args));
	if (TYPEOF(aenv) != ENVSXP && aenv != R_NilValue)
		error("invalid envir argument\n");

	if (isLogical(CAR(nthcdr(args, 3))))
		ginherits = LOGICAL(CAR(nthcdr(args, 3)))[0];
	else
		error("get: invalid inherits argument\n");
	if (ginherits)
		setVar(name, val, aenv);
	else
		defineVar(name, val, aenv);
	UNPROTECT(2);
	return R_NilValue;
}

/*
 * do_remove has 3 arguments, a list of names to remove, an optional
 * environment (if missing set it to R_GlobalEnv) and inherits, a logical
 * indicating whether to look in the parent env if a symbol is not found in
 * the supplied env. This is ignored if environment is not specified
 */

SEXP do_remove(SEXP call, SEXP op, SEXP args, SEXP rho)
{
	SEXP name, aenv, tsym, tenv, tframe;
	int ginherits;
	int set,i,len;

	checkArity(op, args);

	name = CAR(args);
	if (!isString(name))
		error("invalid first argument to remove.\n");

	if (CADR(args) != R_NilValue) {
		if (TYPEOF(CADR(args)) != ENVSXP)
			error("invalid envir argument\n");
		else
			aenv = CADR(args);
	}
	else
		aenv = R_GlobalContext->sysparent;

	if (isLogical(CAR(nthcdr(args, 2))))
		ginherits = LOGICAL(CAR(nthcdr(args, 2)))[0];
	else
		error("get: invalid inherits argument\n");

	for (i=0 ; i<LENGTH(name) ; i++) {
		set = 0;
		tsym = install(CHAR(STRING(name)[i]));
		tenv = aenv;
	rmset:	for (tframe = FRAME(tenv); tframe != R_NilValue; tframe = CDR(tframe))
			if (TAG(tframe) == tsym) {
				unbindVar(tsym, tenv);
				set = 1;
			}
		if (ginherits && !set && (tenv = ENCLOS(tenv)) != R_NilValue)
			goto rmset;
		if (!set)
			warning("remove: variable \"%s\" was not found\n", CHAR(PRINTNAME(tsym)));
	}
	return R_NilValue;
}

/*
 * do_get returns the SEXP associated with the character argument, do_get
 * needs the environment of the calling function as a default,
 * 
 */

#define FUNSXP 999

SEXP do_get(SEXP call, SEXP op, SEXP args, SEXP rho)
{
	SEXP rval, genv, t1;
	SEXPTYPE gmode;
	int ginherits, where;

	checkArity(op, args);

	/* set up the default environment */
	rval = findVar(CAR(args), rho);
	if (TYPEOF(rval) == PROMSXP)
		genv = PRENV(rval);

	args = evalList(args, rho);

	if (!isString(CAR(args)))
		error("get: invalid first argument\n");
	else
		t1 = install(CHAR(STRING(CAR(args))[0]));
	if (CADR(args) != R_NilValue) {
		if (TYPEOF(CADR(args)) == REALSXP || TYPEOF(CADR(args)) == INTSXP) {
			where = asInteger(CADR(args));
			genv = sysframe(where,R_GlobalContext);
		}
		else if (TYPEOF(CADR(args)) != ENVSXP)
			errorcall(call,"invalid envir argument\n");
		else
			genv = CADR(args);
	}
	if (isString(CAR(CDDR(args)))) {
		if(!strcmp(CHAR(STRING(CAR(CDDR(args)))[0]),"function"))
			gmode = FUNSXP;
		else 
			gmode = str2type(CHAR(STRING(CAR(CDDR(args)))[0]));
	} else errorcall(call,"invalid mode argument\n");

	if (isLogical(CAR(nthcdr(args, 3))))
		ginherits = LOGICAL(CAR(nthcdr(args, 3)))[0];
	else
		errorcall(call,"invalid inherits argument\n");

	rval = findVar1(t1, genv, gmode, ginherits);

	if (PRIMVAL(op)) {	/* we have a get */
		if (rval == R_UnboundValue)
			errorcall(call,"variable \"%s\" was not found\n", CHAR(PRINTNAME(t1)));
		rval = eval(rval, genv);
		NAMED(rval) = 1;
		return rval;
	}
	else {
		if (rval == R_UnboundValue)
			ginherits = 0;
		else
			ginherits = 1;
		rval = allocVector(LGLSXP, 1);
		LOGICAL(rval)[0] = ginherits;
		return (rval);
	}
}

SEXP findVar1(SEXP symbol, SEXP rho, SEXPTYPE mode, int inherits)
{
	SEXP vl;

	while (rho != R_NilValue) {
		vl = findVarInFrame(FRAME(rho), symbol);
		if (vl != R_UnboundValue ) {
			if(mode == ANYSXP || TYPEOF(vl) == mode) return vl;
			if(mode == FUNSXP && (
				TYPEOF(vl) == CLOSXP ||
				TYPEOF(vl) == BUILTINSXP ||
				TYPEOF(vl) == SPECIALSXP)) return (vl);
		}
		if (inherits)
			rho = ENCLOS(rho);
		else
			return (R_UnboundValue);
	}
	return (SYMVALUE(symbol));
}


/*
 * for switch, evaluate the first arg, if it is a character then try to match
 * the name with the remaining args, and evaluate the match, if there is no
 * match then evaluate the first unnamed arg.  If the value of the first arg 
 * is not a character string then coerce it to integer (k) and choose the kth 
 * argument from those that remain provided 0 < k < (nargs-1)
 * For character matching, if the value is missing then take the next 
 * non-missing arg as the value
 * then things like
 *  switch(as.character(answer), yes=, YES=1, no=, NO=2, 3)
 * work
 */

SEXP switchList(SEXP el, SEXP rho)
{
	SEXP rlist, s, w, h;

	if (CAR(el) == R_DotsSymbol) {
		h = findVar(CAR(el), rho);
		if (h == R_NilValue)
			return R_NilValue;
		if (TYPEOF(h) != DOTSXP) {
			if (h == R_MissingArg)
				return R_MissingArg;
			error("... used in an incorrect context\n");
		}
		return h;
	}
	else
		error("bad parameter in switch \n");
}

SEXP do_switch(SEXP call, SEXP op, SEXP args, SEXP rho)
{
	int argval;
	SEXP x, y, w;

	x = eval(CAR(args), rho);
	if (!isVector(x) && length(x) != 1)
		error("switch: EXPR must return a length 1 vector\n");

	PROTECT(w = switchList(CDR(args), rho));
	if (isString(x)) {
		for (y = w; y != R_NilValue; y = CDR(y))
			if (streql(CHAR(STRING(x)[0]), CHAR(PRINTNAME(TAG(y))))) {
				while (CAR(y) == R_MissingArg && y != R_NilValue)
					y = CDR(y);
				UNPROTECT(1);
				return (eval(CAR(y), rho));
			}
		for (y = w; y != R_NilValue; y = CDR(y))
			if (TAG(y) == R_NilValue) {
				UNPROTECT(1);
				return (eval(CAR(y), rho));
			}
		UNPROTECT(1);
		return R_NilValue;
	}
	argval = asInteger(x);
	if (argval <= 0 || argval > (length(w))) {
		UNPROTECT(1);
		return R_NilValue;
	}
	x = eval(CAR(nthcdr(w, argval - 1)), rho);
	UNPROTECT(1);
	return x;
}

void InitEd()
{
	tmpnam(EdFiLeName);
}

/*
 * ed, vi etc have 3 parameters. the data, a file and an editor
 * 
 * if file is specified then the given file is used (and not removed on exit) if
 * file is not specified then a temporary file is used; since only one
 * temporary file is used for an entire session previous editing is lost
 * 
 * if data is specified then it is passed out to be edited; if data is not
 * specified then either file (if specified) or the temporary file is used
 * (thus errors can be re-editied by calling edit a second time with no
 * arguments).
 * 
 * if the editor is specified then the specified editor is invoked if possible
 * and an error message reported otherwise
 */

SEXP do_edit(SEXP call, SEXP op, SEXP args, SEXP rho)
{
	int i, protected=0;
	SEXP x, fn, envir, ed;
	char tmpn[120], tmp2[140];
	FILE *fp;

	checkArity(op, args);

	x = CAR(args);
	if (TYPEOF(x) == CLOSXP) envir = CLOENV(x);
	else envir = NULL;
	PROTECT(envir);

	fn = CADR(args);
	if (!isString(fn))
		error("invalid argument to edit()\n");
	if (LENGTH(STRING(fn)[0]) == 0)
		strcpy(tmpn, EdFiLeName);
	else
		strcpy(tmpn, CHAR(STRING(fn)[0]));

	if (x != R_NilValue) {
		fp = fopen(tmpn, "w");
		if (!fp)
			error("edit: unable to open file\n");
		x = deparse1(x, 0);
		for (i = 0; i < LENGTH(x); i++)
			fprintf(fp, "%s\n", CHAR(STRING(x)[i]));
		fclose(fp);
	}

	ed = CAR(CDDR(args));
	if (!isString(ed))
		error("editor type not valid\n");
	strcpy(tmp2, CHAR(STRING(ed)[0]));
	strcat(tmp2, " ");
	system(strcat(tmp2, tmpn));

	fp = fopen(tmpn, "r");
	if (!fp) error("edit: unable to open file to read\n");;
	x = parse(fp, 1);
	if (R_ParseError) {
		error("An error occurred on line %d\n use a command like\n x <- vi()\n to recover\n", R_ParseError);
	}
	ResetConsole();
	x = eval(CAR(x), R_GlobalEnv);
	if (TYPEOF(x) == CLOSXP && envir != R_NilValue)
		CLOENV(x) = envir;
	UNPROTECT(1);
	return (x);
}
=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
r-testers mailing list -- To (un)subscribe, send
subscribe	or	unsubscribe
(in the "body", not the subject !)  To: r-testers-request@stat.math.ethz.ch
=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-