The R Project SVN R

Rev

Rev 61399 | Rev 64656 | Go to most recent revision | Details | Compare with Previous | Last modification | View Log | RSS feed

Rev Author Line No. Line
2 r 1 
/*
2 
 *  R : A Computer Langage for Statistical Data Analysis
3 
 *  Copyright (C) 1995, 1996  Robert Gentleman and Ross Ihaka
62580 ripley 4 
 *  Copyright (C) 2001-13     The R Core Team
2 r 5 
 *
6 
 *  This program is free software; you can redistribute it and/or modify
7 
 *  it under the terms of the GNU General Public License as published by
8 
 *  the Free Software Foundation; either version 2 of the License, or
9 
 *  (at your option) any later version.
10 
 *
11 
 *  This program is distributed in the hope that it will be useful,
12 
 *  but WITHOUT ANY WARRANTY; without even the implied warranty of
13 
 *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
14 
 *  GNU General Public License for more details.
15 
 *
16 
 *  You should have received a copy of the GNU General Public License
42307 ripley 17 
 *  along with this program; if not, a copy is available at
18 
 *  http://www.r-project.org/Licenses/
2 r 19 
 */
20 
 
5187 hornik 21 
#ifdef HAVE_CONFIG_H
7701 hornik 22 
#include <config.h>
5187 hornik 23 
#endif
24 
 
57538 ripley 25 
#define R_USE_SIGNALS 1
11668 ripley 26 
#include <Defn.h>
60667 ripley 27 
#include <Internal.h>
11668 ripley 28 
#include <Fileio.h>
29 
#include <IOStuff.h>
30 
#include <Parse.h>
31 
#include <Rconnections.h>
2 r 32 
 
291 ihaka 33 
extern IoBuffer R_ConsoleIob;
2 r 34 
 
44201 ripley 35 
SEXP attribute_hidden getParseContext(void)
35498 murdoch 36 
{
37 
    int i, last = PARSE_CONTEXT_SIZE;
38 
    char context[PARSE_CONTEXT_SIZE+1];
39 
 
40 
    SEXP ans = R_NilValue, ans2;
55061 ripley 41 
    int nn, nread;
35498 murdoch 42 
    char c;
43 
 
44 
    context[last] = '\0';
47713 murdoch 45 
    for (i=R_ParseContextLast; last>0 ; i += PARSE_CONTEXT_SIZE - 1) {
35498 murdoch 46 
	i = i % PARSE_CONTEXT_SIZE;
47 
	context[--last] = R_ParseContext[i];
48 
	if (!context[last]) {
49 
	    last++;
50 
	    break;
51 
	}
52 
    }
40705 ripley 53 
 
35498 murdoch 54 
    nn = 16; /* initially allocate space for 16 lines */
55 
    PROTECT(ans = allocVector(STRSXP, nn));
56 
    c = context[last];
57 
    nread = 0;
58 
    while(c) {
45446 ripley 59 
	nread++;
35498 murdoch 60 
	if(nread >= nn) {
61 
	    ans2 = allocVector(STRSXP, 2*nn);
62 
	    for(i = 0; i < nn; i++)
63 
		SET_STRING_ELT(ans2, i, STRING_ELT(ans, i));
64 
	    nn *= 2;
65 
	    UNPROTECT(1); /* old ans */
66 
	    PROTECT(ans = ans2);
67 
	}
68 
	i = last;
42147 murdoch 69 
	while((c = context[i++])) {
35498 murdoch 70 
	    if(c == '\n') break;
71 
	}
42147 murdoch 72 
	context[i-1] = '\0';
35498 murdoch 73 
	SET_STRING_ELT(ans, nread-1, mkChar(context + last));
40220 murdoch 74 
	last = i;
35498 murdoch 75 
    }
76 
    /* get rid of empty line after last newline */
47481 murdoch 77 
    if (nread && !length(STRING_ELT(ans, nread-1))) {
78 
    	nread--;
79 
    	R_ParseContextLine--;
80 
    }
35498 murdoch 81 
    PROTECT(ans2 = allocVector(STRSXP, nread));
82 
    for(i = 0; i < nread; i++)
83 
	SET_STRING_ELT(ans2, i, STRING_ELT(ans, i));
84 
    UNPROTECT(2);
85 
    return ans2;
40705 ripley 86 
}
35498 murdoch 87 
 
