The R Project SVN – R – Diff – /trunk/src/gnuwin32/dodevga.c


/*
 *  R : A Computer Language for Statistical Data Analysis
 *  Copyright (C) 1998-2003  Guido Masarotto and Brian Ripley
 *
 *  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., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
 */
 
#ifdef HAVE_CONFIG_H
#include <config.h>
#endif
 
#include <Defn.h>
#include <Graphics.h>
#include <Rdevices.h>
#include "devga.h"
 
/* Return a non-relocatable copy of a string */
 
static SEXP gcall;
 
static char *SaveString(SEXP sxp, int offset)
{
    char *s;
 
    if (!isString(sxp) || length(sxp) <= offset)
	errorcall(gcall, "invalid string argument");
    s = R_alloc(strlen(CHAR(STRING_ELT(sxp, offset))) + 1, sizeof(char));
    strcpy(s, CHAR(STRING_ELT(sxp, offset)));
    return s;
}
 
/* This is Guido's devga device. */
 
SEXP do_devga(SEXP call, SEXP op, SEXP args, SEXP env)
{
    NewDevDesc *dev;
    GEDevDesc* dd;
    char *display, *vmax;
    double height, width, ps, xpinch, ypinch, gamma;
    int recording = 0, resize = 1, canvas, xpos, ypos, buffered;
    SEXP sc, psenv;
 
    checkArity(op, args);
    gcall = call;
    vmax = vmaxget();
    display = SaveString(CAR(args), 0);
    args = CDR(args);
    width = asReal(CAR(args));
    args = CDR(args);
    height = asReal(CAR(args));
    args = CDR(args);
    if (width <= 0 || height <= 0)
	errorcall(call, "invalid width or height");
    ps = asReal(CAR(args));
    args = CDR(args);
    recording = asLogical(CAR(args));
    if (recording == NA_LOGICAL)
	errorcall(call, "invalid value of `recording'");
    args = CDR(args);
    resize = asInteger(CAR(args));
    if (resize == NA_INTEGER)
	errorcall(call, "invalid value of `resize'");
    args = CDR(args);
    xpinch = asReal(CAR(args));
    args = CDR(args);
    ypinch = asReal(CAR(args));
    args = CDR(args);
    sc = CAR(args);
    if (!isString(sc) && !isInteger(sc) && !isLogical(sc) && !isReal(sc))
	errorcall(call, "invalid value of `canvas'");
    canvas = RGBpar(sc, 0);
    args = CDR(args);
    gamma = asReal(CAR(args));
    args = CDR(args);
    xpos = asInteger(CAR(args));
    args = CDR(args);
    ypos = asInteger(CAR(args));
    args = CDR(args);
    buffered = asLogical(CAR(args));
    if (buffered == NA_LOGICAL)
	errorcall(call, "invalid value of `buffered'");
    args = CDR(args);
    psenv = CAR(args);
    
    R_CheckDeviceAvailable();
    BEGIN_SUSPEND_INTERRUPTS {
	/* Allocate and initialize the device driver data */
	if (!(dev = (NewDevDesc *) calloc(1, sizeof(NewDevDesc))))
	    return 0;
	/* Do this for early redraw attempts */
	dev->displayList = R_NilValue;
	/* Make sure that this is initialised before a GC can occur.
	 * This (and displayList) get protected during GC
	 */
	dev->savedSnapshot = R_NilValue;
	GAsetunits(xpinch, ypinch);
	if (!GADeviceDriver(dev, display, width, height, ps, 
			    (Rboolean)recording, resize, canvas, gamma,
			    xpos, ypos, (Rboolean)buffered, psenv)) {
	    free(dev);
	    errorcall(call, "unable to start device devga");
	}
	gsetVar(install(".Device"),
		mkString(display[0] ? display : "windows"), R_NilValue);
	dd = GEcreateDevDesc(dev);
	addDevice((DevDesc*) dd);
	GEinitDisplayList(dd);
    } END_SUSPEND_INTERRUPTS;
    vmaxset(vmax);
    return R_NilValue;
}

