The R Project SVN R-packages

Rev

Rev 3323 | Blame | Compare with Previous | Last modification | View Log | Download | RSS feed 

/*
 *  R.app : a Cocoa front end to: "R A Computer Language for Statistical Data Analysis"
 *  
 *  R.app Copyright notes:
 *                     Copyright (C) 2004-5  The R Foundation
 *                     written by Stefano M. Iacus and Simon Urbanek
 *
 *                  
 *  R Copyright notes:
 *                     Copyright (C) 1995-1996   Robert Gentleman and Ross Ihaka
 *                     Copyright (C) 1998-2001   The R Development Core Team
 *                     Copyright (C) 2002-2005   The R Foundation
 *
 *  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.
 *
 *  A copy of the GNU General Public License is available via WWW at
 *  http://www.gnu.org/copyleft/gpl.html.  You can also obtain it by
 *  writing to the Free Software Foundation, Inc., 59 Temple Place,
 *  Suite 330, Boston, MA  02111-1307  USA.
 */

#include <Rversion.h>
#if (R_VERSION >= R_Version(2,3,0))
#define R_INTERFACE_PTRS 1
#define CSTACK_DEFNS 1
#endif

#include "privateR.h"

#include <R.h>
#include <Rinternals.h>
#include "Rinit.h"
#include "Rcallbacks.h"
#include "IOStuff.h"
#include <R_ext/Parse.h>
#include <Parse.h>

#include <Rdevices.h>
#include <R_ext/GraphicsDevice.h>

#include <Rdefines.h>

/* This constant defines the maximal length of single ReadConsole input, which usually corresponds to the maximal length of a single line. The buffer is allocated dynamically, so an arbitrary size is fine. */
#ifndef MAX_R_LINE_SIZE
#define MAX_R_LINE_SIZE 32767
#endif

/*----------- more recent R versions have Rinterface ---------*/
#if (R_VERSION >= R_Version(2,3,0))
#include <Rinterface.h>

/* unfortunately 2.3.0 doesn't export R_CStackLimit */
#if (R_VERSION < R_Version(2,3,1))
#if !defined(HAVE_UINTPTR_T) && !defined(uintptr_t)
typedef unsigned long uintptr_t;
#endif
extern uintptr_t R_CStackLimit; /* C stack limit */
extern uintptr_t R_CStackStart; /* Initial stack address */
#endif

/* and SaveAction is not officially exported */
extern SA_TYPE SaveAction;

#else

/*-------- old-style initialization w/o Rinterface.h ---------*/

int setup_Rmainloop(void);  /* from src/main.c */

/*-------------------------------------------------------------------*
 * UNIX initialization (includes Darwin/Mac OS X)                    *
 *-------------------------------------------------------------------*/

/* from Defn.h */
extern Rboolean R_Interactive;   /* TRUE during interactive use*/

extern FILE*    R_Consolefile;   /* Console output file */
extern FILE*    R_Outputfile;   /* Output file */

typedef enum {
    SA_NORESTORE,/* = 0 */
    SA_RESTORE,
    SA_DEFAULT,/* was === SA_RESTORE */
    SA_NOSAVE,
    SA_SAVE,
    SA_SAVEASK,
    SA_SUICIDE
} SA_TYPE;

extern SA_TYPE SaveAction;

/* from src/unix/devUI.h */

extern void (*ptr_R_Suicide)(char *);
extern void (*ptr_R_ShowMessage)();
extern int  (*ptr_R_ReadConsole)(char *, unsigned char *, int, int);
extern void (*ptr_R_WriteConsole)(char *, int);
extern void (*ptr_R_ResetConsole)();
extern void (*ptr_R_ClearerrConsole)();
extern void (*ptr_R_Busy)(int);
/* extern void (*ptr_R_CleanUp)(SA_TYPE, int, int); */
extern int  (*ptr_R_ShowFiles)(int, char **, char **, char *, Rboolean, char *);
extern int  (*ptr_R_EditFiles)(int, char **, char **, char *);

extern int  (*ptr_R_ChooseFile)(int, char *, int);
extern void (*ptr_R_loadhistory)(SEXP, SEXP, SEXP, SEXP);
extern void (*ptr_R_savehistory)(SEXP, SEXP, SEXP, SEXP);
#endif

