void initVP(pGEDevDesc dd)
{
SEXP vpfnname, vpfn, vp;
SEXP xscale, yscale;
SEXP currentgp = gridStateElement(dd, GSS_GPAR);
SEXP gsd = (SEXP) dd->gesd[gridRegisterIndex]->systemSpecific;
PROTECT(vpfnname = findFun(install("grid.top.level.vp"), R_gridEvalEnv));
PROTECT(vpfn = lang1(vpfnname));
PROTECT(vp = eval(vpfn, R_GlobalEnv));
/*
* Set the "native" scale of the top viewport to be the
* natural device coordinate system (e.g., points in
* postscript, pixels in X11, ...)
*/
PROTECT(xscale = allocVector(REALSXP, 2));
REAL(xscale)[0] = dd->dev->left;
REAL(xscale)[1] = dd->dev->right;
SET_VECTOR_ELT(vp, VP_XSCALE, xscale);
PROTECT(yscale = allocVector(REALSXP, 2));
REAL(yscale)[0] = dd->dev->bottom;
REAL(yscale)[1] = dd->dev->top;
SET_VECTOR_ELT(vp, VP_YSCALE, yscale);
SET_VECTOR_ELT(vp, PVP_GPAR, currentgp);
vp = doSetViewport(vp, TRUE, TRUE, dd);
SET_VECTOR_ELT(gsd, GSS_VP, vp);
UNPROTECT(5);
}
SEXP attribute_hidden 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 = installTrChar(STRING_ELT(CAR(args), 0)));
SETCAR(args, findFun(s, rho));
UNPROTECT(1);
}
if (TYPEOF(CAR(args)) == CLOSXP) {
s = allocSExp(CLOSXP);
SET_FORMALS(s, FORMALS(CAR(args)));
SET_BODY(s, R_NilValue);
SET_CLOENV(s, R_GlobalEnv);
return s;
}
if (TYPEOF(CAR(args)) == BUILTINSXP || TYPEOF(CAR(args)) == SPECIALSXP) {
char *nm = PRIMNAME(CAR(args));
SEXP env, s2;
PROTECT_INDEX xp;
PROTECT_WITH_INDEX(env = findVarInFrame3(R_BaseEnv,
install(".ArgsEnv"), TRUE),
&xp);
if (TYPEOF(env) == PROMSXP) REPROTECT(env = eval(env, R_BaseEnv), xp);
PROTECT(s2 = findVarInFrame3(env, install(nm), TRUE));
if(s2 != R_UnboundValue) {
s = duplicate(s2);
SET_CLOENV(s, R_GlobalEnv);
UNPROTECT(2);
return s;
}
UNPROTECT(1); /* s2 */
REPROTECT(env = findVarInFrame3(R_BaseEnv, install(".GenericArgsEnv"),
TRUE), xp);
if (TYPEOF(env) == PROMSXP) REPROTECT(env = eval(env, R_BaseEnv), xp);
PROTECT(s2 = findVarInFrame3(env, install(nm), TRUE));
if(s2 != R_UnboundValue) {
s = allocSExp(CLOSXP);
SET_FORMALS(s, FORMALS(s2));
SET_BODY(s, R_NilValue);
SET_CLOENV(s, R_GlobalEnv);
UNPROTECT(2);
return s;
}
UNPROTECT(2);
}
return R_NilValue;
}
SEXP do_edit(SEXP call, SEXP op, SEXP args, SEXP rho)
{
int i, rc;
ParseStatus status;
SEXP x, fn, envir, ed, src, srcfile, Rfn;
char *filename, *editcmd;
const char *cmd;
const void *vmaxsave;
FILE *fp;
#ifdef Win32
SEXP ti;
char *title;
#endif
checkArity(op, args);
vmaxsave = vmaxget();
x = CAR(args); args = CDR(args);
if (TYPEOF(x) == CLOSXP) envir = CLOENV(x);
else envir = R_NilValue;
PROTECT(envir);
fn = CAR(args); args = CDR(args);
if (!isString(fn))
error(_("invalid argument to edit()"));
if (LENGTH(STRING_ELT(fn, 0)) > 0) {
const char *ss = translateChar(STRING_ELT(fn, 0));
filename = R_alloc(strlen(ss), sizeof(char));
strcpy(filename, ss);
}
else filename = DefaultFileName;
if (x != R_NilValue) {
if((fp=R_fopen(R_ExpandFileName(filename), "w")) == NULL)
errorcall(call, _("unable to open file"));
if (LENGTH(STRING_ELT(fn, 0)) == 0) EdFileUsed++;
if (TYPEOF(x) != CLOSXP || isNull(src = getAttrib(x, R_SourceSymbol)))
src = deparse1(x, CXXRFALSE, FORSOURCING); /* deparse for sourcing, not for display */
for (i = 0; i < LENGTH(src); i++)
fprintf(fp, "%s\n", translateChar(STRING_ELT(src, i)));
fclose(fp);
}
#ifdef Win32
ti = CAR(args);
#endif
args = CDR(args);
ed = CAR(args);
if (!isString(ed)) errorcall(call, _("argument 'editor' type not valid"));
cmd = translateChar(STRING_ELT(ed, 0));
if (strlen(cmd) == 0) errorcall(call, _("argument 'editor' is not set"));
editcmd = R_alloc(strlen(cmd) + strlen(filename) + 6, sizeof(char));
#ifdef Win32
if (!strcmp(cmd,"internal")) {
if (!isString(ti))
error(_("'title' must be a string"));
if (LENGTH(STRING_ELT(ti, 0)) > 0) {
title = R_alloc(strlen(CHAR(STRING_ELT(ti, 0)))+1, sizeof(char));
strcpy(title, CHAR(STRING_ELT(ti, 0)));
} else {
title = R_alloc(strlen(filename)+1, sizeof(char));
strcpy(title, filename);
}
Rgui_Edit(filename, CE_NATIVE, title, 1);
}
else {
/* Quote path if necessary */
if(cmd[0] != '"' && Rf_strchr(cmd, ' '))
sprintf(editcmd, "\"%s\" \"%s\"", cmd, filename);
else
sprintf(editcmd, "%s \"%s\"", cmd, filename);
rc = runcmd(editcmd, CE_NATIVE, 1, 1, NULL, NULL, NULL);
if (rc == NOLAUNCH)
errorcall(call, _("unable to run editor '%s'"), cmd);
if (rc != 0)
warningcall(call, _("editor ran but returned error status"));
}
#else
if (ptr_R_EditFile)
rc = ptr_R_EditFile(filename);
else {
sprintf(editcmd, "'%s' '%s'", cmd, filename); // allow for spaces
rc = R_system(editcmd);
}
if (rc != 0)
errorcall(call, _("problem with running editor %s"), cmd);
#endif
if (asLogical(GetOption1(install("keep.source")))) {
PROTECT(Rfn = findFun(install("readLines"), R_BaseEnv));
PROTECT(src = lang2(Rfn, ScalarString(mkChar(R_ExpandFileName(filename)))));
PROTECT(src = eval(src, R_BaseEnv));
PROTECT(Rfn = findFun(install("srcfilecopy"), R_BaseEnv));
PROTECT(srcfile = lang3(Rfn, ScalarString(mkChar("<tmp>")), src));
srcfile = eval(srcfile, R_BaseEnv);
UNPROTECT(5);
} else
srcfile = R_NilValue;
PROTECT(srcfile);
/* <FIXME> setup a context to close the file, and parse and eval
line by line */
if((fp = R_fopen(R_ExpandFileName(filename), "r")) == NULL)
errorcall(call, _("unable to open file to read"));
x = PROTECT(R_ParseFile(fp, -1, &status, srcfile));
fclose(fp);
if (status != PARSE_OK)
errorcall(call,
_("%s occurred on line %d\n use a command like\n x <- edit()\n to recover"), R_ParseErrorMsg, R_ParseError);
R_ResetConsole();
{ /* can't just eval(x) here */
int j, n;
SEXP tmp = R_NilValue;
n = LENGTH(x);
for (j = 0 ; j < n ; j++)
tmp = eval(XVECTOR_ELT(x, j), R_GlobalEnv);
x = tmp;
}
if (TYPEOF(x) == CLOSXP && envir != R_NilValue)
SET_CLOENV(x, envir);
UNPROTECT(3);
vmaxset(vmaxsave);
return x;
}
int ex(nodeType *p) {
int oldx,oldy,lbl1, lbl2,lbl3;
int oldoutest;
int oldoff = 0;
struct dic *tmp;
struct arrayDic *arrayTmp;
struct dic *oldhead = NULL;
struct fun *ftmp;
if (!p) return 0;
switch(p->type) {
case typeCon:
// printf("---typeCon---\n");
printf("\tpush\t%d\n", p->con.value);
ischar = 0;
++fpoffset;
//break;
return p->con.value;
case typeCha:
// printf("---typeCha---\n");
printf("\tpush\t%d\n", p->cha.value);
ischar = 1;
++fpoffset;//sad
break;
case typeString:
printf("\tpush\t%s\n", p->strg.value);
++fpoffset;
break;
case typeId:
// printf("---typeId:%s---\n",p->id.id);
if(p->id.global)
{
tmp = findVar(p->id.id,NULL);
}
else
tmp = findVar(p->id.id,head);
if(tmp == NULL)
{
printf("cannot be refer since it does not exist.\n");
exit(1);
}
if(!isg)
printf("\tpush\tfp[%d]\n", tmp->pos);
else
printf("\tpush\tsb[%d]\n", tmp->pos);
ischar = tmp->ischar;
++fpoffset;
break;
case typeOpr:
// printf("---typeOpr---\n");
switch(p->opr.oper) {
case BREAK:
if(outy!=-1)
printf("\tjmp\tL%03d\n",outy);
else
{
printf("break must be inside a loop.\n");
exit(0);
}
break;
case CONTINUE:
if(outx!=-1)
printf("\tjmp\tL%03d\n",outx);
else
{
printf("continue must be inside a loop.\n");
exit(0);
}
break;
case FOR:
lbl1 = lbl++;
lbl2 = lbl++;
lbl3 = lbl++;
oldx = outx;
oldy = outy;
outx = lbl3;
outy = lbl2;
ex(p->opr.op[0]);
printf("L%03d:\n", lbl1);
ex(p->opr.op[1]);
printf("\tj0\tL%03d\n", lbl2);
--fpoffset;
ex(p->opr.op[3]);
printf("L%03d:\n", lbl3);
ex(p->opr.op[2]);
printf("\tjmp\tL%03d\n", lbl1);
printf("L%03d:\n", lbl2);
outx = oldx;
outy = oldy;
break;
case WHILE:
lbl1 = lbl++;
lbl2 = lbl++;
oldx = outx;
oldy = outy;
outx = lbl1;
outy = lbl2;
printf("L%03d:\n", lbl1);
ex(p->opr.op[0]);
printf("\tj0\tL%03d\n", lbl2);
--fpoffset;
ex(p->opr.op[1]);
printf("\tjmp\tL%03d\n", lbl1);
printf("L%03d:\n", lbl2);
outx = oldx;
outy = oldy;
break;
case DO:
lbl1 = lbl++;
lbl2 = lbl++;
oldx = outx;
oldy = outy;
outx = lbl1;
outy = lbl2;
printf("L%03d:\n",lbl1);
ex(p->opr.op[0]);
ex(p->opr.op[1]);
printf("\tj0\tL%03d\n",lbl2);
--fpoffset;
printf("\tjmp\tL%03d\n",lbl1);
printf("L%03d:\n",lbl2);
outx = oldx;
outy = oldy;
break;
case GETI:
parsegeti(p->opr.op[0]);
break;
case GETC:
parsegetc(p->opr.op[0]);
break;
case PUTIN:
parseputin(p->opr.op[0]);
break;
case PUTI:
if(p->opr.nops==1)
parseputi(p->opr.op[0]);
else
parseputifm(p->opr.op[0],p->opr.op[1]);
break;
case PUTCN:
parseputcn(p->opr.op[0]);
break;
case PUTC:
if(p->opr.nops==1)
parseputc(p->opr.op[0]);
else
parseputcfm(p->opr.op[0],p->opr.op[1]);
break;
case PUTSN:
parseputsn(p->opr.op[0]);
break;
case PUTS:
if(p->opr.nops==1)
parseputs(p->opr.op[0]);
// TODO: formatted
// else
// parseputcfm(p->opr.op[0],p->opr.op[1]);
break;
case IF:
ex(p->opr.op[0]);
if (p->opr.nops > 2) {
/* if else */
printf("\tj0\tL%03d\n", lbl1 = lbl++);
--fpoffset;
ex(p->opr.op[1]);
printf("\tjmp\tL%03d\n", lbl2 = lbl++);
printf("L%03d:\n", lbl1);
ex(p->opr.op[2]);
printf("L%03d:\n", lbl2);
} else {
/* if */
printf("\tj0\tL%03d\n", lbl1 = lbl++);
--fpoffset;
ex(p->opr.op[1]);
printf("L%03d:\n", lbl1);
}
break;
case ARRAY: // array declaration; single dimension
flag = 0;
++fpoffset;
if(p->opr.op[0]->id.global)
tmp = findVar(p->opr.op[0]->id.id,NULL);
else
tmp = findVar(p->opr.op[0]->id.id,head);
if (tmp != NULL){ // already declared
printf("ERROR: duplicated array declaration: %s\n", p->opr.op[0]->id.id);
// execution should stop here so the value of fp is no longer relevant
exit(-1);
}
if(outest)
tmp = addVar2Point(p->opr.op[0]->id.id, &global);
else
tmp = addVar2Point(p->opr.op[0]->id.id, &head);
// int dim = p->opr.op[1]->con.value;
if(p->opr.nops == 2){ // without initialization
// default init value is 0; "type" is 0: the type is not determined yet
//tmp->ref = newArray(p->opr.op[0]->id.id, 0, 0, getDims(p->opr.op[1]));
tmp->ref = newArray(p->opr.op[0]->id.id, 0, 0, p->opr.op[1]);
}
else{ // with initialization
switch(p->opr.op[3]->con.value){
case 1: // integer array
//tmp->ref = newArray(p->opr.op[0]->id.id, p->opr.op[2]->con.value, 1, getDims(p->opr.op[1]));
tmp->ref = newArray(p->opr.op[0]->id.id, p->opr.op[2]->con.value, 1, p->opr.op[1]);
break;
case 2: // char array, i.e. "real string"
// tmp->ref = newArray(p->opr.op[0]->id.id, p->opr.op[2]->cha.value, 2, getDims(p->opr.op[1]));
tmp->ref = newArray(p->opr.op[0]->id.id, p->opr.op[2]->con.value, 2, p->opr.op[1]);
break;
}
}
break;
case ACCESS: // VARIABLE '[' expr ']'
flag = 0;
if(p->opr.op[0]->id.global)
tmp = findVar(p->opr.op[0]->id.id,NULL);
else
tmp = findVar(p->opr.op[0]->id.id,head);
if (tmp == NULL){
printf("ERROR: array element referenced before declaration.\n");
exit(1);
}
ex(p->opr.op[1]);
printf("\tpush\t%d\n", tmp->pos);
printf("\tadd\n");
printf("\tpop\tin\n");
if(!isg)
printf("\tpush\tfp[in]\n");
else
printf("\tpush\tsb[in]\n");
// printf("\tpush\tfp[in]\n");
break;
//printf("\tpush\tfp[%d]\n", tmp->pos + p->opr.op[1]->con.value);
case RETURN:
ex(p->opr.op[0]);
printf("\tret\n");
break;
case READ:
flag = 0;
if(p->opr.op[0]->id.global)
tmp = findVar(p->opr.op[0]->id.id,NULL);
else
tmp = findVar(p->opr.op[0]->id.id,head);
if(tmp == NULL)
{
if(p->opr.op[0]->id.global&&outest==0)
{
printf("cannot find that global variable.\n");
exit(1);
}
else
{
if(!outest)
tmp = addVar2Point(p->opr.op[0]->id.id,&head);
else
tmp = addVar2Point(p->opr.op[0]->id.id,&global);
}
}
tmp->ischar = 0;
if(!flag)
{
printf("\tgeti\n");
if(!isg)
printf("\tpop\tfp[%d]\n",tmp->pos);
else
printf("\tpop\tsb[%d]\n",tmp->pos);
}
else
{
printf("\tpush 0\n");
++fpoffset;
++tmp->pos;
//ex(p->opr.op[0]);
printf("\tgeti\n");
if(p->opr.op[0]->id.global)
tmp = findVar(p->opr.op[0]->id.id,NULL);
else
tmp = findVar(p->opr.op[0]->id.id,head);
if(!isg)
printf("\tpop\tfp[%d]\n",tmp->pos);
else
printf("\tpop\tsb[%d]\n",tmp->pos);
}
break;
case READC:
flag = 0;
if(p->opr.op[0]->id.global)
tmp = findVar(p->opr.op[0]->id.id,NULL);
else
tmp = findVar(p->opr.op[0]->id.id,head);
if(tmp == NULL)
{
if(p->opr.op[0]->id.global&&outest==0)
{
printf("cannot find that global variable.\n");
exit(1);
}
else
{
if(!outest)
tmp = addVar2Point(p->opr.op[0]->id.id,&head);
else
tmp = addVar2Point(p->opr.op[0]->id.id,&global);
}
}
tmp->ischar = 1;
if(!flag)
{
printf("\tgetc\n");
if(!isg)
printf("\tpop\tfp[%d]\n",tmp->pos);
else
printf("\tpop\tsb[%d]\n",tmp->pos);
}
else
{
printf("\tpush 0\n");
++fpoffset;
++tmp->pos;
//ex(p->opr.op[0]);
printf("\tgetc\n");
if(p->opr.op[0]->id.global)
tmp = findVar(p->opr.op[0]->id.id,NULL);
else
tmp = findVar(p->opr.op[0]->id.id,head);
if(!isg)
printf("\tpop\tfp[%d]\n",tmp->pos);
else
printf("\tpop\tsb[%d]\n",tmp->pos);
}
break;
case PRINT:
ex(p->opr.op[0]);
--fpoffset;
if (ischar) printf("\tputc\n");
else printf("\tputi\n");
//ischar = 1;
break;
case PI:
if(p->opr.nops==1) // simple
ex(p->opr.op[0]);
else // formatted
ex(p->opr.op[1]);
--fpoffset;
if(p->opr.nops==1)
printf("\tputi\n");
else
printf("\tputi %s\n",p->opr.op[0]->strg.value);
break;
case PIN:
ex(p->opr.op[0]);
--fpoffset;
printf("\tputi_\n");
break;
case PC:
if(p->opr.nops==1)
ex(p->opr.op[0]);
else
ex(p->opr.op[1]);
--fpoffset;
if(p->opr.nops==1)
printf("\tputc\n");
else
printf("\tputc %s\n",p->opr.op[0]->strg.value);
break;
case PCN:
ex(p->opr.op[0]);
--fpoffset;
printf("\tputc_\n");
break;
// added
case PS:
if(p->opr.nops==1)
ex(p->opr.op[0]);
else
ex(p->opr.op[1]);
--fpoffset;
if(p->opr.nops==1)
printf("\tputs\n");
// TODO: formatted
// else
// printf("\tputc %s\n",p->opr.op[0]->id.id);
break;
case PSN:
ex(p->opr.op[0]);
--fpoffset;
printf("\tputs_\n");
break;
case '=':
//ex(p->opr.op[1]); // RHS value
//nodeType *vartmp;
//int isArray;
if (p->opr.op[0]->type == typeId){
vartmp = p->opr.op[0]; // simple variable
isArray = 0;
}
else{
vartmp = p->opr.op[0]->opr.op[0]; // array element
isArray = 1;
}
// common
if(vartmp->id.global)
tmp = findVar(vartmp->id.id,NULL);
else
tmp = findVar(vartmp->id.id,head);
if(tmp == NULL) // variable not found
{
if (isArray == 1){
printf("ERROR: array element referenced before declaration.\n");
exit(1);
}
if(vartmp->id.global && outest==0)
{
printf("cannot find that global variable.\n");
exit(1);
}
else
{
printf("\tpush\t0\n");
++fpoffset;
if(outest)
tmp = addVar2Point(vartmp->id.id, &global);
else
tmp = addVar2Point(vartmp->id.id, &head);
}
}
if(!flag){ // the variable is not newly created
--fpoffset;
//var type changed.
tmp->ischar = ischar; // Disable and exit if type change is not allowed.
}
else{
//ex(p->opr.op[1]);
//printf("\tpush\t0\n");
--fpoffset;
tmp->ischar = ischar;
if(vartmp->id.global)
tmp = findVar(vartmp->id.id, NULL);
else
tmp = findVar(vartmp->id.id, head);
}
ex(p->opr.op[1]); // RHS value
if(isArray == 0){ // simple variable
if(tmp->ref != NULL){
printf("TYPE ERROR: cannot assign an array\n");
exit(1);
}
if(!isg)
printf("\tpop\tfp[%d]\n",tmp->pos);
else
printf("\tpop\tsb[%d]\n",tmp->pos);
}
else{ // array element
if (tmp->ref == NULL){
printf("TYPE ERROR: %s is not an array\n", tmp->name);
exit(1);
}
ex(p->opr.op[0]->opr.op[1]);
printf("\tpush\t%d\n", tmp->pos);
printf("\tadd\n");
printf("\tpop\tin\n");
if(!isg)
printf("\tpop\tfp[in]\n");
else
printf("\tpop\tsb[in]\n");
}
break;
case FUNCALL:
ex(p->opr.op[1]);
ftmp = findFun(p->opr.op[0]->id.id);
printf("\tcall L%03d,%d\n",ftmp->no,ftmp->para_num);
break;
case FUNDCLR:
oldoutest = outest;
outest = 0;
oldoff = fpoffset;
fpoffset = 0;
lbl1 = lbl++;
oldhead = head;
head = NULL;
printf("\tjmp L%03d\n",lbl1);
ftmp = findFun(p->opr.op[0]->id.id);
if(ftmp!=NULL)
{
printf("Has been declared;\n");
exit(1);
}
ftmp = addFun(p->opr.op[0]->id.id);
ftmp->no = lbl++;
printf("L%03d:\n",ftmp->no);
if(p->opr.op[1]==NULL)
{
}
else
{
nodeType *ptmp = p->opr.op[1];
para = 1;
while(ptmp->type==typeOpr)
{
addVar2Point(ptmp->opr.op[1]->id.id,&head);
ptmp = ptmp->opr.op[0];
para++;
}
addVar2Point(ptmp->id.id,&head);
para = addPara(p->opr.op[1]);
}
int itmp = 0;
for(tmp = head;tmp!=NULL;tmp = tmp->next)
{
tmp->pos -= (3+itmp);
itmp++;
}
ftmp->para_num = para;
ex(p->opr.op[2]);
printf("L%03d:\n",lbl1);
outest = oldoutest;
head = oldhead;
fpoffset = oldoff;
break;
case UMINUS:
ex(p->opr.op[0]);
ischar = 0;
printf("\tneg\n");
break;
default:
ex(p->opr.op[0]); // deleted: int aischar = ischar;
ex(p->opr.op[1]); int charopr = ischar; ischar = 0;
switch(p->opr.oper) {
case ',': if(p->opr.op[2]->con.value == 1) para++; break;
case '+': printf("\tadd\n"); --fpoffset; break;
case '-': printf("\tsub\n"); --fpoffset; break;
case '*': printf("\tmul\n"); --fpoffset;break;
case '/': printf("\tdiv\n"); --fpoffset;break;
case '%': printf("\tmod\n"); --fpoffset;break;
case '<': printf("\tcomplt\n"); --fpoffset;break;
case '>': printf("\tcompgt\n"); --fpoffset;break;
case GE: printf("\tcompge\n"); --fpoffset;break;
case LE: printf("\tcomple\n"); --fpoffset;break;
case NE: printf("\tcompne\n"); --fpoffset;break;
case EQ: printf("\tcompeq\n"); --fpoffset;break;
case AND: printf("\tand\n"); --fpoffset;break;
case OR: printf("\tor\n"); --fpoffset;break;
}
}
}
return 0;
}