Rev 26109	Rev 27526
1	`/*`	1	`/*`
2	`* R : A Computer Language for Statistical Data Analysis`	2	`* R : A Computer Language for Statistical Data Analysis`
3	`* Copyright (C) 1998-2003 Guido Masarotto and Brian Ripley`	3	`* Copyright (C) 1998-2003 Guido Masarotto and Brian Ripley`
4	`*`	4	`*`
5	`* This program is free software; you can redistribute it and/or modify`	5	`* This program is free software; you can redistribute it and/or modify`
6	`* it under the terms of the GNU General Public License as published by`	6	`* it under the terms of the GNU General Public License as published by`
7	`* the Free Software Foundation; either version 2 of the License, or`	7	`* the Free Software Foundation; either version 2 of the License, or`
8	`* (at your option) any later version.`	8	`* (at your option) any later version.`
9	`*`	9	`*`
10	`* This program is distributed in the hope that it will be useful,`	10	`* This program is distributed in the hope that it will be useful,`
11	`* but WITHOUT ANY WARRANTY; without even the implied warranty of`	11	`* but WITHOUT ANY WARRANTY; without even the implied warranty of`
12	`* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the`	12	`* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the`
13	`* GNU General Public License for more details.`	13	`* GNU General Public License for more details.`
14	`*`	14	`*`
15	`* You should have received a copy of the GNU General Public License`	15	`* You should have received a copy of the GNU General Public License`
16	`* along with this program; if not, write to the Free Software`	16	`* along with this program; if not, write to the Free Software`
17	`* Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA`	17	`* Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA`
18	`*/`	18	`*/`
19		19
20	`#ifdef HAVE_CONFIG_H`	20	`#ifdef HAVE_CONFIG_H`
21	`#include <config.h>`	21	`#include <config.h>`
22	`#endif`	22	`#endif`
23		23
24	`#include <Defn.h>`	24	`#include <Defn.h>`
25	`#include <Graphics.h>`	25	`#include <Graphics.h>`
26	`#include <Rdevices.h>`	26	`#include <Rdevices.h>`
27	`#include "devga.h"`	27	`#include "devga.h"`
28		28
29	`/* Return a non-relocatable copy of a string */`	29	`/* Return a non-relocatable copy of a string */`
30		30
31	`static SEXP gcall;`	31	`static SEXP gcall;`
32		32
33	`static char *SaveString(SEXP sxp, int offset)`	33	`static char *SaveString(SEXP sxp, int offset)`
34	`{`	34	`{`
35	`char *s;`	35	`char *s;`
36		36
37	`if (!isString(sxp) \|\| length(sxp) <= offset)`	37	`if (!isString(sxp) \|\| length(sxp) <= offset)`
38	`errorcall(gcall, "invalid string argument");`	38	`errorcall(gcall, "invalid string argument");`
39	`s = R_alloc(strlen(CHAR(STRING_ELT(sxp, offset))) + 1, sizeof(char));`	39	`s = R_alloc(strlen(CHAR(STRING_ELT(sxp, offset))) + 1, sizeof(char));`
40	`strcpy(s, CHAR(STRING_ELT(sxp, offset)));`	40	`strcpy(s, CHAR(STRING_ELT(sxp, offset)));`
41	`return s;`	41	`return s;`
42	`}`	42	`}`
43		43
44	`/* This is Guido's devga device. */`	44	`/* This is Guido's devga device. */`
45		45
46	`SEXP do_devga(SEXP call, SEXP op, SEXP args, SEXP env)`	46	`SEXP do_devga(SEXP call, SEXP op, SEXP args, SEXP env)`
47	`{`	47	`{`
48	`NewDevDesc *dev;`	48	`NewDevDesc *dev;`
49	`GEDevDesc* dd;`	49	`GEDevDesc* dd;`
50	`char display, vmax;`	50	`char display, vmax;`
51	`double height, width, ps, xpinch, ypinch, gamma;`	51	`double height, width, ps, xpinch, ypinch, gamma;`
52	`int recording = 0, resize = 1, canvas, xpos, ypos, buffered;`	52	`int recording = 0, resize = 1, canvas, xpos, ypos, buffered;`
53	`SEXP sc;`	53	`SEXP sc, psenv;`
54		54
55	`checkArity(op, args);`	55	`checkArity(op, args);`
56	`gcall = call;`	56	`gcall = call;`
57	`vmax = vmaxget();`	57	`vmax = vmaxget();`
58	`display = SaveString(CAR(args), 0);`	58	`display = SaveString(CAR(args), 0);`
59	`args = CDR(args);`	59	`args = CDR(args);`
60	`width = asReal(CAR(args));`	60	`width = asReal(CAR(args));`
61	`args = CDR(args);`	61	`args = CDR(args);`
62	`height = asReal(CAR(args));`	62	`height = asReal(CAR(args));`
63	`args = CDR(args);`	63	`args = CDR(args);`
64	`if (width <= 0 \|\| height <= 0)`	64	`if (width <= 0 \|\| height <= 0)`
65	`errorcall(call, "invalid width or height");`	65	`errorcall(call, "invalid width or height");`
66	`ps = asReal(CAR(args));`	66	`ps = asReal(CAR(args));`
67	`args = CDR(args);`	67	`args = CDR(args);`
68	`recording = asLogical(CAR(args));`	68	`recording = asLogical(CAR(args));`
69	`if (recording == NA_LOGICAL)`	69	`if (recording == NA_LOGICAL)`
70	errorcall(call, "invalid value of `recording'");	70	errorcall(call, "invalid value of `recording'");
71	`args = CDR(args);`	71	`args = CDR(args);`
72	`resize = asInteger(CAR(args));`	72	`resize = asInteger(CAR(args));`
73	`if (resize == NA_INTEGER)`	73	`if (resize == NA_INTEGER)`
74	errorcall(call, "invalid value of `resize'");	74	errorcall(call, "invalid value of `resize'");
75	`args = CDR(args);`	75	`args = CDR(args);`
76	`xpinch = asReal(CAR(args));`	76	`xpinch = asReal(CAR(args));`
77	`args = CDR(args);`	77	`args = CDR(args);`
78	`ypinch = asReal(CAR(args));`	78	`ypinch = asReal(CAR(args));`
79	`args = CDR(args);`	79	`args = CDR(args);`
80	`sc = CAR(args);`	80	`sc = CAR(args);`
81	`if (!isString(sc) && !isInteger(sc) && !isLogical(sc) && !isReal(sc))`	81	`if (!isString(sc) && !isInteger(sc) && !isLogical(sc) && !isReal(sc))`
82	errorcall(call, "invalid value of `canvas'");	82	errorcall(call, "invalid value of `canvas'");
83	`canvas = RGBpar(sc, 0);`	83	`canvas = RGBpar(sc, 0);`
84	`args = CDR(args);`	84	`args = CDR(args);`
85	`gamma = asReal(CAR(args));`	85	`gamma = asReal(CAR(args));`
86	`args = CDR(args);`	86	`args = CDR(args);`
87	`xpos = asInteger(CAR(args));`	87	`xpos = asInteger(CAR(args));`
88	`args = CDR(args);`	88	`args = CDR(args);`
89	`ypos = asInteger(CAR(args));`	89	`ypos = asInteger(CAR(args));`
90	`args = CDR(args);`	90	`args = CDR(args);`
91	`buffered = asLogical(CAR(args));`	91	`buffered = asLogical(CAR(args));`
92	`if (buffered == NA_LOGICAL)`	92	`if (buffered == NA_LOGICAL)`
93	errorcall(call, "invalid value of `buffered'");	93	errorcall(call, "invalid value of `buffered'");
-		94	`args = CDR(args);`
-		95	`psenv = CAR(args);`
94		96
95	`R_CheckDeviceAvailable();`	97	`R_CheckDeviceAvailable();`
96	`BEGIN_SUSPEND_INTERRUPTS {`	98	`BEGIN_SUSPEND_INTERRUPTS {`
97	`/* Allocate and initialize the device driver data */`	99	`/* Allocate and initialize the device driver data */`
98	`if (!(dev = (NewDevDesc *) calloc(1, sizeof(NewDevDesc))))`	100	`if (!(dev = (NewDevDesc *) calloc(1, sizeof(NewDevDesc))))`
99	`return 0;`	101	`return 0;`
100	`/* Do this for early redraw attempts */`	102	`/* Do this for early redraw attempts */`
101	`dev->displayList = R_NilValue;`	103	`dev->displayList = R_NilValue;`
102	`/* Make sure that this is initialised before a GC can occur.`	104	`/* Make sure that this is initialised before a GC can occur.`
103	`* This (and displayList) get protected during GC`	105	`* This (and displayList) get protected during GC`
104	`*/`	106	`*/`
105	`dev->savedSnapshot = R_NilValue;`	107	`dev->savedSnapshot = R_NilValue;`
106	`GAsetunits(xpinch, ypinch);`	108	`GAsetunits(xpinch, ypinch);`
107	`if (!GADeviceDriver(dev, display, width, height, ps,`	109	`if (!GADeviceDriver(dev, display, width, height, ps,`
108	`(Rboolean)recording, resize, canvas, gamma,`	110	`(Rboolean)recording, resize, canvas, gamma,`
109	`xpos, ypos, (Rboolean)buffered)) {`	111	`xpos, ypos, (Rboolean)buffered, psenv)) {`
110	`free(dev);`	112	`free(dev);`
111	`errorcall(call, "unable to start device devga");`	113	`errorcall(call, "unable to start device devga");`
112	`}`	114	`}`
113	`gsetVar(install(".Device"),`	115	`gsetVar(install(".Device"),`
114	`mkString(display[0] ? display : "windows"), R_NilValue);`	116	`mkString(display[0] ? display : "windows"), R_NilValue);`
115	`dd = GEcreateDevDesc(dev);`	117	`dd = GEcreateDevDesc(dev);`
116	`addDevice((DevDesc*) dd);`	118	`addDevice((DevDesc*) dd);`
117	`GEinitDisplayList(dd);`	119	`GEinitDisplayList(dd);`
118	`} END_SUSPEND_INTERRUPTS;`	120	`} END_SUSPEND_INTERRUPTS;`
119	`vmaxset(vmax);`	121	`vmaxset(vmax);`
120	`return R_NilValue;`	122	`return R_NilValue;`
121	`}`	123	`}`

The R Project SVN R

(root)/trunk/src/gnuwin32/dodevga.c @ 28362 – Rev 26109 → 27526