/* --- those are not part of the Rinterface --- */
extern SEXP (*ptr_do_packagemanger)(SEXP, SEXP, SEXP, SEXP);
extern SEXP (*ptr_do_datamanger)(SEXP, SEXP, SEXP, SEXP);
extern SEXP (*ptr_do_browsepkgs)(SEXP, SEXP, SEXP, SEXP);
extern SEXP (*ptr_do_wsbrowser)(SEXP, SEXP, SEXP, SEXP);
extern SEXP (*ptr_do_hsbrowser)(SEXP, SEXP, SEXP, SEXP);
extern SEXP (*ptr_do_dataentry)(SEXP, SEXP, SEXP, SEXP);
extern SEXP (*ptr_do_selectlist)(SEXP, SEXP, SEXP, SEXP);
extern void (*ptr_do_flushconsole)();
extern void (*ptr_R_ProcessEvents)();

#if (R_VERSION >= R_Version(2,1,0))
extern int  (*ptr_R_EditFile)(char *); /* in r-devel ptr_Raqua_Edit is no longer used*/
extern SEXP (*ptr_do_selectlist)(SEXP, SEXP, SEXP, SEXP);
extern int  (*ptr_Raqua_CustomPrint)(char *, SEXP); /* custom print proxy for help/search/pkg-info */
#else
extern int  (*ptr_Raqua_Edit)(char *);
#endif

extern int  (*ptr_CocoaSystem)(char *);

int end_Rmainloop(void);    /* from src/main.c */
int Rf_initialize_R(int ac, char **av); /* from src/unix/system.c */

extern Rboolean (*ptr_CocoaInnerQuartzDevice)(NewDevDesc *,char *,
                      double ,double ,
                      double ,char *,
                      Rboolean ,
                      Rboolean ,int ,
                      int );
extern void (*ptr_CocoaGetQuartzParameters)(double *, double *, double *, 
        char *, Rboolean *, Rboolean *, int *);

extern Rboolean innerQuartzDevice(NewDevDesc*dd,char*display,
                                  double width,double height,
                                  double pointsize,char*family,
                                  Rboolean antialias,
                                  Rboolean autorefresh,int quartzpos,
                                  int bg);
extern void getQuartzParameters(double *width, double *height, double *ps, char *family, 
                                Rboolean *antialias, Rboolean *autorefresh, int *quartzpos);

/*--- note: the REPL code was modified, R_ReplState is not the same as used internally in R */

typedef struct {
  ParseStatus    status;
  int            prompt_type;
  int            browselevel;
  int            buflen;
  unsigned char *buf;
  unsigned char *bufp;
} R_ReplState;

static int  RGUI_ReplIteration(SEXP rho, int savestack, int browselevel, R_ReplState *state);
static void RGUI_ReplConsole(SEXP rho, int savestack, int browselevel);

/*---------- implementation -----------*/

static R_ReplState state = {0, 1, 0, (MAX_R_LINE_SIZE+1), NULL, NULL};

char *lastInitRError = 0;

/* Note: R_SignalHandlers are evaluated in setup_Rmainloop which is called inside initR */
int initR(int argc, char **argv, int save_action) {
    if (!getenv("R_HOME")) {
        lastInitRError = "R_HOME is not set. Please set all required environment variables before running this program.";
        return -1;
    }
    
    int stat=Rf_initialize_R(argc, argv);
    if (stat<0) {
        lastInitRError = "Failed to initialize R!";;
        return -2;
    }

    if (state.buflen<128) state.buflen=1024;
    state.buf=(unsigned char*) malloc(state.buflen);
    
   // printf("R primary initialization done. Setting up parameters.\n");

    R_Outputfile = NULL;
    R_Consolefile = NULL;
    R_Interactive = 1;
    SaveAction = (save_action==Rinit_save_yes)?SA_SAVE:((save_action==Rinit_save_no)?SA_NOSAVE:SA_SAVEASK);

    /* ptr_R_Suicide = Re_Suicide; */
    /* ptr_R_CleanUp = Re_CleanUp; */
    ptr_R_ShowMessage = Re_ShowMessage;
    ptr_R_ReadConsole =  Re_ReadConsole;
    ptr_R_WriteConsole = Re_WriteConsole;
    ptr_R_ResetConsole = Re_ResetConsole;
    ptr_do_flushconsole = Re_FlushConsole;
    ptr_R_ClearerrConsole = Re_ClearerrConsole;
    ptr_R_Busy = Re_RBusy;
    ptr_R_ProcessEvents =  Re_ProcessEvents;

#if (R_VERSION >= R_Version(2,1,0))
    ptr_R_EditFile = Re_Edit;
    ptr_Raqua_CustomPrint = Re_CustomPrint;
#else
    ptr_Raqua_Edit = Re_Edit;
#endif
    
    ptr_R_ShowFiles = Re_ShowFiles;
    ptr_R_EditFiles = Re_EditFiles;
    ptr_R_ChooseFile = Re_ChooseFile;
    
    
    ptr_do_packagemanger = Re_packagemanger;
    ptr_do_datamanger = Re_datamanger;
    ptr_do_browsepkgs = Re_browsepkgs;
    ptr_do_wsbrowser = Re_do_wsbrowser;
    ptr_do_hsbrowser = Re_do_hsbrowser;
    
    ptr_CocoaInnerQuartzDevice = innerQuartzDevice;
    ptr_CocoaGetQuartzParameters = getQuartzParameters;
    ptr_CocoaSystem = Re_system;
    ptr_do_dataentry = Re_dataentry;
#if (R_VERSION >= R_Version(2,1,0))
    ptr_do_selectlist = Re_do_selectlist;
#endif  
    setup_Rmainloop();

    return 0;
}

