int Rgui_Edit(const char *filename, int enc, const char *title,
int modal)
{
editor c;
EditorData p;
if (neditors == MAXNEDITORS) {
R_ShowMessage(G_("Maximum number of editors reached"));
return 1;
}
c = neweditor();
if (!c) {
R_ShowMessage(G_("Unable to create editor window"));
return 1;
}
if (strlen(filename) > 0) {
editor_load_file(c, filename, enc);
editor_set_title(c, title);
}
else {
editor_set_title(c, G_("Untitled"));
}
show(c);
p = getdata(getdata(c));
p->stealconsole = modal;
if (modal) {
fix_editor_up = TRUE;
eventloop(c);
}
return 0;
}
int copystringtoclipboard(char *str)
{
HGLOBAL hglb;
char *s;
int ll = strlen(str) + 1;
if (!(hglb = GlobalAlloc(GHND, ll))){
R_ShowMessage(G_("Insufficient memory: cell not copied to the clipboard"));
return 1;
}
if (!(s = (char *)GlobalLock(hglb))){
R_ShowMessage(G_("Insufficient memory: cell not copied to the clipboard"));
return 1;
}
strcpy(s, str);
GlobalUnlock(hglb);
if (!OpenClipboard(NULL) || !EmptyClipboard()) {
R_ShowMessage(G_("Unable to open the clipboard"));
GlobalFree(hglb);
return 1;
}
SetClipboardData(CF_TEXT, hglb);
CloseClipboard();
return 0;
}
/* try site Renviron: R_ENVIRON, then R_HOME/etc/Renviron.site. */
void process_site_Renviron ()
{
char buf[PATH_MAX], *p = getenv("R_ENVIRON");
if(p) {
if(*p) process_Renviron(p);
return;
}
#ifdef R_ARCH
if(strlen(R_Home) + strlen("/etc/Renviron.site") + strlen(R_ARCH) > PATH_MAX - 2) {
R_ShowMessage("path to arch-specific Renviron.site is too long: skipping");
} else {
snprintf(buf, PATH_MAX, "%s/etc/%s/Renviron.site", R_Home, R_ARCH);
if(access(buf, R_OK) == 0) {
process_Renviron(buf);
return;
}
}
#endif
if(strlen(R_Home) + strlen("/etc/Renviron.site") > PATH_MAX - 1) {
R_ShowMessage("path to Renviron.site is too long: skipping");
return;
}
snprintf(buf, PATH_MAX, "%s/etc/Renviron.site", R_Home);
process_Renviron(buf);
}
/*
To be fixed: during creation, memory is allocated two times
(faster for small files but a big waste otherwise)
*/
static xbuf file2xbuf(const char *name, int enc, int del)
{
HANDLE f;
DWORD rr, vv;
char *p;
xlong dim, cnt;
xint ms;
xbuf xb;
wchar_t *wp, *q;
if (enc == CE_UTF8) {
wchar_t wfn[MAX_PATH+1];
Rf_utf8towcs(wfn, name, MAX_PATH+1);
f = CreateFileW(wfn, GENERIC_READ, FILE_SHARE_READ,
NULL, OPEN_EXISTING, 0, NULL);
} else
f = CreateFile(name, GENERIC_READ, FILE_SHARE_READ,
NULL, OPEN_EXISTING, 0, NULL);
if (f == INVALID_HANDLE_VALUE) {
R_ShowMessage(G_("Error opening file"));
return NULL;
}
vv = GetFileSize(f, NULL);
p = (char *) malloc((size_t) vv + 1);
if (!p) {
CloseHandle(f);
R_ShowMessage(G_("Insufficient memory to display file in internal pager"));
return NULL;
}
ReadFile(f, p, vv, &rr, NULL);
CloseHandle(f);
if (del) DeleteFile(name);
p[rr] = '\0';
cnt = mbstowcs(NULL, p, 0);
wp = (wchar_t *) malloc((cnt+1) * sizeof(wchar_t));
mbstowcs(wp, p, cnt+1);
for (q = wp, ms = 1, dim = cnt; *q; q++) {
if (*q == '\t')
dim += TABSIZE;
else if (*q == '\n') {
dim++;
ms++;
}
}
free(p);
if ((xb = newxbuf(dim + 1, ms + 1, 1)))
for (q = wp, ms = 0; *q; q++) {
if (*q == L'\r') continue;
if (*q == L'\n') {
ms++;
xbufaddxc(xb, *q);
/* next line interprets underlining in help files */
if (q[1] == L'_' && q[2] == L'\b') xb->user[ms] = -2;
} else xbufaddxc(xb, *q);
}
free(wp);
return xb;
}
/* width and height are in mm */
metafile newmetafile(const char *name, double width, double height)
{
metafile obj;
HDC hDC;
RECT wr;
static double cppix=-1, ppix, cppiy, ppiy;
/*
* In theory, (cppix=ppix) and (cppiy=ppiy). However, we
* use the ratio to adjust the 'reference dimension'
* in case.... ("Importing graph in MsWord" thread)
*/
if (cppix < 0) {
cppix = 25.40 * devicewidth(NULL) / devicewidthmm(NULL);
ppix = 100 * devicepixelsx(NULL);
cppiy = 25.40 * deviceheight(NULL) / deviceheightmm(NULL);
ppiy = 100 * devicepixelsy(NULL);
}
/* This is all very peculiar. We would really like to create
a metafile measured in some sensible units, but it seems
we get it in units of 0.01mm *on the current screen* with
horizontal and vertical resolution set for that screen.
And of course Windows is famous for getting screen sizes wrong.
*/
wr.left = 0;
wr.top = 0 ;
wr.right = (ppix * width) / cppix ;
wr.bottom = (ppiy * height) / cppiy ;
/* Here the size is in 0.01mm units */
hDC = CreateEnhMetaFile(NULL, strlen(name) ? name : NULL, &wr,
"GraphApp\0\0");
if ( !hDC ) {
R_ShowMessage(_("Unable to create metafile"));
return NULL;
}
obj = new_object(MetafileObject, (HANDLE) hDC, get_metafile_base());
if ( !obj ) {
R_ShowMessage(_("Insufficient memory to create metafile"));
DeleteEnhMetaFile(CloseEnhMetaFile(hDC));
return NULL;
}
/* In looks like Windows rounds up the width and height, so we
do too. 1 out is common, but 2 out has been seen.
This is needed to get complete painting of the background.
*/
obj->rect = rect(0, 0, 2+(ppix * width)/2540, 2+(ppiy * height)/2540);
obj->depth = GetDeviceCaps(hDC, BITSPIXEL) * GetDeviceCaps(hDC, PLANES);
obj->die = private_delmetafile;
obj->drawstate = copydrawstate();
obj->drawstate->dest = obj;
settext(obj, name ? name : "");
return obj;
}
SEXP hiplar_dtrMatrix_matrix_mm(SEXP a, SEXP b, SEXP right, SEXP trans) {
#ifdef HIPLAR_DBG
R_ShowMessage("DBG: Entering hiplar_dtrMatrix_matrix_mm");
#endif
#if defined(HIPLAR_WITH_PLASMA) && defined(HIPLAR_WITH_MAGMA)
int *dims = INTEGER(GET_SLOT(a, Matrix_DimSym));
int size = dims[0];
if ((hiplar_library == HIPLAR_USE_PLASMA) ||
((hiplar_library == HIPLAR_USE_AUTO) && (size < xover_dtrMatrix_matrix_mm))) {
#endif
#ifdef HIPLAR_WITH_PLASMA
return plasma_dtrMatrix_matrix_mm(a, b, right, trans);
#endif
#if defined(HIPLAR_WITH_PLASMA) && defined(HIPLAR_WITH_MAGMA)
} else {
#endif
#ifdef HIPLAR_WITH_MAGMA
return magma_dtrMatrix_matrix_mm(a, b, right, trans);
#endif
#if defined(HIPLAR_WITH_PLASMA) && defined(HIPLAR_WITH_MAGMA)
}
#endif
return R_NilValue;
}
void copytoclipboard(drawing sb)
{
HBITMAP hbmpOldDest, hbmpNew;
HDC hdcSrc, hdcDest;
rect r;
r = getrect(sb);
hdcSrc = get_context((object)sb);
hdcDest = CreateCompatibleDC(hdcSrc);
hbmpNew = CreateCompatibleBitmap(hdcSrc, r.width, r.height);
hbmpOldDest = SelectObject(hdcDest, hbmpNew);
BitBlt(hdcDest, 0, 0, r.width, r.height, hdcSrc, 0, 0, SRCCOPY);
SelectObject(hdcDest, hbmpOldDest);
DeleteDC(hdcDest);
if (!OpenClipboard(NULL) || !EmptyClipboard()) {
R_ShowMessage(G_("Unable to open the clipboard"));
DeleteObject(hbmpNew);
return;
}
SetClipboardData(CF_BITMAP, hbmpNew);
CloseClipboard();
return;
}
static void pagercopy(control m)
{
control c = getdata(m);
if (consolecancopy(c)) consolecopy(c);
else R_ShowMessage(G_("No selection"));
}
static int process_Renviron(const char *filename)
{
FILE *fp;
char *s, *p, sm[BUF_SIZE], *lhs, *rhs, msg[MSG_SIZE+50];
int errs = 0;
if (!filename || !(fp = R_fopen(filename, "r"))) return 0;
snprintf(msg, MSG_SIZE+50,
"\n File %s contains invalid line(s)", filename);
while(fgets(sm, BUF_SIZE, fp)) {
sm[BUF_SIZE-1] = '\0';
s = rmspace(sm);
if(strlen(s) == 0 || s[0] == '#') continue;
if(!(p = Rf_strchr(s, '='))) {
errs++;
if(strlen(msg) < MSG_SIZE) {
strcat(msg, "\n "); strcat(msg, s);
}
continue;
}
*p = '\0';
lhs = rmspace(s);
rhs = findterm(rmspace(p+1));
/* set lhs = rhs */
if(strlen(lhs) && strlen(rhs)) Putenv(lhs, rhs);
}
fclose(fp);
if (errs) {
strcat(msg, "\n They were ignored\n");
R_ShowMessage(msg);
}
return 1;
}
/*
* nfile = number of files
* file = array of filenames
* editor = editor to be used.
*/
int R_EditFiles(int nfile, const char **file, const char **title,
const char *editor)
{
char buf[1024];
if (ptr_R_EditFiles) return(ptr_R_EditFiles(nfile, file, title, editor));
if (nfile > 0) {
if (nfile > 1)
R_ShowMessage(_("WARNING: Only editing the first in the list of files"));
if (ptr_R_EditFile) ptr_R_EditFile((char *) file[0]);
else {
/* Quote path if necessary */
if (editor[0] != '"' && Rf_strchr(editor, ' '))
snprintf(buf, 1024, "\"%s\" \"%s\"", editor, file[0]);
else
snprintf(buf, 1024, "%s \"%s\"", editor, file[0]);
if (R_system(buf) == 127)
warningcall(R_NilValue, _("error in running command"));
}
return 0;
}
return 1;
}
void R_Suicide(const char *s)
{
char pp[1024];
snprintf(pp, 1024, _("Fatal error: %s\n"), s);
R_ShowMessage(pp);
R_CleanUp(SA_SUICIDE, 2, 0);
}
/*
I don't use 'error' since (1) we must free 'scanline' and
(2) we can be arrived here from a button or menuitem callback maybe
in a different thread from the one where R runs.
*/
static void my_png_error(png_structp png_ptr, png_const_charp msg)
{
R_ShowMessage((char *) msg);
#if PNG_LIBPNG_VER < 10400
longjmp(png_ptr->jmpbuf,1);
#else
longjmp(png_jmpbuf(png_ptr),1);
#endif
}
static void SetSize(R_size_t vsize)
{
char msg[1024];
/* vsize > 0 to catch long->int overflow */
if (vsize < 1000 && vsize > 0) {
R_ShowMessage("WARNING: vsize ridiculously low, Megabytes assumed\n");
vsize *= R_size_t( Mega);
}
if(vsize < Min_Vsize || vsize > Max_Vsize) {
snprintf(msg, 1024,
"WARNING: invalid v(ector heap)size `%lu' ignored\n"
"using default = %gM\n", static_cast<unsigned long>( vsize),
R_VSIZE / Mega);
R_ShowMessage(msg);
R_VSize = R_VSIZE;
} else
R_VSize = vsize;
}
/* We also replace the output method */
static void my_output_message (j_common_ptr cinfo)
{
char buffer[JMSG_LENGTH_MAX];
/* Create the message */
(*cinfo->err->format_message) (cinfo, buffer);
/* and show it */
R_ShowMessage(buffer);
}
static void pagerpastecmds(control m)
{
control c = getdata(m);
if (CharacterMode != RGui) {
R_ShowMessage(G_("No RGui console to paste to"));
return;
}
if (!consolecancopy(c)) {
R_ShowMessage(G_("No selection"));
return;
} else {
consolecopy(c);
}
if (consolecanpaste(RConsole)) {
consolepastecmds(RConsole);
show(RConsole);
}
}
SEXP plasma_dsyMatrix_norm(SEXP obj, SEXP type)
{
#ifdef HIPLAR_WITH_PLASMA
#ifdef HIPLAR_DBG
R_ShowMessage("DBG: Entering plasma_dsyMatrix_norm");
#endif
return ScalarReal(get_norm_sy(obj, CHAR(asChar(type))));
#endif
return R_NilValue;
}
static pager newpager1win(const char *wtitle,
const char *filename, int enc,
int deleteonexit)
{
if (!pagerInstance && !(pagerInstance = pagercreate())) {
R_ShowMessage(G_("Unable to create pager window"));
return NULL;
}
if (!pageraddfile(wtitle, filename, enc, deleteonexit)) return NULL;
pagerupdateview();
return pagerInstance;
}
void R_SizeFromEnv(Rstart Rp)
{
int ierr;
R_size_t value;
char *p;
if((p = getenv("R_VSIZE"))) {
value = R_Decode2Long(p, &ierr);
if(ierr != 0 || value > Max_Vsize || value < Min_Vsize)
R_ShowMessage("WARNING: invalid R_VSIZE ignored\n");
else
Rp->vsize = value;
}
}
/* try system Renviron: R_HOME/etc/Renviron. Unix only. */
void process_system_Renviron()
{
char buf[PATH_MAX];
#ifdef R_ARCH
if(strlen(R_Home) + strlen("/etc/Renviron") + strlen(R_ARCH) + 1 > PATH_MAX - 1) {
R_ShowMessage("path to system Renviron is too long: skipping");
return;
}
strcpy(buf, R_Home);
strcat(buf, "/etc/");
strcat(buf, R_ARCH);
strcat(buf, "/Renviron");
#else
if(strlen(R_Home) + strlen("/etc/Renviron") > PATH_MAX - 1) {
R_ShowMessage("path to system Renviron is too long: skipping");
return;
}
strcpy(buf, R_Home);
strcat(buf, "/etc/Renviron");
#endif
if(!process_Renviron(buf))
R_ShowMessage("cannot find system Renviron");
}
void R_setupHistory()
{
int value, ierr;
char *p;
if ((R_HistoryFile = getenv("R_HISTFILE")) == NULL)
R_HistoryFile = ".Rhistory";
R_HistorySize = 512;
if ((p = getenv("R_HISTSIZE"))) {
value = (int) R_Decode2Long(p, &ierr);
if (ierr != 0 || value < 0)
R_ShowMessage("WARNING: invalid R_HISTSIZE ignored;");
else
R_HistorySize = value;
}
}
static void editor_load_file(editor c, const char *name, int enc)
{
textbox t = getdata(c);
EditorData p = getdata(t);
FILE *f;
char *buffer = NULL, tmp[MAX_PATH+50], tname[MAX_PATH+1];
const char *sname;
long num = 1, bufsize;
if(enc == CE_UTF8) {
wchar_t wname[MAX_PATH+1];
Rf_utf8towcs(wname, name, MAX_PATH+1);
f = R_wfopen(wname, L"r");
reEnc2(name, tname, MAX_PATH+1, CE_UTF8, CE_NATIVE, 3);
sname = tname;
} else {
f = R_fopen(name, "r");
sname = name;
}
if (f == NULL) {
snprintf(tmp, MAX_PATH+50,
G_("unable to open file %s for reading"), sname);
R_ShowMessage(tmp);
return;
}
p->file = 1;
strncpy(p->filename, name, MAX_PATH+1);
bufsize = 0;
while (num > 0) {
buffer = realloc(buffer, bufsize + 3000 + 1);
num = fread(buffer + bufsize, 1, 3000 - 1, f);
if (num >= 0) {
bufsize += num;
buffer[bufsize] = '\0';
}
else {
snprintf(tmp, MAX_PATH+50,
G_("Could not read from file '%s'"), sname);
askok(tmp);
}
}
setlimittext(t, 2 * strlen(buffer));
settext(t, buffer);
gsetmodified(t, 0);
free(buffer);
fclose(f);
}
static void editorrun(textbox t)
{
if (!busy_running) {
long start=0, end=0;
if (CharacterMode != RGui) {
R_ShowMessage(G_("No RGui console to paste to"));
return;
}
busy_running = TRUE;
textselectionex(t, &start, &end);
if (start >= end)
editorrunline(t);
else {
editorrunselection(t, start, end);
selecttextex(t, end, end); /* move insertion point to end of selection after running */
}
busy_running = FALSE;
}
}
static void private_delmetafile(metafile obj)
{
HENHMETAFILE hm;
if (!obj || (obj->kind != MetafileObject)) return;
hm = (HENHMETAFILE) CloseEnhMetaFile((HDC) obj->handle);
if (strlen(GA_gettext(obj))) { /* real file*/
DeleteEnhMetaFile(hm);
return;
}
if (OpenClipboard(NULL) && EmptyClipboard() && /* try to save to the*/
SetClipboardData(CF_ENHMETAFILE, hm) && /*clipboard */
CloseClipboard())
return;
else {
R_ShowMessage(_("Unable to save metafile to the clipboard"));
DeleteEnhMetaFile(hm);
return;
}
}
SEXP plasma_dsyMatrix_matrix_mm(SEXP a, SEXP b, SEXP rtP)
{
#ifdef HIPLAR_WITH_PLASMA
SEXP val = PROTECT(dup_mMatrix_as_dgeMatrix(b));
int rt = asLogical(rtP); /* if(rt), compute b %*% a, else a %*% b */
int *adims = INTEGER(GET_SLOT(a, Matrix_DimSym)),
*bdims = INTEGER(GET_SLOT(val, Matrix_DimSym)),
m = bdims[0], n = bdims[1];
double one = 1., zero = 0.;
double *vx = REAL(GET_SLOT(val, Matrix_xSym));
double *bcp = (double*)malloc(m * n * sizeof(double));
memcpy(bcp, vx, m * n * sizeof(double));
int info;
R_CheckStack();
#ifdef HIPLAR_DBG
R_ShowMessage("DBG: Entering plasma_dsyMatrix_matrix_mm");
#endif
if ((rt && n != adims[0]) || (!rt && m != adims[0]))
error(_("Matrices are not conformable for multiplication"));
if (m < 1 || n < 1) {
/* error(_("Matrices with zero extents cannot be multiplied")); */
} else {
info = P_dsymm(rt ? "R" :"L", uplo_P(a), m, n, one,
REAL(GET_SLOT(a, Matrix_xSym)), adims[0], bcp,
m, zero, vx, m);
if (info) {
error(_("PLASMA routine %s returned error code %d"), "PLASMA_dsymm", info);
}
}
UNPROTECT(1);
free(bcp);
return val;
#endif
return R_NilValue;
}
double magma_get_norm_sy(SEXP obj, const char *typstr)
{
#ifdef HIPLAR_WITH_MAGMA
char typnm[] = {'\0', '\0'};
int *dims = INTEGER(GET_SLOT(obj, Matrix_DimSym));
double *work = (double *) NULL;
int N = dims[0];
int lda = N;
double *A = REAL(GET_SLOT(obj, Matrix_xSym));
typnm[0] = La_norm_type(typstr);
const char *c = uplo_P(obj);
//Magmablas dlansy only does I & M norms
if(GPUFlag == 1 && (*typnm == 'I' || *typnm == 'M')) {
#ifdef HIPLAR_DBG
R_ShowMessage("DBG: Performing norm using magmablas_dlansy");
#endif
double *dwork, *d_A, maxnorm;
cublasAlloc(N, sizeof(double), (void**)&dwork);
cublasAlloc(lda * N, sizeof(double), (void**)&d_A);
cublasSetVector(N * lda, sizeof(double), A, 1, d_A, 1);
maxnorm = magmablas_dlansy(typnm[0], *c ,N, d_A, lda, dwork);
cublasFree(d_A);
cublasFree(dwork);
return maxnorm;
}
else {
if (*typnm == 'I' || *typnm == 'O') {
work = (double *) R_alloc(dims[0], sizeof(double));
}
return F77_CALL(dlansy)(typnm, uplo_P(obj),
dims, A,
dims, work);
}
#endif
return 0.0;
}
SEXP magma_dgeMatrix_determinant(SEXP x, SEXP logarithm)
{
#ifdef HIPLAR_WITH_MAGMA
#ifdef HIPLAR_DBG
R_ShowMessage("DBG: Entering magma_dgeMatrix_determinant");
#endif
int lg = asLogical(logarithm);
int *dims = INTEGER(GET_SLOT(x, Matrix_DimSym)),
n = dims[0], sign = 1;
double modulus = lg ? 0. : 1; /* initialize; = result for n == 0 */
if (n != dims[1])
error(_("Determinant requires a square matrix"));
if (n > 0) {
SEXP lu = magma_dgeMatrix_LU_(x, /* do not warn about singular LU: */ FALSE);
int i, *jpvt = INTEGER(GET_SLOT(lu, Matrix_permSym));
double *luvals = REAL(GET_SLOT(lu, Matrix_xSym));
for (i = 0; i < n; i++) if (jpvt[i] != (i + 1)) sign = -sign;
if (lg) {
for (i = 0; i < n; i++) {
double dii = luvals[i*(n + 1)]; /* ith diagonal element */
modulus += log(dii < 0 ? -dii : dii);
if (dii < 0) sign = -sign;
}
} else {
for (i = 0; i < n; i++)
modulus *= luvals[i*(n + 1)];
if (modulus < 0) {
modulus = -modulus;
sign = -sign;
}
}
}
return as_det_obj(modulus, lg, sign);
#endif
return R_NilValue;
}
static
double magma_get_norm(SEXP obj, const char *typstr)
{
#ifdef HIPLAR_WITH_MAGMA
if(any_NA_in_x(obj))
return NA_REAL;
else {
char typnm[] = {'\0', '\0'};
int *dims = INTEGER(GET_SLOT(obj, Matrix_DimSym));
double *work = (double *) NULL;
typnm[0] = La_norm_type(typstr);
if (*typnm == 'I') {
work = (double *) R_alloc(dims[0], sizeof(double));
if(GPUFlag == 1 && (dims[0] % 64 == 0) && (dims[1] % 64 == 0)) {
#ifdef HIPLAR_DBG
R_ShowMessage("DBG: Getting norm using magmablas_dlange");
#endif
double *d_work, *d_A, *A, val;
A = REAL(GET_SLOT(obj, Matrix_xSym));
cublasAlloc(dims[0] * dims[1], sizeof(double), (void**)&d_A);
cublasAlloc(dims[0], sizeof(double), (void**)&d_work);
cublasSetVector(dims[0] * dims[1], sizeof(double), A, 1, d_A, 1);
val = magmablas_dlange(*typstr, dims[0], dims[1], d_A, dims[0], d_work);
cudaFree(d_A);
cudaFree(d_work);
return val;
}
}
return F77_CALL(dlange)(typstr, dims, dims+1,
REAL(GET_SLOT(obj, Matrix_xSym)),
dims, work);
}
#endif
return 0.0;
}
static HDC chooseprinter(void)
{
PRINTDLG pd;
HDC dc;
DWORD rc;
char cwd[MAX_PATH];
GetCurrentDirectory(MAX_PATH,cwd);
pd.lStructSize = sizeof( PRINTDLG );
pd.hwndOwner = NULL;
pd.hDevMode = (HANDLE)NULL;
pd.hDevNames = (HANDLE)NULL;
pd.Flags = PD_RETURNDC | PD_NOSELECTION | PD_NOPAGENUMS |
PD_USEDEVMODECOPIES;
pd.nFromPage = 0;
pd.nToPage = 0;
pd.nMinPage = 0;
pd.nMaxPage = 0;
pd.nCopies = 1;
pd.hInstance = (HINSTANCE)NULL;
pd.lCustData = (LPARAM)0;
pd.lpfnPrintHook = 0;
pd.lpfnSetupHook = 0;
pd.lpPrintTemplateName = (LPCSTR) 0;
pd.lpSetupTemplateName = (LPCSTR) 0;
pd.hPrintTemplate = (HGLOBAL)0;
pd.hSetupTemplate = (HGLOBAL)0;
dc = PrintDlg( &pd ) ? pd.hDC : NULL;
SetCurrentDirectory(cwd);
if (!dc) {
rc = CommDlgExtendedError(); /* 0 means user cancelled */
if (rc) R_ShowMessage(_("Unable to choose printer"));
}
return dc;
}
printer newprinter(double width, double height, const char *name)
{
DOCINFO docinfo;
printer obj;
HDC hDC;
double dd,AL;
int ww,hh,x0,y0;
if(strlen(name)) {
OSVERSIONINFO verinfo;
verinfo.dwOSVersionInfoSize = sizeof(OSVERSIONINFO);
GetVersionEx(&verinfo);
switch(verinfo.dwPlatformId) {
case VER_PLATFORM_WIN32_NT:
hDC = CreateDC("WINSPOOL", name, NULL, NULL);
default:
hDC = CreateDC(NULL, name, NULL, NULL);
}
} else hDC = chooseprinter();
if ( !hDC ) return NULL;
obj = new_object(PrinterObject, (HANDLE) hDC, get_printer_base());
if ( !obj ) {
R_ShowMessage(_("Insufficient memory for new printer"));
DeleteDC(hDC);
return NULL;
}
if ((width == 0.0) && (height == 0.0)) {
ww = GetDeviceCaps(hDC, HORZRES);
hh = GetDeviceCaps(hDC, VERTRES);
}
else {
if (width < 0.1) width = 0.1;
if (height < 0.1) height = 0.1;
dd = GetDeviceCaps(hDC, HORZSIZE) / width;
AL = (dd < 1.0) ? dd : 1.0;
dd = GetDeviceCaps(hDC, VERTSIZE) / height;
AL = (dd < AL) ? dd : AL;
ww = (AL * width) * GetDeviceCaps(hDC, LOGPIXELSX) / 25.4;
hh = (AL * height) * GetDeviceCaps(hDC, LOGPIXELSY) / 25.4;
}
x0 = (GetDeviceCaps(hDC, HORZRES) - ww) / 2;
y0 = (GetDeviceCaps(hDC, VERTRES) - hh) / 2;
obj->rect = rect(x0, y0, ww, hh);
obj->depth = GetDeviceCaps(hDC, BITSPIXEL)* GetDeviceCaps(hDC, PLANES);
obj->die = private_delprinter;
obj->drawstate = copydrawstate();
obj->drawstate->dest = obj;
docinfo.cbSize = sizeof(DOCINFO); /* set this size... */
docinfo.lpszDocName = "GraphAppPrintJob";
docinfo.lpszOutput = 0; /* no file output... */
docinfo.lpszDatatype = 0;
docinfo.fwType = 0;
if (StartDoc(hDC, &docinfo) <= 0) {
R_ShowMessage(_("Unable to start the print job"));
del(obj);
return NULL;
}
StartPage(hDC);
return obj;
}
SEXP hiplarbSet(SEXP var, SEXP val) {
const char *pVar = CHAR(STRING_ELT(var,0));
int tmpVal = asInteger(val);
if(strcmp(pVar, "hiplar_library") == 0) {
switch (tmpVal) {
case HIPLAR_USE_PLASMA:
hiplar_library = HIPLAR_USE_PLASMA;
break;
case HIPLAR_USE_MAGMA:
hiplar_library = HIPLAR_USE_MAGMA;
break;
case HIPLAR_USE_AUTO:
hiplar_library = HIPLAR_USE_AUTO;
break;
default:
hiplar_library = HIPLAR_USE_AUTO;
}
} else if (strcmp(pVar, "magma_interface") == 0) {
magma_interface = tmpVal;
if ((magma_interface != MAGMA_CPU_INTERFACE) &&
(magma_interface != MAGMA_GPU_INTERFACE)) {
magma_interface = MAGMA_CPU_INTERFACE;
}
} else if(strcmp(pVar, "xover_zgeqrf") == 0) {
xover_zgeqrf = tmpVal;
} else if(strcmp(pVar, "xover_dgeqrf") == 0) {
xover_dgeqrf = tmpVal;
} else if(strcmp(pVar, "xover_chol") == 0) {
xover_chol = tmpVal;
} else if(strcmp(pVar, "xover_chol2inv") == 0) {
xover_chol2inv = tmpVal;
} else if(strcmp(pVar, "xover_zgesv") == 0) {
xover_zgesv = tmpVal;
} else if(strcmp(pVar, "xover_dgesv") == 0) {
xover_dgesv = tmpVal;
} else if(strcmp(pVar, "xover_dlange") == 0) {
xover_dlange = tmpVal;
} else if(strcmp(pVar, "xover_bakslv") == 0) {
xover_bakslv = tmpVal;
} else if(strcmp(pVar, "xover_svd") == 0) {
xover_svd = tmpVal;
} else if(strcmp(pVar, "xover_svd_cmplx") == 0) {
xover_svd_cmplx = tmpVal;
} else if(strcmp(pVar, "xover_rs") == 0) {
xover_rs = tmpVal;
} else if(strcmp(pVar, "xover_rs_cmplx") == 0) {
xover_rs_cmplx = tmpVal;
} else if(strcmp(pVar, "xover_rg") == 0) {
xover_rg = tmpVal;
} else if(strcmp(pVar, "xover_rg_cmplx") == 0) {
xover_rg_cmplx = tmpVal;
} else if(strcmp(pVar, "xover_det_ge_real") == 0) {
xover_det_ge_real = tmpVal;
} else if(strcmp(pVar, "xover_dgecon") == 0) {
xover_dgecon = tmpVal;
} else if(strcmp(pVar, "xover_zgecon") == 0) {
xover_zgecon = tmpVal;
} else if(strcmp(pVar, "xover_matprod") == 0) {
xover_matprod = tmpVal;
} else if(strcmp(pVar, "maxmagma_zgeqrf") == 0) {
maxmagma_zgeqrf = tmpVal;
} else if(strcmp(pVar, "maxmagma_dgeqrf") == 0) {
maxmagma_dgeqrf = tmpVal;
} else if(strcmp(pVar, "maxmagma_chol") == 0) {
maxmagma_chol = tmpVal;
} else if(strcmp(pVar, "maxmagma_chol2inv") == 0) {
maxmagma_chol2inv = tmpVal;
} else if(strcmp(pVar, "maxmagma_zgesv") == 0) {
maxmagma_zgesv = tmpVal;
} else if(strcmp(pVar, "maxmagma_dgesv") == 0) {
maxmagma_dgesv = tmpVal;
} else if(strcmp(pVar, "maxmagma_dlange") == 0) {
maxmagma_dlange = tmpVal;
} else if(strcmp(pVar, "maxmagma_bakslv") == 0) {
maxmagma_bakslv = tmpVal;
} else if(strcmp(pVar, "maxmagma_svd") == 0) {
maxmagma_svd = tmpVal;
} else if(strcmp(pVar, "maxmagma_svd_cmplx") == 0) {
maxmagma_svd_cmplx = tmpVal;
} else if(strcmp(pVar, "maxmagma_rs") == 0) {
maxmagma_rs = tmpVal;
} else if(strcmp(pVar, "maxmagma_rs_cmplx") == 0) {
maxmagma_rs_cmplx = tmpVal;
} else if(strcmp(pVar, "maxmagma_rg") == 0) {
maxmagma_rg = tmpVal;
} else if(strcmp(pVar, "maxmagma_rg_cmplx") == 0) {
maxmagma_rg_cmplx = tmpVal;
} else if(strcmp(pVar, "maxmagma_det_ge_real") == 0) {
maxmagma_det_ge_real = tmpVal;
} else if(strcmp(pVar, "maxmagma_dgecon") == 0) {
maxmagma_dgecon = tmpVal;
} else if(strcmp(pVar, "maxmagma_zgecon") == 0) {
maxmagma_zgecon = tmpVal;
} else if(strcmp(pVar, "maxmagma_matprod") == 0) {
maxmagma_matprod = tmpVal;
} else {
R_ShowMessage("ERROR: Unknow variable");
}
return R_NilValue;
}
