The R Project SVN R

Rev

Details | Last modification | View Log | RSS feed

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