static int firstRun=1;

void setRSignalHandlers(int val) {
#if (R_VERSION >= R_Version(2,3,1))
    R_SignalHandlers = val;
#endif
    /* it's a noop on R <2.3.1 */
}

void run_REngineRmainloop(int delayed)
{
    /* Here is the real R read-eval-loop. */
    /* We handle the console until end-of-file. */

    firstRun=delayed;
    
    R_IoBufferInit(&R_ConsoleIob);
    SETJMP(R_Toplevel.cjmpbuf);
    R_GlobalContext = R_ToplevelContext = &R_Toplevel;
#ifdef REINSTALL_SIGNAL_HANDLERS
    signal(SIGINT, handleInterrupt);
    signal(SIGUSR1,onsigusr1);
    signal(SIGUSR2,onsigusr2);
#ifdef Unix
    signal(SIGPIPE, onpipe);
#endif
#endif
    if (firstRun) {
        firstRun=0;
        return;
    }
    
    RGUI_ReplConsole(R_GlobalEnv, 0, 0);
    end_Rmainloop(); /* must go here */
}

extern void Re_WritePrompt(char *prompt);
extern char *R_PromptString(int browselevel, int type); /* from main.c */
extern void Rf_callToplevelHandlers(SEXP expr, SEXP value, Rboolean succeeded, 
            Rboolean visible);  /* from main.c */

#if (R_VERSION < R_Version(2,3,0))
extern int Rf_ParseBrowser(SEXP, SEXP);
#else
                                    /* FIXME: Rf_ParseBrowser is no longer exported
                                    we will need to update it manually - ugly!
                                    This is copy/paste from R 2.3.0 release
                                    */
static void printwhere(void)
{
    RCNTXT *cptr;
    int lct = 1;
    
    for (cptr = R_GlobalContext; cptr; cptr = cptr->nextcontext) {
        if ((cptr->callflag & (CTXT_FUNCTION | CTXT_BUILTIN)) &&
            (TYPEOF(cptr->call) == LANGSXP)) {
                Rprintf("where %d: ", lct++);
                PrintValue(cptr->call);
        }
    }
    Rprintf("\n");
}
                                    
static int Rf_ParseBrowser(SEXP CExpr, SEXP rho)
{
    int rval = 0;
    if (isSymbol(CExpr)) {
        if (!strcmp(CHAR(PRINTNAME(CExpr)), "n")) {
            SET_DEBUG(rho, 1);
            rval = 1;
        }
        if (!strcmp(CHAR(PRINTNAME(CExpr)), "c")) {
            rval = 1;
            SET_DEBUG(rho, 0);
        }
        if (!strcmp(CHAR(PRINTNAME(CExpr)), "cont")) {
            rval = 1;
            SET_DEBUG(rho, 0);
        }
        if (!strcmp(CHAR(PRINTNAME(CExpr)), "Q")) {
                                                
            /* Run onexit/cend code for everything above the target.
               The browser context is still on the stack, so any error
               will drop us back to the current browser.  Not clear
               this is a good thing.  Also not clear this should still
               be here now that jump_to_toplevel is used for the
               jump. */
            R_run_onexits(R_ToplevelContext);
                                                
            /* this is really dynamic state that should be managed as such */
            R_BrowseLevel = 0;
            SET_DEBUG(rho, 0); /*PR#1721*/
                            
            jump_to_toplevel();
        }
        if (!strcmp(CHAR(PRINTNAME(CExpr)),"where")) {
            printwhere();
            /* SET_DEBUG(rho, 1); */
            rval = 2;
        }
    }
    return rval;
}
#endif