55743 luke 88 
static void getParseFilename(char* buffer, size_t buflen)
39996 murdoch 89 
{
90 
    buffer[0] = '\0';
61399 murdoch 91 
    if (R_ParseErrorFile) {
92 
    	if (isEnvironment(R_ParseErrorFile)) {
93 
	    SEXP filename;
94 
	    PROTECT(filename = findVar(install("filename"), R_ParseErrorFile));
95 
	    if (isString(filename) && length(filename))
96 
	        strncpy(buffer, CHAR(STRING_ELT(filename, 0)), buflen - 1);
97 
	    UNPROTECT(1);
98 
        } else if (isString(R_ParseErrorFile) && length(R_ParseErrorFile))
99 
            strncpy(buffer, CHAR(STRING_ELT(R_ParseErrorFile, 0)), buflen - 1);
100 
    }
39996 murdoch 101 
}
102 
 
47713 murdoch 103 
static SEXP tabExpand(SEXP strings)
104 
{
105 
    int i;
106 
    char buffer[200], *b;
107 
    const char *input;
108 
    SEXP result;
48500 murdoch 109 
    PROTECT(strings);
47713 murdoch 110 
    PROTECT(result = allocVector(STRSXP, length(strings)));
111 
    for (i = 0; i < length(strings); i++) {
112 
    	input = CHAR(STRING_ELT(strings, i));
55757 ripley 113 
    	for (b = buffer; *input && (b-buffer < 192); input++) {
47713 murdoch 114 
    	    if (*input == '\t') do {
115 
    	    	*b++ = ' ';
116 
    	    } while (((b-buffer) & 7) != 0);
117 
    	    else *b++ = *input;
118 
    	}
119 
    	*b = '\0';
120 
    	SET_STRING_ELT(result, i, mkCharCE(buffer, Rf_getCharCE(STRING_ELT(strings, i))));
121 
    }
48500 murdoch 122 
    UNPROTECT(2);
47713 murdoch 123 
    return result;
124 
}
125 
 
60757 ripley 126 
void parseError(SEXP call, int linenum)
35498 murdoch 127 
{
47713 murdoch 128 
    SEXP context;
129 
    int len, width;
130 
    char filename[128], buffer[10];
131 
    PROTECT(context = tabExpand(getParseContext()));
132 
    len = length(context);
35498 murdoch 133 
    if (linenum) {
45446 ripley 134 
	getParseFilename(filename, sizeof(filename)-2);
47481 murdoch 135 
	if (strlen(filename)) strcpy(filename + strlen(filename), ":");
40705 ripley 136 
 
35498 murdoch 137 
	switch (len) {
40705 ripley 138 
	case 0:
60844 ripley 139 
	    error("%s%d:%d: %s",
47481 murdoch 140 
		  filename, linenum, R_ParseErrorCol, R_ParseErrorMsg);
40705 ripley 141 
	    break;
58489 ripley 142 
	case 1: // replaces use of %n
62580 ripley 143 
	    width = snprintf(buffer, 10, "%d: ", R_ParseContextLine);
60844 ripley 144 
	    error("%s%d:%d: %s\n%d: %s\n%*s",
47481 murdoch 145 
		  filename, linenum, R_ParseErrorCol, R_ParseErrorMsg,
47713 murdoch 146 
		  R_ParseContextLine, CHAR(STRING_ELT(context, 0)),
147 
		  width+R_ParseErrorCol, "^");
40705 ripley 148 
	    break;
149 
	default:
62580 ripley 150 
	    width = snprintf(buffer, 10, "%d:", R_ParseContextLine);
60844 ripley 151 
	    error("%s%d:%d: %s\n%d: %s\n%d: %s\n%*s",
47481 murdoch 152 
		  filename, linenum, R_ParseErrorCol, R_ParseErrorMsg,
153 
		  R_ParseContextLine-1, CHAR(STRING_ELT(context, len-2)),
47713 murdoch 154 
		  R_ParseContextLine, CHAR(STRING_ELT(context, len-1)),
155 
		  width+R_ParseErrorCol, "^");
40705 ripley 156 
	    break;
35498 murdoch 157 
	}
158 
    } else {
159 
	switch (len) {
40705 ripley 160 
	case 0:
60844 ripley 161 
	    error("%s", R_ParseErrorMsg);
40705 ripley 162 
	    break;
163 
	case 1:
60844 ripley 164 
	    error("%s in \"%s\"",
41715 ripley 165 
		  R_ParseErrorMsg, CHAR(STRING_ELT(context, 0)));
40705 ripley 166 
	    break;
167 
	default:
60844 ripley 168 
	    error("%s in:\n\"%s\n%s\"",
41715 ripley 169 
		  R_ParseErrorMsg, CHAR(STRING_ELT(context, len-2)),
170 
		  CHAR(STRING_ELT(context, len-1)));
40705 ripley 171 
	    break;
172 
	}
35498 murdoch 173 
    }
47713 murdoch 174 
    UNPROTECT(1);
35498 murdoch 175 
}
176 
 
54018 ripley 177 
static void con_cleanup(void *data)
178 
{
179 
    Rconnection con = data;
180 
    if(con->isopen) con->close(con);
181 
}
182 
 
6189 maechler 183 
/* "do_parse" - the user interface input/output to files.
2 r 184 
 
6189 maechler 185 
 The internal R_Parse.. functions are defined in ./gram.y (-> gram.c)
2 r 186 
 
50833 ripley 187 
 .Internal( parse(file, n, text, prompt, srcfile, encoding) )
6189 maechler 188 
 If there is text then that is read and the other arguments are ignored.
189 
*/
36990 ripley 190 
SEXP attribute_hidden do_parse(SEXP call, SEXP op, SEXP args, SEXP env)
2 r 191 
{
39996 murdoch 192 
    SEXP text, prompt, s, source;
11656 ripley 193 
    Rconnection con;
50833 ripley 194 
    Rboolean wasopen, old_latin1 = known_to_be_latin1,
195 
	old_utf8 = known_to_be_utf8, allKnown = TRUE;
46864 ripley 196 
    int ifile, num, i;
41807 rgentlem 197 
    const char *encoding;
25961 ripley 198 
    ParseStatus status;
54018 ripley 199 
    RCNTXT cntxt;
11656 ripley 200 
 
1839 ihaka 201 
    checkArity(op, args);
202 
    R_ParseError = 0;
39996 murdoch 203 
    R_ParseErrorMsg[0] = '\0';
2 r 204 
 
11656 ripley 205 
    ifile = asInteger(CAR(args));                       args = CDR(args);
206 
 
207 
    con = getConnection(ifile);
208 
    wasopen = con->isopen;
6201 maechler 209 
    num = asInteger(CAR(args));				args = CDR(args);
35189 tlumley 210 
    if (num == 0)
45446 ripley 211 
	return(allocVector(EXPRSXP, 0));
51330 ripley 212 
 
213 
    PROTECT(text = coerceVector(CAR(args), STRSXP));
214 
    if(length(CAR(args)) && !length(text))
215 
	errorcall(call, _("coercion of 'text' to character was unsuccessful"));
216 
    args = CDR(args);
6201 maechler 217 
    prompt = CAR(args);					args = CDR(args);
39996 murdoch 218 
    source = CAR(args);					args = CDR(args);
40672 ripley 219 
    if(!isString(CAR(args)) || LENGTH(CAR(args)) != 1)
41715 ripley 220 
	error(_("invalid '%s' value"), "encoding");
40705 ripley 221 
    encoding = CHAR(STRING_ELT(CAR(args), 0)); /* ASCII */
40672 ripley 222 
    known_to_be_latin1 = known_to_be_utf8 = FALSE;
46864 ripley 223 
    /* allow 'encoding' to override declaration on 'text'. */
224 
    if(streql(encoding, "latin1")) {
225 
	known_to_be_latin1 = TRUE;
226 
	allKnown = FALSE;
48572 murdoch 227 
    } else if(streql(encoding, "UTF-8"))  {
46864 ripley 228 
	known_to_be_utf8 = TRUE;
229 
	allKnown = FALSE;
50186 murdoch 230 
    } else if(!streql(encoding, "unknown") && !streql(encoding, "native.enc"))
48572 murdoch 231 
    	warning(_("argument '%s = \"%s\"' will be ignored"), "encoding", encoding);
46864 ripley 232 
 
1839 ihaka 233 
    if (prompt == R_NilValue)
234 
	PROTECT(prompt);
235 
    else
236 
	PROTECT(prompt = coerceVector(prompt, STRSXP));
237 
 
238 
    if (length(text) > 0) {
46864 ripley 239 
	/* If 'text' has known encoding then we can be sure it will be
240 
	   correctly re-encoded to the current encoding by
241 
	   translateChar in the parser and so could mark the result in
242 
	   a Latin-1 or UTF-8 locale.
243 
 
244 
	   A small complication is that different elements could have
245 
	   different encodings, but all that matters is that all
246 
	   non-ASCII elements have known encoding.
247 
	*/
248 
	for(i = 0; i < length(text); i++)
249 
	    if(!ENC_KNOWN(STRING_ELT(text, i)) &&
58404 urbaneks 250 
	       !IS_ASCII(STRING_ELT(text, i))) {
46864 ripley 251 
		allKnown = FALSE;
252 
		break;
253 
	    }
254 
	if(allKnown) {
255 
	    known_to_be_latin1 = old_latin1;
256 
	    known_to_be_utf8 = old_utf8;
257 
	}
258 
	if (num == NA_INTEGER) num = -1;
39999 murdoch 259 
	s = R_ParseVector(text, num, &status, source);
52834 murdoch 260 
	if (status != PARSE_OK) parseError(call, R_ParseError);
1839 ihaka 261 
    }
11656 ripley 262 
    else if (ifile >= 3) {/* file != "" */
46864 ripley 263 
	if (num == NA_INTEGER) num = -1;
45982 ripley 264 
	if(!wasopen) {
32873 ripley 265 
	    if(!con->open(con)) error(_("cannot open the connection"));
54018 ripley 266 
	    /* Set up a context which will close the connection on error */
267 
	    begincontext(&cntxt, CTXT_CCODE, R_NilValue, R_BaseEnv, R_BaseEnv,
268 
			 R_NilValue, R_NilValue);
269 
	    cntxt.cend = &con_cleanup;
270 
	    cntxt.cenddata = con;
271 
	}
272 
	if(!con->canread) error(_("cannot read from this connection"));
39996 murdoch 273 
	s = R_ParseConn(con, num, &status, source);
54018 ripley 274 
	if(!wasopen) {endcontext(&cntxt); con->close(con);}
35498 murdoch 275 
	if (status != PARSE_OK) parseError(call, R_ParseError);
1839 ihaka 276 
    }
277 
    else {
46864 ripley 278 
	if (num == NA_INTEGER) num = 1;
39996 murdoch 279 
	s = R_ParseBuffer(&R_ConsoleIob, num, &status, prompt, source);
52834 murdoch 280 
	if (status != PARSE_OK) parseError(call, R_ParseError);
1839 ihaka 281 
    }
11656 ripley 282 
    UNPROTECT(2);
40672 ripley 283 
    known_to_be_latin1 = old_latin1;
284 
    known_to_be_utf8 = old_utf8;
6201 maechler 285 
    return s;
2 r 286 
}