static void RGUI_ReplConsole(SEXP rho, int savestack, int browselevel)
{
    int status;

    R_IoBufferWriteReset(&R_ConsoleIob);
    state.buf[0] = '\0';
    state.buf[state.buflen-1] = '\0'; /* stopgap measure */
    state.bufp = state.buf;
    if(R_Verbose)
        REprintf(" >R_ReplConsole(): before \"for(;;)\" {Rinit.c}\n");
    for(;;) {
        status = RGUI_ReplIteration(rho, savestack, browselevel, &state);
        if(status < 0)
            return;
    }
}

static int cleanExit=1;

static int RGUI_ReplIteration(SEXP rho, int savestack, int browselevel, R_ReplState *state)
{
    int c, browsevalue;
    SEXP value;
    Rboolean wasDisplayed = FALSE;

    if (!cleanExit) // if previous eval was aborted, we may need to clear the busy flag
        R_Busy(0);
    
    if(!*state->bufp) {
        if (Re_ReadConsole(R_PromptString(browselevel, state->prompt_type),
                           state->buf, state->buflen-1, 1) == 0) return(-1);
        state->bufp = state->buf;
    }
#ifdef SHELL_ESCAPE
    if (*state->bufp == '!') {
#ifdef HAVE_SYSTEM
        R_system(&(state->buf[1]));
#else
        Rprintf("error: system commands are not supported in this version of R.\n");
#endif /* HAVE_SYSTEM */
        state->buf[0] = '\0';
        return(0);
    }
#endif /* SHELL_ESCAPE */
    while((c = *state->bufp++)) {
        R_IoBufferPutc(c, &R_ConsoleIob);
        if(c == ';' || c == '\n') break;
    }

    R_PPStackTop = savestack;
    R_CurrentExpr = R_Parse1Buffer(&R_ConsoleIob, 0, &state->status);
    switch(state->status) {
    case PARSE_NULL:

        if (browselevel)
            return(-1);
        R_IoBufferWriteReset(&R_ConsoleIob);
        state->prompt_type = 1;
        return(1);

    case PARSE_OK:

        R_IoBufferReadReset(&R_ConsoleIob);
        R_CurrentExpr = R_Parse1Buffer(&R_ConsoleIob, 1, &state->status);
        if (browselevel) {
            browsevalue = Rf_ParseBrowser(R_CurrentExpr, rho);
            if(browsevalue == 1 )
                return(-1);
            if(browsevalue == 2 ) {
                R_IoBufferWriteReset(&R_ConsoleIob);
                return(0);
            }
        }
        R_Visible = 0;
        R_EvalDepth = 0;
        PROTECT(R_CurrentExpr);
        cleanExit=0;
        R_Busy(1);
        value = eval(R_CurrentExpr, rho);
        SET_SYMVALUE(R_LastvalueSymbol, value);
        wasDisplayed = R_Visible;
        if (R_Visible)
            PrintValueEnv(value, rho);
        if (R_CollectWarnings)
            PrintWarnings();
        Rf_callToplevelHandlers(R_CurrentExpr, value, TRUE, wasDisplayed);
        R_CurrentExpr = value; /* Necessary? Doubt it. */
        R_Busy(0);
        cleanExit=1;
        UNPROTECT(1);
        R_IoBufferWriteReset(&R_ConsoleIob);
        state->prompt_type = 1;
        return(1);

    case PARSE_ERROR:

        state->prompt_type = 1;
        error("syntax error");
        R_IoBufferWriteReset(&R_ConsoleIob);
        return(1);

    case PARSE_INCOMPLETE:

        R_IoBufferReadReset(&R_ConsoleIob);
        state->prompt_type = 2;
        return(2);

    case PARSE_EOF:

        return(-1);
        break;
    }

    return(0);
}