The R Project SVN – R – Diff – /branches/djm-source/src/main/devPS.c

 /*
  *  R : A Computer Language for Statistical Data Analysis
  *  Copyright (C) 1995, 1996  Robert Gentleman and Ross Ihaka
- *  Copyright (C) 1998--2003  Robert Gentleman, Ross Ihaka and the
+ *  Copyright (C) 1998--2004  Robert Gentleman, Ross Ihaka and the
  *                            R Development Core Team
+ *
  *  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
     { NULL }
 };
-static char familyname[5][50];
 /* Part 1.  AFM File Parsing.  */
 /* These are the basic entities in the AFM file */
 #define BUFSIZE 512
 	    (metrics->FontBBox[3]));
 #endif
     return 1;
+}
-static char charnames[256][25];
+typedef struct {
-static char encnames[256][25];
+    char cname[25];
+} CNAME;
 /* If reencode > 0, remap to new encoding */
-static int GetCharInfo(char *buf, FontMetricInfo *metrics, int reencode)
+static int GetCharInfo(char *buf, FontMetricInfo *metrics,
+		       CNAME *charnames, CNAME *encnames,
+		       int reencode)
+{
     char *p = buf, charname[25];
     int nchar, nchar2=-1, i;
     short WX;
 	Rprintf("char name %s\n", charname);
 #endif
 	/* a few chars appear twice in ISOLatin1 */
 	nchar = nchar2 = -1;
 	for (i = 0; i < 256; i++)
-	    if(!strcmp(charname, encnames[i])) {
+	    if(!strcmp(charname, encnames[i].cname)) {
-		strcpy(charnames[i], charname);
+		strcpy(charnames[i].cname, charname);
 		if(nchar == -1) nchar = i; else nchar2 = i;
+	    }
 	if (nchar == -1) return 1;
     } else {
-	sscanf(p, "%s", charnames[nchar]);
+	sscanf(p, "%s", charnames[nchar].cname);
+    }
     metrics->CharInfo[nchar].WX = WX;
     p = SkipToNextKey(p);
     if (!MatchKey(p, "B ")) return 0;
 #endif
+    }
     return 1;
+}
-static int GetKPX(char *buf, int nkp, FontMetricInfo *metrics)
+static int GetKPX(char *buf, int nkp, FontMetricInfo *metrics,
+		  CNAME *charnames)
+{
     char *p = buf, c1[50], c2[50];
     int i, done = 0;
     p = SkipToNextItem(p);
     sscanf(p, "%s %s %hd", c1, c2, &(metrics->KernPairs[nkp].kern));
     for(i = 0; i < 256; i++) {
-	if (!strcmp(c1, charnames[i])) {
+	if (!strcmp(c1, charnames[i].cname)) {
 	    metrics->KernPairs[nkp].c1 = i;
 	    done++;
 	    break;
+	}
+    }
     for(i = 0; i < 256; i++)
-	if (!strcmp(c2, charnames[i])) {
+	if (!strcmp(c2, charnames[i].cname)) {
 	    metrics->KernPairs[nkp].c2 = i;
 	    done++;
 	    break;
+	}
     return (done==2);
 	break;
+    }
     return 0;
+}
-static char enccode[5000];
 /* Load encoding array from a file: defaults to the R_HOME/afm directory */
+/*
+ * encpath gives the file to read from
+ * encname is filled with the encoding name from the file
+ * encnames is filled with the character names from the file
+ * enccode is filled with the raw source of the file
+ */
 static int
-LoadEncoding(char *encpath, char *encname, Rboolean isPDF)
+LoadEncoding(char *encpath, char *encname, CNAME *encnames,
+	     char *enccode, Rboolean isPDF)
+{
     char buf[BUFSIZE];
     int i;
     FILE *fp;
     EncodingInputState state;
     if (!isPDF) snprintf(enccode, 5000, "/%s [\n", encname);
     else enccode[0] = '\0';
     if (GetNextItem(fp, buf, 0, &state)) { fclose(fp); return 0;} /* [ */
     for(i = 0; i < 256; i++) {
 	if (GetNextItem(fp, buf, i, &state)) { fclose(fp); return 0; }
-	strcpy(encnames[i], buf+1);
+	strcpy(encnames[i].cname, buf+1);
-	strcat(enccode, " /"); strcat(enccode, encnames[i]);
+	strcat(enccode, " /"); strcat(enccode, encnames[i].cname);
 	if(i%8 == 7) strcat(enccode, "\n");
+    }
     if (GetNextItem(fp, buf, 0, &state)) { fclose(fp); return 0;} /* ] */
     fclose(fp);
     if (!isPDF) strcat(enccode,"]\n");
 /* Load font metrics from a file: defaults to the R_HOME/afm directory */
 static int
-PostScriptLoadFontMetrics(const char * const fontpath, FontMetricInfo *metrics,
+PostScriptLoadFontMetrics(const char * const fontpath,
+			  FontMetricInfo *metrics,
-			  char *fontname, int reencode)
+			  char *fontname,
+			  CNAME *charnames,
+			  CNAME *encnames,
+			  int reencode)
+{
     char buf[BUFSIZE], *p;
     int mode, i = 0, j, ii, nKPX=0;
     FILE *fp;
     Rprintf("reencode is %d\n", reencode);
 #endif
     if (!(fp = R_fopen(R_ExpandFileName(buf), "r"))) return 0;
+    metrics->KernPairs = NULL;
     mode = 0;
     for (ii = 0; ii < 256; ii++) {
-	charnames[ii][0] = '\0';
+	charnames[ii].cname[0] = '\0';
 	metrics->CharInfo[ii].WX = NA_SHORT;
 	for(j = 0; j < 4; j++) metrics->CharInfo[ii].BBox[j] = 0;
+    }
     while (fgets(buf, BUFSIZE, fp)) {
 	switch(KeyType(buf)) {
 	    if (!GetFontBBox(buf, metrics)) goto pserror;
 	    break;
 	case C:
 	    if (mode != StartFontMetrics) goto pserror;
-	    if (!GetCharInfo(buf, metrics, reencode)) goto pserror;
+	    if (!GetCharInfo(buf, metrics, charnames, encnames, reencode))
+		goto pserror;
 	    break;
 	case StartKernData:
 	    mode = StartKernData;
 	    break;
+	    }
 	    break;
 	case KPX:
 	    if(mode != StartKernData || i >= nKPX) goto pserror;
-	    if (GetKPX(buf, i, metrics)) i++;
+	    if (GetKPX(buf, i, metrics, charnames)) i++;
 	    break;
 	case EndKernData:
 	    mode = 0;
 	    break;
 	*width = 0.001 * wx;
+    }
+}
+/*******************************************************
+ * Data structures and functions for loading Type 1 fonts into an R session.
+ *
+ * Used by PostScript, XFig and PDF drivers.
+ *
+ * The idea is that font information is only loaded once for each font
+ * within an R session.  Also, each encoding is only loaded once per
+ * session.  A global list of loaded fonts and a global list of
+ * loaded encodings are maintained.  Devices maintain their own list
+ * of fonts and encodings used on the device;  the elements of these
+ * lists are just pointers to the elements of the global lists.
+ *
+ * Cleaning up device lists just involves free'ing the lists themselves.
+ * When the R session closes, the actual font and encoding information
+ * is unloaded using the global lists.
+ */
+/*
-/*  Part 2.  Graphics Support Code.  */
+ * Information about one Type 1 font
+ */
+typedef struct T1FontInfo {
+    char name[50];
+    FontMetricInfo metrics;
+    CNAME charnames[256];
+} Type1FontInfo, *type1fontinfo;
+/*
+ * Information about a font encoding
+ */
+typedef struct EncInfo {
+    char encpath[PATH_MAX];
+    char name[100];
+    CNAME encnames[256];
+    char enccode[5000];
+} EncodingInfo, *encodinginfo;
+/*
+ * Information about a font family
+ * (5 fonts representing plain, bold, italic, bolditalic, and symbol)
+ *
+ * The name is a graphics engine font family name
+ * (distinct from the Type 1 font name)
+ */
+typedef struct T1FontFamily {
+    char name[50];
+    type1fontinfo fonts[5];
+    encodinginfo encoding;
+} Type1FontFamily, *type1fontfamily;
+/*
+ * A list of Type 1 font families
+ *
+ * Used to keep track of fonts currently loaded in the session
-static const char * const TypeFaceDef[] = { "R", "B", "I", "BI", "S" };
+ * AND by each device to keep track of fonts currently used on the device.
+ */
+typedef struct T1FontList {
+    type1fontfamily family;
+    struct T1FontList *next;
+} Type1FontList, *type1fontlist;
+/*
+ * Same as type 1 font list, but for encodings.
+ */
+typedef struct EncList {
+    encodinginfo encoding;
+    struct EncList *next;
+} EncodingList, *encodinglist;
+/*
+ * Various constructors and destructors
+ */
+static type1fontinfo makeType1Font()
+{
+    type1fontinfo font = (Type1FontInfo *) malloc(sizeof(Type1FontInfo));
+    if (!font)
+	warning("Failed to allocate Type 1 font info");
+    return font;
+}
+static void freeType1Font(type1fontinfo font)
+{
+    if (font->metrics.KernPairs)
+	free(font->metrics.KernPairs);
+    free(font);
+}
+static encodinginfo makeEncoding()
+{
+    encodinginfo encoding = (EncodingInfo *) malloc(sizeof(EncodingInfo));
+    if (!encoding)
+	warning("Failed to allocate encoding info");
+    return encoding;
+}
-static void PSEncodeFont(FILE *fp, char *encname)
+static void freeEncoding(encodinginfo encoding)
+{
+    free(encoding);
+}
+static type1fontfamily makeFontFamily()
+{
+    type1fontfamily family = (Type1FontFamily *) malloc(sizeof(Type1FontFamily));
+    if (family) {
+	int i;
+	for (i=0; i<5; i++)
+	    family->fonts[i] = NULL;
+	family->encoding = NULL;
+    } else
+	warning("Failed to allocate Type 1 font family");
+    return family;
+}
+/*
+ * Frees a font family, including fonts, but NOT encoding
+ *
+ * Used by global font list to free all fonts loaded in session
+ * (should not be used by devices; else may free fonts more than once)
+ *
+ * Encodings a freed using the global encoding list
+ * (to ensure that each encoding is only freed once)
+ */
+static void freeFontFamily(type1fontfamily family)
+{
     int i;
+    for (i=0; i<5; i++)
+	if (family->fonts[i])
+	    freeType1Font(family->fonts[i]);
+    free(family);
+}
+static type1fontlist makeFontList()
+{
-    /* include encoding unless it is ISOLatin1Encoding, which is predefined */
+    type1fontlist fontlist = (Type1FontList *) malloc(sizeof(Type1FontList));
-    if (strcmp(encname, "ISOLatin1Encoding"))
+    if (fontlist) {
+	fontlist->family = NULL;
+	fontlist->next = NULL;
+    } else
-	fprintf(fp, "%% begin encoding\n%s def\n%% end encoding\n", enccode);
+	warning("Failed to allocate font list");
+    return fontlist;
+}
+/*
+ * Just free the Type1FontList structure, do NOT free elements it points to
+ *
+ * Used by both global font list and devices to free the font lists
+ * (global font list separately takes care of the fonts pointed to)
+ */
+static void freeFontList(type1fontlist fontlist) {
+    /*
+     * These will help to find any errors if attempt to
+     * use freed font list.
+     */
+    fontlist->family = NULL;
+    fontlist->next = NULL;
+    free(fontlist);
+}
+static void freeDeviceFontList(type1fontlist fontlist) {
+    if (fontlist) {
+	if (fontlist->next)
+	    freeDeviceFontList(fontlist->next);
+	freeFontList(fontlist);
+    }
+}
+static encodinglist makeEncList()
+{
+    encodinglist enclist = (EncodingList *) malloc(sizeof(EncodingList));
+    if (enclist) {
+	enclist->encoding = NULL;
+	enclist->next = NULL;
+    } else
+	warning("Failed to allocated encoding list");
+    return enclist;
+}
+static void freeEncList(encodinglist enclist)
+{
+    enclist->encoding = NULL;
+    enclist->next = NULL;
+    free(enclist);
+}
+static void freeDeviceEncList(encodinglist enclist) {
+    if (enclist) {
+	if (enclist->next)
+	    freeDeviceEncList(enclist->next);
+	freeEncList(enclist);
+    }
+}
+/*
+ * Global list of fonts and encodings that have been loaded this session
+ */
+static type1fontlist loadedFonts = NULL;
+static encodinglist loadedEncodings = NULL;
+/*
+ * Free the above globals
+ *
+ * NOTE that freeing the font families does NOT free the encodings
+ * Hence we free all encodings first.
+ */
+void freeType1Fonts()
+{
+    encodinglist enclist = loadedEncodings;
+    type1fontlist fontlist = loadedFonts;
+    while (enclist) {
+	enclist = enclist->next;
+	freeEncoding(loadedEncodings->encoding);
+	freeEncList(loadedEncodings);
+	loadedEncodings = enclist;
+    }
+    while (fontlist) {
+	fontlist = fontlist->next;
+	freeFontFamily(loadedFonts->family);
+	freeFontList(loadedFonts);
+	loadedFonts = fontlist;
+    }
+}
+/*
+ * Given a path to an encoding file,
+ * find an EncodingInfo that corresponds
+ */
+static encodinginfo findEncoding(char *encpath)
+{
+    encodinglist enclist = loadedEncodings;
+    encodinginfo encoding = NULL;
+    int found = 0;
+    while (enclist && !found) {
+	found = !strcmp(encpath, enclist->encoding->encpath);
+	if (found)
+	    encoding = enclist->encoding;
+	enclist = enclist->next;
+    }
+    return encoding;
+}
+/*
+ * Find an encoding in device encoding list
+ */
+static encodinginfo findDeviceEncoding(char *encpath, encodinglist enclist,
+				       int *index)
+{
+    encodinginfo encoding = NULL;
+    int found = 0;
+    *index = 0;
+    while (enclist && !found) {
+	found = !strcmp(encpath, enclist->encoding->encpath);
+	if (found)
+	    encoding = enclist->encoding;
+	enclist = enclist->next;
+	*index = *index + 1;
+    }
+    return encoding;
+}
+/*
+ * Utility to avoid string overrun
+ */
+static void safestrcpy(char *dest, char *src, int maxlen)
+{
+    if (strlen(src) < maxlen)
+	strcpy(dest, src);
+    else {
+	warning("Truncated string which was too long for copy");
+	strncpy(dest, src, maxlen-1);
+	dest[maxlen-1] = '\0';
+    }
+}
+/*
+ * Add an encoding to the list of loaded encodings ...
+ *
+ * ... and return the new encoding
+ */
+static encodinginfo addEncoding(char* encpath,
+				Rboolean isPDF)
+{
+    encodinginfo encoding = makeEncoding();
+    if (encoding) {
+	if (LoadEncoding(encpath,
+			 encoding->name, encoding->encnames,
+			 encoding->enccode,
+			 isPDF)) {
+	    encodinglist newenc = makeEncList();
+	    if (!newenc) {
+		freeEncoding(encoding);
+		encoding = NULL;
+	    } else {
+		encodinglist enclist = loadedEncodings;
+		safestrcpy(encoding->encpath, encpath, PATH_MAX);
+		newenc->encoding = encoding;
+		if (!enclist)
+		    loadedEncodings = newenc;
+		else {
+		    while (enclist->next)
+			enclist = enclist->next;
+		    enclist->next = newenc;
+		}
+	    }
+	} else {
+	    warning("Failed to load encoding file");
+	    freeEncoding(encoding);
+	    encoding = NULL;
+	}
+    } else
+	encoding = NULL;
+    return encoding;
+}
+/*
+ * Add an encoding to a list of device encodings ...
+ *
+ * ... and return the new list
+ */
+static encodinglist addDeviceEncoding(encodinginfo encoding,
+				      encodinglist devEncs)
+{
+    encodinglist newenc = makeEncList();
+    if (!newenc) {
+	devEncs = NULL;
+    } else {
+	encodinglist enclist = devEncs;
+	newenc->encoding = encoding;
+	if (!devEncs)
+	    devEncs = newenc;
+	else {
+	    while (enclist->next)
+		enclist = enclist->next;
+	    enclist->next = newenc;
+	}
+    }
+    return devEncs;
+}
+/*
+ * Given a graphics engine font family name,
+ * find a Type1FontFamily that corresponds
+ *
+ * Returns NULL if can't find font in loadedFonts
+ */
+static type1fontfamily findLoadedFont(char *name)
+{
+    type1fontlist fontlist = loadedFonts;
+    type1fontfamily font = NULL;
+    int found = 0;
+    while (fontlist && !found) {
+	found = !strcmp(name, fontlist->family->name);
+	if (found)
+	    font = fontlist->family;
+	fontlist = fontlist->next;
+    }
+    return font;
+}
+SEXP do_Type1FontInUse(SEXP call, SEXP op, SEXP args, SEXP env)
+{
+    SEXP result;
+    SEXP name = CAR(args);
+    if (!isString(name) || LENGTH(name) > 1)
+	error("Invalid font name or more than one font name");
+    PROTECT(result = allocVector(LGLSXP, 1));
+    if (findLoadedFont(CHAR(STRING_ELT(name, 0))))
+	LOGICAL(result)[0] = TRUE;
+    else
+	LOGICAL(result)[0] = FALSE;
+    UNPROTECT(1);
+    return result;
+}
+/*
+ * Same as findLoadedFont only given different info
+ */
+static type1fontfamily findDefaultLoadedFont(char *encpath, char* family,
+					     Rboolean isPDF)
+{
+    type1fontlist fontlist = loadedFonts;
+    type1fontfamily font = NULL;
+    int found = 0;
+    while (fontlist && !found) {
+	found =
+	    !strcmp(encpath, fontlist->family->encoding->encpath) &&
+	    !strcmp(family, fontlist->family->fonts[0]->name);
+	if (found)
+	    font = fontlist->family;
+	fontlist = fontlist->next;
+    }
+    return font;
+}
+/*
+ * Find a font in device font list
+ */
+static type1fontfamily findDeviceFont(char *name, type1fontlist fontlist,
+				      int *index)
+{
+    type1fontfamily font = NULL;
+    int found = 0;
+    *index = 0;
+    /*
+     * If the graphics engine font family is ""
+     * just use the default font that was loaded when the device
+     * was created.
+     * This will (MUST) be the first font in the device
+     */
+    if (strlen(name) > 0) {
+	while (fontlist && !found) {
+	    found = !strcmp(name, fontlist->family->name);
+	    if (found)
+		font = fontlist->family;
+	    fontlist = fontlist->next;
+	    *index = *index + 1;
+	}
+    } else {
+	font = fontlist->family;
+	*index = 1;
+    }
+    return font;
+}
+/*
+ * Get the path to the afm file for a user-specifed font
+ * given a graphics engine font family and the face
+ * index (0..4)
+ *
+ * Do this by looking up the font name in the PostScript
+ * font database
+ */
+static char* fontMetricsFileName(char *family, int faceIndex)
+{
+    SEXP graphicsNS, PSenv, fontdb, fontnames;
+    int i, nfonts;
+    char* result = NULL;
+    int found = 0;
+    PROTECT(graphicsNS = R_FindNamespace(ScalarString(mkChar("grDevices"))));
+    PROTECT(PSenv = findVar(install(".PSenv"), graphicsNS));
+    /* under lazy loading this will be a promise on first use */
+    if(TYPEOF(PSenv) == PROMSXP) {
+	PROTECT(PSenv);
+	PSenv = eval(PSenv, graphicsNS);
+	UNPROTECT(1);
+    }
+    PROTECT(fontdb = findVar(install(".PostScript.Fonts"), PSenv));
+    PROTECT(fontnames = getAttrib(fontdb, R_NamesSymbol));
+    nfonts = LENGTH(fontdb);
+    for (i=0; i<nfonts && !found; i++) {
+	char* fontFamily = CHAR(STRING_ELT(fontnames, i));
-    if(strcmp(familyname[4], "CMSY10 CMBSY10 CMMI10") == 0) {
+	if (strcmp(family, fontFamily) == 0) {
+	    found = 1;
+	    result = CHAR(STRING_ELT(VECTOR_ELT(VECTOR_ELT(fontdb, i), 1),
+				     faceIndex));
+	}
+    }
+    if (!found)
+	warning("Font family not found in PostScript font database");
+    UNPROTECT(4);
+    return result;
+}
+static char WinAnsiEnc[] = "WinAnsi.enc";
+static char ISOLatin1Enc[] = "ISOLatin1.enc";
+/*
+ * Get encoding name from font database
+ */
+static char* getFontEncoding(char *family) {
+    SEXP graphicsNS, PSenv, fontdb, fontnames;
+    int i, nfonts;
+    char* result = NULL;
+    int found = 0;
+    PROTECT(graphicsNS = R_FindNamespace(ScalarString(mkChar("grDevices"))));
+    PROTECT(PSenv = findVar(install(".PSenv"), graphicsNS));
+    /* under lazy loading this will be a promise on first use */
+    if(TYPEOF(PSenv) == PROMSXP) {
+	PROTECT(PSenv);
+	PSenv = eval(PSenv, graphicsNS);
+	UNPROTECT(1);
+    }
+    PROTECT(fontdb = findVar(install(".PostScript.Fonts"), PSenv));
+    PROTECT(fontnames = getAttrib(fontdb, R_NamesSymbol));
+    nfonts = LENGTH(fontdb);
+    for (i=0; i<nfonts && !found; i++) {
+	char* fontFamily = CHAR(STRING_ELT(fontnames, i));
+	if (strcmp(family, fontFamily) == 0) {
+	    found = 1;
+	    result = CHAR(STRING_ELT(VECTOR_ELT(VECTOR_ELT(fontdb, i), 2), 0));
+	}
+    }
+    if (!found)
+	warning("Font encoding not found in PostScript font database");
+    else {
+	/*
+	 * Convert "default" to "WinAnsi.enc" on Windows
+	 * and "ISOLatin1.enc" elsewhere
+	 *
+	 * Equivalent of following code in postscript.R;
+	 *
+	 * old$encoding <- switch(.Platform$OS.type,
+         *                        "windows" = "WinAnsi.enc",
+         *                        "ISOLatin1.enc")
+	 */
+	if (!strcmp(result, "default")) {
+	    SEXP platform, platformNames, OStype;
+	    PROTECT(platform = findVar(install(".Platform"), R_GlobalEnv));
+	    PROTECT(platformNames = getAttrib(platform, R_NamesSymbol));
+	    if (strcmp(CHAR(STRING_ELT(platformNames, 0)), "OS.type"))
+		error(".Platform has changed and nobody told postscript");
+	    PROTECT(OStype = VECTOR_ELT(platform, 0));
+	    if (!strcmp(CHAR(STRING_ELT(OStype, 0)), "windows"))
+		result = WinAnsiEnc;
+	    else
+		result = ISOLatin1Enc;
+	    UNPROTECT(3);
+	}
+    }
+    UNPROTECT(4);
+    return result;
+}
+/*
+ * Add a graphics engine font family/encoding to the list of loaded fonts ...
+ *
+ * ... and return the new font
+ */
+static type1fontfamily addLoadedFont(type1fontfamily font)
+{
+    type1fontlist newfont = makeFontList();
+    if (!newfont) {
+	freeFontFamily(font);
+	font = NULL;
+    } else {
+	type1fontlist fontlist = loadedFonts;
+	newfont->family = font;
+	if (!loadedFonts)
+	    loadedFonts = newfont;
+	else {
+	    while (fontlist->next)
+		fontlist = fontlist->next;
+	    fontlist->next = newfont;
+	}
+    }
+    return font;
+}
+/*
+ * Add a font from a graphics engine font family name
+ */
+static type1fontfamily addFont(char *name, Rboolean isPDF)
+{
+    type1fontfamily fontfamily = makeFontFamily();
+    if (fontfamily) {
+	int i;
+	encodinginfo encoding;
+	char *encpath = getFontEncoding(name);
+	if (!encpath) {
+	    freeFontFamily(fontfamily);
+	    fontfamily = NULL;
+	} else {
+	    /*
+	     * Set the name of the font
+	     */
+	    safestrcpy(fontfamily->name, name, 50);
+	    /*
+	     * Find or add encoding
+	     */
+	    if (!(encoding = findEncoding(encpath)))
+		encoding = addEncoding(encpath, isPDF);
+	    if (!encoding) {
+		freeFontFamily(fontfamily);
+		fontfamily = NULL;
+	    } else {
+		/*
+		 * Load font info
+		 */
+		fontfamily->encoding = encoding;
+		for(i = 0; i < 5 ; i++) {
+		    type1fontinfo font = makeType1Font();
+		    char *afmpath = fontMetricsFileName(name, i);
+		    if (!font) {
+			freeFontFamily(fontfamily);
+			fontfamily = NULL;
+			break;
+		    }
+		    if (!afmpath) {
+			freeFontFamily(fontfamily);
+			fontfamily = NULL;
+			break;
+		    }
+		    fontfamily->fonts[i] = font;
+		    if (!PostScriptLoadFontMetrics(afmpath,
+						   &(fontfamily->fonts[i]->metrics),
+						   fontfamily->fonts[i]->name,
+						   fontfamily->fonts[i]->charnames,
+						   /*
+						    * Reencode all but
+						    * symbol face
+						    */
+						   encoding->encnames,
+						   (i < 4)?1:0)) {
+			warning("cannot read afm file %s", afmpath);
+			freeFontFamily(fontfamily);
+			fontfamily = NULL;
+			break;
+		    }
+		}
+		/*
+		 * Add font
+		 */
+		if (fontfamily)
+		    fontfamily = addLoadedFont(fontfamily);
+	    }
+	}
+    } else
+	fontfamily = NULL;
+    return fontfamily;
+}
+/*
+ * Add a default font family/encoding to the list of loaded fonts ...
+ *
+ * ... using a set of AFM paths ...
+ *
+ * ... and return the new font
+ */
+static type1fontfamily addDefaultFontFromAFMs(char *encpath, char **afmpaths,
+					      Rboolean isPDF)
+{
+    encodinginfo encoding;
+    type1fontfamily fontfamily = makeFontFamily();
+    if (fontfamily) {
+	int i;
+	if (!(encoding = findEncoding(encpath)))
+	    encoding = addEncoding(encpath, isPDF);
+	if (!encoding) {
+	    freeFontFamily(fontfamily);
+	    fontfamily = NULL;
+	} else {
+	    /*
+	     * This is the device default font, so set the
+	     * graphics engine font family name to ""
+	     */
+	    fontfamily->name[0] ='\0';
+	    /*
+	     * Load font info
+	     */
+	    fontfamily->encoding = encoding;
+	    for(i = 0; i < 5 ; i++) {
+		type1fontinfo font = makeType1Font();
+		if (!font) {
+		    freeFontFamily(fontfamily);
+		    fontfamily = NULL;
+		    break;
+		}
+		fontfamily->fonts[i] = font;
+		if (!PostScriptLoadFontMetrics(afmpaths[i],
+					       &(fontfamily->fonts[i]->metrics),
+					       fontfamily->fonts[i]->name,
+					       fontfamily->fonts[i]->charnames,
+					       /*
+						* Reencode all but
+						* symbol face
+						*/
+					       encoding->encnames,
+					       (i < 4)?1:0)) {
+		    warning("cannot read afm file %s", afmpaths[i]);
+		    freeFontFamily(fontfamily);
+		    fontfamily = NULL;
+		    break;
+		}
+	    }
+	    /*
+	     * Add font
+	     */
+	    if (fontfamily)
+		fontfamily = addLoadedFont(fontfamily);
+	}
+    } else
+	fontfamily = NULL;
+    return fontfamily;
+}
+/*
+ * Add a default font family/encoding to the list of loaded fonts ...
+ *
+ * ... using an index into the internal list of Type 1 font families ...
+ *
+ * ... and return the new font
+ */
+static type1fontfamily addDefaultFontFromFamily(char *encpath, int family,
+				      Rboolean isPDF)
+{
+    encodinginfo encoding;
+    type1fontfamily fontfamily = makeFontFamily();
+    if (fontfamily) {
+	int i;
+	if (!(encoding = findEncoding(encpath)))
+	    encoding = addEncoding(encpath, isPDF);
+	if (!encoding) {
+	    freeFontFamily(fontfamily);
+	    fontfamily = NULL;
+	} else {
+	    /*
+	     * This is the device default font, so set the
+	     * graphics engine font family name to ""
+	     */
+	    fontfamily->name[0] ='\0';
+	    /*
+	     * Load font info
+	     */
+	    fontfamily->encoding = encoding;
+	    for(i = 0; i < 5 ; i++) {
+		type1fontinfo font = makeType1Font();
+		if (!font) {
+		    freeFontFamily(fontfamily);
+		    fontfamily = NULL;
+		    break;
+		}
+		fontfamily->fonts[i] = font;
+		if (!PostScriptLoadFontMetrics(Family[family].afmfile[i],
+					       &(fontfamily->fonts[i]->metrics),
+					       fontfamily->fonts[i]->name,
+					       fontfamily->fonts[i]->charnames,
+					       /*
+						* Reencode all but
+						* symbol face
+						*/
+					       encoding->encnames,
+					       (i < 4)?1:0)) {
+		    warning("cannot read afm file %s",
+			    Family[family].afmfile[i]);
+		    freeFontFamily(fontfamily);
+		    fontfamily = NULL;
+		    break;
+		}
+	    }
+	    /*
+	     * Add font
+	     */
+	    if (fontfamily)
+		fontfamily = addLoadedFont(fontfamily);
+	}
+    } else
+	fontfamily = NULL;
+    return fontfamily;
+}
+/*
+ * Add a graphics engine font family/encoding to a list of device fonts ...
+ *
+ * ... and return the new font list
+ */
+static type1fontlist addDeviceFont(type1fontfamily font,
+				   type1fontlist devFonts,
+				   int *index)
+{
+    type1fontlist newfont = makeFontList();
+    *index = 0;
+    if (!newfont) {
+	devFonts = NULL;
+    } else {
+	type1fontlist fontlist = devFonts;
+	newfont->family = font;
+	*index = 1;
+	if (!devFonts) {
+	    devFonts = newfont;
+	} else {
+	    while (fontlist->next) {
+		fontlist = fontlist->next;
+		*index = *index + 1;
+	    }
+	    fontlist->next = newfont;
+	}
+    }
+    return devFonts;
+}
+/*
+***********************************************************
+*/
+/* Part 2.  Device Driver State. */
+typedef struct {
+    char filename[PATH_MAX];
+    int open_type;
+    char papername[64];	/* paper name */
+    int paperwidth;	/* paper width in big points (1/72 in) */
+    int paperheight;	/* paper height in big points */
+    Rboolean landscape;	/* landscape mode */
+    int pageno;		/* page number */
+    int maxpointsize;
+    double width;	/* plot width in inches */
+    double height;	/* plot height in inches */
+    double pagewidth;	/* page width in inches */
+    double pageheight;	/* page height in inches */
+    Rboolean pagecentre;/* centre image on page? */
+    Rboolean printit;	/* print page at close? */
+    char command[PATH_MAX];
+    char title[1024];
+    FILE *psfp;		/* output file */
+    Rboolean onefile;	/* EPSF header etc*/
+    Rboolean paperspecial;	/* suppress %%Orientation */
+    /* This group of variables track the current device status.
+     * They should only be set by routines that emit PostScript code. */
+    struct {
+	double lwd;		 /* line width */
+	int lty;		 /* line type */
+	int font;
+	int fontstyle;	         /* font style, R, B, I, BI, S */
-	/* use different ps fragment for CM fonts */
+	int fontsize;	         /* font size in points */
+	rcolor col;		 /* color */
+	rcolor fill;	         /* fill color */
+    } current;
+    /*
+     * Fonts and encodings used on the device
+     */
+    type1fontlist fonts;
+    encodinglist encodings;
+}
+PostScriptDesc;
+/*  Part 3.  Graphics Support Code.  */
+static const char * const TypeFaceDef[] = { "R", "B", "I", "BI", "S" };
+static void specialCaseCM(FILE *fp, type1fontfamily family)
+{
 	fprintf(fp, "%% begin encoding\n");
 	fprintf(fp, "/SymbolEncoding [\n");
 	fprintf(fp, " /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef\n");
 	fprintf(fp, " /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef\n");
 	fprintf(fp, " /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef\n");
 	fprintf(fp, "  end\n");
 	fprintf(fp, "} def\n");
 	fprintf(fp, "%%%%IncludeResource: font CMR10\n");
 	fprintf(fp, "%%%%IncludeResource: font CMSY10\n");
 	fprintf(fp, "[ /%s findfont /CMSY10 findfont ] %s mergefonts\n",
-		familyname[0], encname);
+		family->fonts[0]->name, family->encoding->name);
 	fprintf(fp, "/Font1 exch definefont pop\n");
 	fprintf(fp, "%%%%IncludeResource: font CMBX10\n");
 	fprintf(fp, "%%%%IncludeResource: font CMBSY10\n");
 	fprintf(fp, "[ /%s findfont /CMBSY10 findfont ] %s mergefonts\n",
-		familyname[1], encname);
+		family->fonts[1]->name, family->encoding->name);
 	fprintf(fp, "/Font2 exch definefont pop\n");
 	fprintf(fp, "%%%%IncludeResource: font CMSL10\n");
 	fprintf(fp, "[ /%s findfont /CMSY10 findfont ] %s mergefonts\n",
-		familyname[2], encname);
+		family->fonts[2]->name, family->encoding->name);
 	fprintf(fp, "/Font3 exch definefont pop\n");
 	fprintf(fp, "%%%%IncludeResource: font CMBXSL10\n");
 	fprintf(fp, "[ /%s findfont /CMBSY10 findfont ] %s mergefonts\n",
-		familyname[3], encname);
+		family->fonts[3]->name, family->encoding->name);
 	fprintf(fp, "/Font4 exch definefont pop\n");
 	fprintf(fp, "%%%%IncludeResource: font CMMI10\n");
 	fprintf(fp, "[ /CMR10 findfont /CMSY10 findfont /CMMI10 findfont ] SymbolEncoding mergefonts\n");
 	fprintf(fp, "/Font5 exch definefont pop\n");
+}
+static void PSEncodeFonts(FILE *fp, PostScriptDesc *pd)
+{
+    type1fontlist fonts = pd->fonts;
+    int familynum = 1;
+    while (fonts) {
+	int dontcare;
+	/*
+	 * Has the encoding already been used on the device?
+	 */
+	encodinginfo encoding =
+	    findDeviceEncoding(fonts->family->encoding->encpath,
+			       pd->encodings, &dontcare);
+	if (!encoding) {
+	    /*
+	     * The encoding should have been loaded when the font was loaded
+	     */
+	    encoding = findEncoding(fonts->family->encoding->encpath);
+	    if (!encoding)
+		warning("Corrupt loaded encodings;  encoding not recorded");
-    } else {
+	    else {
+		/*
+		 * Record encoding on device's list of encodings so
+		 * don't write same encoding more than once
+		 */
+		encodinglist enclist = addDeviceEncoding(encoding,
+							 pd->encodings);
+		if (enclist)
+		    pd->encodings = enclist;
+		else
+		    warning("Failed to record device encoding");
+	    }
+	    /*
+	     * Include encoding unless it is ISOLatin1Encoding,
+	     * which is predefined
+	     */
+	    if (strcmp(fonts->family->encoding->name, "ISOLatin1Encoding"))
+		fprintf(fp, "%% begin encoding\n%s def\n%% end encoding\n",
+			fonts->family->encoding->enccode);
+	}
+	if(strcmp(fonts->family->fonts[4]->name,
+		  "CMSY10 CMBSY10 CMMI10") == 0) {
+	    /* use different ps fragment for CM fonts */
+	    specialCaseCM(fp, fonts->family);
+	} else {
+	    int i;
-  	for (i = 0; i < 4 ; i++) {
+	    for (i = 0; i < 4 ; i++) {
+		fprintf(fp, "%%%%IncludeResource: font %s\n",
+			fonts->family->fonts[i]->name);
+		fprintf(fp, "/%s findfont\n",
+			fonts->family->fonts[i]->name);
+		fprintf(fp, "dup length dict begin\n");
+		fprintf(fp, "  {1 index /FID ne {def} {pop pop} ifelse} forall\n");
+		fprintf(fp, "  /Encoding %s def\n",
+			fonts->family->encoding->name);
+		fprintf(fp, "  currentdict\n");
+		fprintf(fp, "  end\n");
+		fprintf(fp, "/Font%d exch definefont pop\n",
+			(familynum - 1)*5 + i + 1);
+	    }
-	    fprintf(fp, "%%%%IncludeResource: font %s\n", familyname[i]);
+	    fprintf(fp, "%%%%IncludeResource: font %s\n",
+		    fonts->family->fonts[4]->name);
-	    fprintf(fp, "/%s findfont\n", familyname[i]);
+	    fprintf(fp, "/%s findfont\n",
+		    fonts->family->fonts[4]->name);
 	    fprintf(fp, "dup length dict begin\n");
 	    fprintf(fp, "  {1 index /FID ne {def} {pop pop} ifelse} forall\n");
-	    fprintf(fp, "  /Encoding %s def\n", encname);
 	    fprintf(fp, "  currentdict\n");
 	    fprintf(fp, "  end\n");
-	    fprintf(fp, "/Font%d exch definefont pop\n", i + 1);
+	    fprintf(fp, "/Font%d exch definefont pop\n",
+		    (familynum - 1)*5 + 5);
+	}
-   	}
-	fprintf(fp, "%%%%IncludeResource: font %s\n", familyname[4]);
-   	fprintf(fp, "/%s findfont\n", familyname[4]);
-   	fprintf(fp, "dup length dict begin\n");
-   	fprintf(fp, "  {1 index /FID ne {def} {pop pop} ifelse} forall\n");
-   	fprintf(fp, "  currentdict\n");
+	familynum++;
-   	fprintf(fp, "  end\n");
+	fonts = fonts->next;
-   	fprintf(fp, "/Font5 exch definefont pop\n");
+    }
+}
 /* The variables "paperwidth" and "paperheight" give the dimensions */
 /* of the (unrotated) printer page in points whereas the graphics */
 /* region box is for the rotated page. */
-static void PSFileHeader(FILE *fp, char* encname,
+static void PSFileHeader(FILE *fp,
 			 char *papername, double paperwidth,
 			 double paperheight, Rboolean landscape,
 			 int EPSFheader, Rboolean paperspecial,
 			 double left, double bottom, double right, double top,
-			 char *title)
+			 char *title,
+			 PostScriptDesc *pd)
+{
     int i;
     SEXP prolog;
+    type1fontlist fonts = pd->fonts;
+    int firstfont = 1;
     if(EPSFheader)
 	fprintf(fp, "%%!PS-Adobe-3.0 EPSF-3.0\n");
     else
 	fprintf(fp, "%%!PS-Adobe-3.0\n");
+    /*
-    fprintf(fp, "%%%%DocumentNeededResources: font %s\n", familyname[0]);
+     * DocumentNeededResources names all fonts
+     */
+    while (fonts) {
-    for (i = 1; i < 5; i++)
+	for (i=0; i<5; i++)
+	    if (firstfont) {
+		fprintf(fp, "%%%%DocumentNeededResources: font %s\n",
+			fonts->family->fonts[0]->name);
+		firstfont = 0;
+	    } else
-	fprintf(fp, "%%%%+ font %s\n", familyname[i]);
+	fprintf(fp, "%%%%+ font %s\n", fonts->family->fonts[i]->name);
+	fonts = fonts->next;
+    }
     if(!EPSFheader)
 	fprintf(fp, "%%%%DocumentMedia: %s %.0f %.0f 0 () ()\n",
 		papername, paperwidth, paperheight);
     fprintf(fp, "%%%%Title: %s\n", title);
     else
 	fprintf(fp, "/bp  { gs gs } def\n");
     prolog = findVar(install(".ps.prolog"), R_GlobalEnv);
     if(prolog == R_UnboundValue) {
 	/* if no object is visible, look in the graphics namespace */
-	SEXP graphicsNS = R_FindNamespace(ScalarString(mkChar("graphics")));
+	SEXP graphicsNS = R_FindNamespace(ScalarString(mkChar("grDevices")));
 	prolog = findVar(install(".ps.prolog"), graphicsNS);
+	/* under lazy loading this will be a promise on first use */
+	if(TYPEOF(prolog) == PROMSXP) {
+	    PROTECT(prolog);
+	    prolog = eval(prolog, graphicsNS);
+	    UNPROTECT(1);
+	}
+    }
     if(!isString(prolog))
 	error("Object .ps.prolog is not a character vector");
     fprintf(fp, "%% begin .ps.prolog\n");
     for (i = 0; i < length(prolog); i++)
 	fprintf(fp, "%s\n", CHAR(STRING_ELT(prolog, i)));
     fprintf(fp, "%% end   .ps.prolog\n");
-    PSEncodeFont(fp, encname);
+    PSEncodeFonts(fp, pd);
     fprintf(fp, "%%%%EndProlog\n");
+}
 static void PostScriptFileTrailer(FILE *fp, int pageno)
+{
 static void PostScriptSetLineWidth(FILE *fp, double linewidth)
+{
     fprintf(fp, "%.2f setlinewidth\n", linewidth);
+}
-static void PostScriptSetFont(FILE *fp, int typeface, double size)
+static void PostScriptSetFont(FILE *fp, int fontnum, double size)
+{
-    fprintf(fp, "/ps %.0f def %s %.0f s\n", size, TypeFaceDef[typeface], size);
+    fprintf(fp, "/ps %.0f def /Font%d findfont %.0f s\n", size, fontnum, size);
+}
 static void
 PostScriptSetLineTexture(FILE *fp, char *dashlist, int nlty, double lwd)
+{
     fprintf(fp, " t\n");
+}
-/* Part 3.  Device Driver State. */
-typedef struct {
-    char filename[PATH_MAX];
-    int open_type;
-    char papername[64];	/* paper name */
-    int paperwidth;	/* paper width in big points (1/72 in) */
-    int paperheight;	/* paper height in big points */
-    Rboolean landscape;	/* landscape mode */
-    int pageno;		/* page number */
-    int fontfamily;	/* font family */
-    char encpath[PATH_MAX]; /* font encoding file */
-    char encname[100]; /* font encoding */
-    char **afmpaths;	/* for user-specified family */
-    int maxpointsize;
-    double width;	/* plot width in inches */
-    double height;	/* plot height in inches */
-    double pagewidth;	/* page width in inches */
-    double pageheight;	/* page height in inches */
-    Rboolean pagecentre;/* centre image on page? */
-    Rboolean printit;	/* print page at close? */
-    char command[PATH_MAX];
-    char title[1024];
-    FILE *psfp;		/* output file */
-    Rboolean onefile;	/* EPSF header etc*/
-    Rboolean paperspecial;	/* suppress %%Orientation */
-    /* This group of variables track the current device status.
-     * They should only be set by routines that emit PostScript code. */
-    struct {
-	double lwd;		 /* line width */
-	int lty;		 /* line type */
-	int fontstyle;	         /* font style, R, B, I, BI, S */
-	int fontsize;	         /* font size in points */
-	rcolor col;		 /* color */
-	rcolor fill;	         /* fill color */
-    } current;
-    FontMetricInfo metrics[5];	/* font metrics */
-}
-PostScriptDesc;
 /* Device Driver Actions */
 static void PS_Activate(NewDevDesc *dd);
 static void PS_Circle(double x, double y, double r,
 		      R_GE_gcontext *gc,
 static void SetFont(int, int, NewDevDesc*);
 static void SetLineStyle(int newlty, double newlwd, NewDevDesc *dd);
 static void Invalidate(NewDevDesc*);
 static int  MatchFamily(char *name);
 static Rboolean
 innerPSDeviceDriver(NewDevDesc *dd, char *file, char *paper, char *family,
 		    char **afmpaths, char *encoding,
 		    char *bg, char *fg,
 		    double width, double height,
 		    Rboolean horizontal, double ps,
 		    Rboolean onefile, Rboolean pagecentre,
-		    Rboolean printit, char *cmd, char *title)
+		    Rboolean printit, char *cmd, char *title,
+		    SEXP fonts)
+{
     /* If we need to bail out with some sort of "error"
        then we must free(dd) */
     double xoff, yoff, pointsize;
     rcolor setbg, setfg;
+    type1fontfamily font;
+    int gotFont;
     PostScriptDesc *pd;
     /* Check and extract the device parameters */
     /* initialise postscript device description */
     strcpy(pd->filename, file);
     strcpy(pd->papername, paper);
     strncpy(pd->title, title, 1024);
-    pd->fontfamily = strcmp(family, "User") ? MatchFamily(family) : USERAFM;
     if(strlen(encoding) > PATH_MAX - 1) {
 	free(dd);
 	free(pd);
 	error("encoding path is too long");
+    }
-    strcpy(pd->encpath, encoding);
-    pd->afmpaths = afmpaths;
+    pd->encodings = NULL;
+    pd->fonts = NULL;
+    gotFont = 0;
+    /*
+     * If user specified afms then assume the font hasn't been loaded
+     * Could lead to redundant extra loading of a font, but not often(?)
+     */
+    if (!strcmp(family, "User")) {
+	font = addDefaultFontFromAFMs(encoding, afmpaths, 0);
+    } else {
+	if (!(font = findDefaultLoadedFont(encoding, family, 0))) {
+	    font = addDefaultFontFromFamily(encoding, MatchFamily(family), 0);
+	}
+    }
+    if (font)
+	pd->fonts = addDeviceFont(font, pd->fonts, &gotFont);
+    if (!gotFont) {
+	free(dd);
+	free(pd);
+	error("Failed to initialise default PostScript font");
+    }
+    /*
+     * Load the font names sent in via the fonts arg
+     * NOTE that these are the font names specified at the
+     * R-level, NOT the translated font names.
+     */
+    if (!isNull(fonts)) {
+	int i, dontcare, gotFonts = 0, nfonts = LENGTH(fonts);
+	type1fontlist fontlist;
+	for (i=0; i<nfonts; i++) {
+	    int index;
+	    char *name = CHAR(STRING_ELT(fonts, i));
+	    if (findDeviceFont(name, pd->fonts, &index))
+		gotFonts++;
+	    else {
+		if (!(font = findLoadedFont(name)))
+		    font = addFont(name, 0);
+		if (font)
+		    if ((fontlist = addDeviceFont(font, pd->fonts,
+						  &dontcare))) {
+			pd->fonts = fontlist;
+			gotFonts++;
+		    }
+	    }
+	}
+	if (gotFonts < nfonts) {
+	    freeDeviceFontList(pd->fonts);
+	    pd->fonts = NULL;
+	    free(dd);
+	    free(pd);
+	    error("Failed to initialise additional PostScript fonts");
+	}
+    }
     setbg = str2col(bg);
     setfg = str2col(fg);
     pd->width = width;
     pd->height = height;
     pd->landscape = horizontal;
     pointsize = floor(ps);
     if(setbg == NA_INTEGER && setfg == NA_INTEGER) {
+	freeDeviceFontList(pd->fonts);
+	pd->fonts = NULL;
 	free(dd);
 	free(pd);
 	error("invalid foreground/background color (postscript)");
+    }
     pd->printit = printit;
     if(strlen(cmd) > PATH_MAX - 1) {
+	freeDeviceFontList(pd->fonts);
+	pd->fonts = NULL;
 	free(dd);
 	free(pd);
 	error("`command' is too long");
+    }
     strcpy(pd->command, cmd);
 	    pd->pageheight = height;
+	}
 	pd->paperspecial = TRUE;
+    }
     else {
+	freeDeviceFontList(pd->fonts);
+	pd->fonts = NULL;
 	free(dd);
 	free(pd);
 	error("invalid page type `%s' (postscript)", pd->papername);
+    }
     pd->pagecentre = pagecentre;
     /*	Start the driver */
     pd->pageno = 0;
     if(!PS_Open(dd, pd)) {
+	freeDeviceFontList(pd->fonts);
+	freeDeviceEncList(pd->encodings);
+	pd->fonts = NULL;
+	pd->encodings = NULL;
+	free(dd);
 	free(pd);
 	return FALSE;
+    }
     dd->newDevStruct = 1;
 	       char **afmpaths, char *encoding,
 	       char *bg, char *fg,
 	       double width, double height,
 	       Rboolean horizontal, double ps,
 	       Rboolean onefile, Rboolean pagecentre,
-	       Rboolean printit, char *cmd, char *title)
+	       Rboolean printit, char *cmd, char *title,
+	       SEXP fonts)
+{
     return innerPSDeviceDriver((NewDevDesc*) dd, file, paper, family,
 			       afmpaths, encoding, bg, fg, width, height,
 			       horizontal, ps, onefile, pagecentre,
-			       printit, cmd, title);
+			       printit, cmd, title, fonts);
+}
 static int MatchFamily(char *name)
+{
     int i;
+	}
 	PostScriptSetLineTexture(pd->psfp, dashlist, i, newlwd * 0.75);
+    }
+}
-static void SetFont(int style, int size, NewDevDesc *dd)
+static void SetFont(int font, int size, NewDevDesc *dd)
+{
     PostScriptDesc *pd = (PostScriptDesc *) dd->deviceSpecific;
-    if(style < 1 || style > 5) {
-	warning("attempt to use invalid font %d replaced by font 1", style);
-	style = 1;
-    }
     if(size < 1 || size > pd->maxpointsize)
 	size = 10;
-    if(size != pd->current.fontsize || style != pd->current.fontstyle) {
+    if (size != pd->current.fontsize || font != pd->current.font) {
-	PostScriptSetFont(pd->psfp, style-1, size);
+	PostScriptSetFont(pd->psfp, font, size);
 	pd->current.fontsize = size;
-	pd->current.fontstyle = style;
+	pd->current.font = font;
+    }
+}
 #ifdef Win32
 /* exists, but does not work on GUI processes */
 #endif
 static Rboolean PS_Open(NewDevDesc *dd, PostScriptDesc *pd)
+{
     char buf[512];
-    int i;
-    if (!LoadEncoding(pd->encpath, pd->encname, FALSE)) {
-	warning("problem loading encoding file");
-	return FALSE;
-    }
-    for(i = 0; i < 5 ; i++) {
-        char const *p;
-	if(pd->fontfamily == USERAFM) p = pd->afmpaths[i];
-	else p = Family[pd->fontfamily].afmfile[i];
-	if(!PostScriptLoadFontMetrics(p, &(pd->metrics[i]),
-				      familyname[i], (i < 4)?1:0)) {
-	    warning("cannot read afm file %s", p);
-	    return FALSE;
-	}
-    }
     if (strlen(pd->filename) == 0) {
 #ifndef HAVE_POPEN
 	warning("printing via file = \"\" is not implemented in this version");
 	return FALSE;
 	return FALSE;
+    }
     if(pd->landscape)
 	PSFileHeader(pd->psfp,
-		     pd->encname,
 		     pd->papername,
 		     pd->paperwidth,
 		     pd->paperheight,
 		     pd->landscape,
 		     !(pd->onefile),
 		     pd->paperspecial,
 		     dd->bottom,
 		     dd->left,
 		     dd->top,
 		     dd->right,
-		     pd->title);
+		     pd->title,
+		     pd);
     else
 	PSFileHeader(pd->psfp,
-		     pd->encname,
 		     pd->papername,
 		     pd->paperwidth,
 		     pd->paperheight,
 		     pd->landscape,
 		     !(pd->onefile),
 		     pd->paperspecial,
 		     dd->left,
 		     dd->bottom,
 		     dd->right,
 		     dd->top,
-		     pd->title);
+		     pd->title,
+		     pd);
     return TRUE;
+}
 /* The driver keeps track of the current values of colors, fonts and
 static void Invalidate(NewDevDesc *dd)
+{
     PostScriptDesc *pd = (PostScriptDesc *) dd->deviceSpecific;
+    pd->current.font = -1;
     pd->current.fontsize = -1;
     pd->current.fontstyle = -1;
     pd->current.lwd = -1;
     pd->current.lty = -1;
     pd->current.col = INVALID_COL;
 static void PS_Close(NewDevDesc *dd)
+{
     PostScriptDesc *pd = (PostScriptDesc *) dd->deviceSpecific;
     PostScriptClose(dd);
+    freeDeviceFontList(pd->fonts);
+    freeDeviceEncList(pd->encodings);
+    pd->fonts = NULL;
+    pd->encodings = NULL;
     free(pd);
+}
 static void PS_Activate(NewDevDesc *dd) {}
 static void PS_Deactivate(NewDevDesc *dd) {}
+static FontMetricInfo *metricInfo(char *family, int face,
+				  PostScriptDesc *pd) {
+    FontMetricInfo *result = NULL;
+    int fontIndex;
+    type1fontfamily fontfamily = findDeviceFont(family, pd->fonts, &fontIndex);
+    if (fontfamily) {
+	result = &(fontfamily->fonts[face-1]->metrics);
+    } else {
+	error("family %s not included in PostScript device", family);
+    }
+    return result;
+}
 static double PS_StrWidth(char *str,
 			  R_GE_gcontext *gc,
 			  NewDevDesc *dd)
+{
     PostScriptDesc *pd = (PostScriptDesc *) dd->deviceSpecific;
     int face = gc->fontface;
     if(face < 1 || face > 5) face = 1;
     return floor(gc->cex * gc->ps + 0.5) *
 	PostScriptStringWidth((unsigned char *)str,
-			      &(pd->metrics[face-1]));
+			      metricInfo(gc->fontfamily, face, pd));
+}
 static void PS_MetricInfo(int c,
 			  R_GE_gcontext *gc,
 			  double* ascent, double* descent,
     int face = gc->fontface;
     if(face < 1 || face > 5) face = 1;
     PostScriptMetricInfo(c, ascent, descent, width,
-			 &(pd->metrics[face-1]));
+			 metricInfo(gc->fontfamily, face, pd));
     *ascent = floor(gc->cex * gc->ps + 0.5) * *ascent;
     *descent = floor(gc->cex * gc->ps + 0.5) * *descent;
     *width = floor(gc->cex * gc->ps + 0.5) * *width;
+}
+	}
 	fprintf(pd->psfp, "o\n");
+    }
+}
+static int translateFont(char* family, int style, PostScriptDesc *pd)
+{
+    int result = style;
+    type1fontfamily fontfamily;
+    int fontIndex;
+    if(style < 1 || style > 5) {
+	warning("attempt to use invalid font %d replaced by font 1", style);
+	style = 1;
+    }
+    fontfamily = findDeviceFont(family, pd->fonts, &fontIndex);
+    if (fontfamily) {
+	result = (fontIndex - 1)*5 + style;
+    } else {
+	warning("family %s not included in PostScript device", family);
+    }
+    return result;
+}
 static void PS_Text(double x, double y, char *str,
 		    double rot, double hadj,
 		    R_GE_gcontext *gc,
 		    NewDevDesc *dd)
+{
     PostScriptDesc *pd = (PostScriptDesc *) dd->deviceSpecific;
+    SetFont(translateFont(gc->fontfamily, gc->fontface, pd),
-    SetFont(gc->fontface, (int)floor(gc->cex * gc->ps + 0.5), dd);
+	    (int)floor(gc->cex * gc->ps + 0.5),dd);
     if(R_ALPHA(gc->col) == 0) {
 	SetColor(gc->col, dd);
 	PostScriptText(pd->psfp, x, y, str, hadj, 0.0, rot);
+    }
+}
     int paperwidth;	 /* paper width in big points (1/72 in) */
     int paperheight;	 /* paper height in big points */
     Rboolean landscape;	 /* landscape mode */
     int pageno;		 /* page number */
-    int fontfamily;	 /* font family */
     int fontnum;	 /* font number in XFig */
-    int fontstyle;	 /* font style, R, B, I, BI, S */
-    int fontsize;	 /* font size in points */
     int maxpointsize;
     double width;	 /* plot width in inches */
     double height;	 /* plot height in inches */
     double pagewidth;	 /* page width in inches */
     char tmpname[PATH_MAX];
     Rboolean onefile;
     int ymax;            /* used to invert coord system */
+    /*
-    FontMetricInfo metrics[5];	/* font metrics */
+     * Fonts and encodings used on the device
+     *
+     * ASSUME ONLY ONE (DEFAULT) FOR NOW
+     */
+    type1fontlist fonts;
+    encodinglist encodings;
 } XFigDesc;
 static void
 XF_FileHeader(FILE *fp, char *papername, Rboolean landscape, Rboolean onefile)
+{
 		      Rboolean onefile, Rboolean pagecentre)
+{
     /* If we need to bail out with some sort of "error" */
     /* then we must free(dd) */
+    int gotFont;
     double xoff, yoff, pointsize;
     XFigDesc *pd;
+    type1fontfamily font;
     /* Check and extract the device parameters */
     if(strlen(file) > PATH_MAX - 1) {
 	free(dd);
     /* free(pd) */
     /* initialize xfig device description */
     strcpy(pd->filename, file);
     strcpy(pd->papername, paper);
-    pd->fontfamily = MatchFamily(family);
-    pd->fontnum = XFig_basenums[pd->fontfamily];
+    pd->fontnum = XFig_basenums[MatchFamily(family)];
     pd->bg = str2col(bg);
     pd->col = str2col(fg);
     pd->fill = NA_INTEGER;
     pd->width = width;
     pd->height = height;
 	free(dd);
 	free(pd);
 	error("invalid foreground/background color (xfig)");
+    }
+    pd->encodings = NULL;
+    pd->fonts = NULL;
+    gotFont = 0;
+    if (!(font = findDefaultLoadedFont("ISOLatin1.enc", family, 0))) {
+	font = addDefaultFontFromFamily("ISOLatin1.enc",
+					MatchFamily(family), 0);
+    }
+    if (font)
+	pd->fonts = addDeviceFont(font, pd->fonts, &gotFont);
+    if (!gotFont) {
+	free(dd);
+	free(pd);
+	error("Failed to initialise default PostScript font");
+    }
     /* Deal with paper and plot size and orientation */
     if(!strcmp(pd->papername, "Default") ||
        !strcmp(pd->papername, "default")) {
 	SEXP s = STRING_ELT(GetOption(install("papersize"), R_NilValue), 0);
 	strcpy(pd->papername, "Legal");
 	pd->pagewidth  =  8.5;
 	pd->pageheight = 14.0;
+    }
     else {
+	freeDeviceFontList(pd->fonts);
+	freeDeviceEncList(pd->encodings);
+	pd->fonts = NULL;
+	pd->encodings = NULL;
 	free(dd);
 	free(pd);
 	error("invalid page type `%s' (xfig)", pd->papername);
+    }
     pd->pagecentre = pagecentre;
     pd->nXFigColors = 32;
     /*	Start the driver */
     if(!XFig_Open(dd, pd)) {
+	freeDeviceFontList(pd->fonts);
+	freeDeviceEncList(pd->encodings);
+	pd->fonts = NULL;
+	pd->encodings = NULL;
+	free(dd);
 	free(pd);
 	return 0;
+    }
     dd->newDevStruct = 1;
 				 ps, onefile, pagecentre);
+}
 static Rboolean XFig_Open(NewDevDesc *dd, XFigDesc *pd)
+{
-    char buf[512], name[50];
+    char buf[512], *tmp;
-    int i;
-    if (!LoadEncoding("ISOLatin1.enc", buf, FALSE))
-	error("problem loading encoding file");
-    for(i = 0; i < 4 ; i++) {
-	if(!PostScriptLoadFontMetrics(Family[pd->fontfamily].afmfile[i],
-				      &(pd->metrics[i]), name, 1)) {
-	    warning("cannot read afm file %s",
-		    Family[pd->fontfamily].afmfile[i]);
-	    return FALSE;
-	}
-    }
-    if(!PostScriptLoadFontMetrics("sy______.afm",
-				  &(pd->metrics[4]), name, 0)) {
-	warning("cannot read afm file sy______.afm");
-	return FALSE;
-    }
     if (strlen(pd->filename) == 0) {
 	error("empty file name");
 	return FALSE;
     } else {
 	snprintf(buf, 512, pd->filename, pd->pageno + 1); /* page 1 to start */
 	pd->psfp = R_fopen(R_ExpandFileName(buf), "w");
+    }
     if (!pd->psfp) return FALSE;
     /* assume tmpname is less than PATH_MAX */
-    strcpy(pd->tmpname, R_tmpnam("Rxfig", R_TempDir));
+    tmp = R_tmpnam("Rxfig", R_TempDir);
+    strcpy(pd->tmpname, tmp);
+    free(tmp);
     pd->tmpfp = R_fopen(pd->tmpname, "w");
     if (!pd->tmpfp) {
 	fclose(pd->psfp);
 	return FALSE;
+    }
     XF_FileHeader(pd->psfp, pd->papername, pd->landscape, pd->onefile);
-    pd->fontstyle = 1;
-    pd->fontsize = 10;
     pd->pageno = 0;
     return TRUE;
+}
     if(style < 1 || style > 5) {
 	warning("attempt to use invalid font %d replaced by font 1", style);
 	style = 1;
+    }
-    pd->fontsize = size;
-    pd->fontstyle = style;
     if(style == 5) fontnum = 32;
     else fontnum = pd->fontnum + styles[style-1];
     XFconvert(&x, &y, pd);
     if(R_ALPHA(gc->col) == 0) {
     if(face < 1 || face > 5) face = 1;
     return floor(gc->cex * gc->ps + 0.5) *
 	PostScriptStringWidth((unsigned char *)str,
-			      &(pd->metrics[face-1]));
+			      &(pd->fonts->family->fonts[face-1]->metrics));
+}
 static void XFig_MetricInfo(int c,
 			    R_GE_gcontext *gc,
 			    double* ascent, double* descent,
     int face = gc->fontface;
     if(face < 1 || face > 5) face = 1;
     PostScriptMetricInfo(c, ascent, descent, width,
-			 &(pd->metrics[face-1]));
+			 &(pd->fonts->family->fonts[face-1]->metrics));
     *ascent = floor(gc->cex * gc->ps + 0.5) * *ascent;
     *descent = floor(gc->cex * gc->ps + 0.5) * *descent;
     *width = floor(gc->cex * gc->ps + 0.5) * *width;
+}
 /* TODO
    Flate encoding?
 */
 typedef struct {
     char filename[PATH_MAX];
     int pageno;		/* page number */
     int fileno;		/* file number */
-    int fontfamily;	/* font family */
-    char encpath[PATH_MAX]; /* font encoding */
-    char encname[100];
-    char **afmpaths;	/* for user-specified family */
     int maxpointsize;
     double width;	/* plot width in inches */
     double height;	/* plot height in inches */
     Rboolean onefile;	/* one file or one file per page? */
     FILE *pdffp;		/* output file */
-    FontMetricInfo metrics[5];	/* font metrics */
     /* This group of variables track the current device status.
      * They should only be set by routines that emit PDF. */
     struct {
 	double lwd;		 /* line width */
 	int lty;		 /* line type */
 	rcolor col;		 /* color */
 	rcolor fill;	         /* fill color */
 	rcolor bg;		 /* color */
     } current;
+    /*
+     * This is a record of the alpha transparency levels used during
+     * drawing to the device.
+     * Only allow 256 different alpha levels
+     * (because R uses 8-bit alpha channel).
+     * "alphas" is a record of alphas used so far (unused set to -1)
+     * There are separate alpha levels for stroking and filling
+     * (i.e., col and fill)
+     */
+    short colAlpha[256];
+    short fillAlpha[256];
+    /*
+     * What version of PDF are we trying to work with?
+     * This is used (so far) for implementing transparency
+     * Alphas are only used if version is at least 1.4
+     */
+    int versionMajor;
+    int versionMinor;
     int nobjs;  /* number of objects */
     int *pos; /* object positions */
     int *pageobj; /* page object numbers */
     int pagemax;
     int startstream; /* position of start of current stream */
     Rboolean inText;
     char title[1024];
+    /*
+     * Fonts and encodings used on the device
+     */
+    type1fontlist fonts;
+    encodinglist encodings;
+}
 PDFDesc;
 /* Device Driver Actions */
 static void PDF_Text(double x, double y, char *str,
 		     double rot, double hadj,
 		     R_GE_gcontext *gc,
 		     NewDevDesc *dd);
+/*
+ * Add a graphics engine font family to the list of fonts used on a
+ * PDF device ...
+ *
+ * ... AND add the font encoding to the list of encodings used on the
+ * device (if necessary)
+ */
+static Rboolean addPDFfont(type1fontfamily family,
+			   PDFDesc *pd,
+			   int *fontIndex)
+{
+    Rboolean result = FALSE;
+    type1fontlist fontlist = addDeviceFont(family, pd->fonts, fontIndex);
+    if (fontlist) {
+	int dontcare;
+	encodinginfo encoding =
+	    findDeviceEncoding(family->encoding->encpath,
+			       pd->encodings, &dontcare);
+	if (encoding) {
+	    pd->fonts = fontlist;
+	    result = TRUE;
+        } else {
+	    /*
+	     * The encoding should have been loaded when the font was loaded
+	     */
+	    encoding = findEncoding(family->encoding->encpath);
+	    if (!encoding) {
+		warning("Corrupt loaded encodings;  font not added");
+	    } else {
+		encodinglist enclist = addDeviceEncoding(encoding,
+							 pd->encodings);
+		if (enclist) {
+		    pd->fonts = fontlist;
+		    pd->encodings = enclist;
+		    result = TRUE;
+		} else
+		    warning("Failed to record device encoding; font not added");
+	    }
+	}
+    }
+    return result;
+}
 static Rboolean
 innerPDFDeviceDriver(NewDevDesc* dd, char *file, char *family, char *encoding,
 		     char *bg, char *fg, double width, double height,
-		     double ps, int onefile, char *title)
+		     double ps, int onefile, char *title, SEXP fonts,
+		     int versionMajor, int versionMinor)
+{
     /* If we need to bail out with some sort of "error" */
     /* then we must free(dd) */
+    int i, gotFont;
     double xoff = 0.0, yoff = 0.0, pointsize;
     rcolor setbg, setfg;
+    type1fontfamily font;
     PDFDesc *pd;
     /* Check and extract the device parameters */
     if (!(pd = (PDFDesc *) malloc(sizeof(PDFDesc))))
 	return 0;
     /* from here on, if need to bail out with "error", must also */
     /* free(pd) */
+    pd->versionMajor = versionMajor;
+    pd->versionMinor = versionMinor;
     pd->pos = (int *) calloc(350, sizeof(int));
     if(!pd->pos) {
 	free(pd); free(dd);
 	error("cannot allocate pd->pos");
+    }
     /* initialize PDF device description */
     strcpy(pd->filename, file);
     strncpy(pd->title, title, 1024);
-    pd->fontfamily = MatchFamily(family);
     if(strlen(encoding) > PATH_MAX - 1) {
 	free(dd);
 	free(pd->pos); free(pd->pageobj); free(pd);
 	error("encoding path is too long");
+    }
+    pd->encodings = NULL;
+    pd->fonts = NULL;
+    gotFont = 0;
+    if (!(font = findDefaultLoadedFont(encoding, family, 0))) {
+	font = addDefaultFontFromFamily(encoding, MatchFamily(family), 0);
+    }
+    if (font)
+	addPDFfont(font, pd, &gotFont);
+    if (!gotFont) {
+	free(dd);
+	free(pd);
+	error("Failed to initialise default PostScript font");
+    }
+    /*
+     * Load the font names sent in via the fonts arg
+     * NOTE that these are the font names specified at the
+     * R-level, NOT the translated font names.
+     */
+    if (!isNull(fonts)) {
+	int i, dontcare, gotFonts = 0, nfonts = LENGTH(fonts);
+	for (i=0; i<nfonts; i++) {
+	    int index;
+	    char *name = CHAR(STRING_ELT(fonts, i));
+	    if (findDeviceFont(name, pd->fonts, &index))
+		gotFonts++;
+	    else {
+		if (!(font = findLoadedFont(name)))
+		    font = addFont(name, 0);
+		if (font)
+		    if (addPDFfont(font, pd, &dontcare)) {
+			gotFonts++;
+		    }
+	    }
+	}
+	if (gotFonts < nfonts) {
+	    freeDeviceFontList(pd->fonts);
-    strcpy(pd->encpath, encoding);
+	    freeDeviceEncList(pd->encodings);
+	    pd->fonts = NULL;
+	    pd->encodings = NULL;
+	    free(dd);
+	    free(pd);
+	    error("Failed to initialise additional PostScript fonts");
+	}
+    }
     setbg = str2col(bg);
     setfg = str2col(fg);
+    /*
+     * Initialise all alphas to -1
+     */
+    for (i=0; i<256; i++) {
+	pd->colAlpha[i] = -1;
+	pd->fillAlpha[i] = -1;
+    }
     pd->width = width;
     pd->height = height;
     pointsize = floor(ps);
     if(setbg == NA_INTEGER && setfg  == NA_INTEGER) {
+	freeDeviceFontList(pd->fonts);
+	freeDeviceEncList(pd->encodings);
+	pd->fonts = NULL;
+	pd->encodings = NULL;
 	free(dd);
 	free(pd->pos); free(pd->pageobj); free(pd);
 	error("invalid foreground/background color (pdf)");
+    }
     dd->canChangeGamma = FALSE;
     /*	Start the driver */
     if(!PDF_Open(dd, pd)) {
+	freeDeviceFontList(pd->fonts);
+	freeDeviceEncList(pd->encodings);
+	pd->fonts = NULL;
+	pd->encodings = NULL;
+	free(dd);
 	free(pd->pos); free(pd->pageobj); free(pd);
 	return 0;
+    }
     dd->newDevStruct = 1;
+}
 Rboolean
 PDFDeviceDriver(DevDesc* dd, char *file, char *family, char *encoding,
 		char *bg, char *fg, double width, double height, double ps,
-		int onefile, char *title)
+		int onefile, char *title, SEXP fonts,
+		int versionMajor, int versionMinor)
+{
     return innerPDFDeviceDriver((NewDevDesc*) dd, file, family, encoding,
-				bg, fg, width, height, ps, onefile, title);
+				bg, fg, width, height, ps, onefile, title,
+				fonts, versionMajor, versionMinor);
+}
+/*
+ * Search through the alphas used so far and return
+ * existing index if there is one.
+ * Otherwise, add alpha to the list and return new index
+ */
+static int alphaIndex(int alpha, short *alphas) {
+    int i, found = 0;
+    for (i=0; i<256 && !found; i++) {
+	if (alphas[i] < 0) {
+	    alphas[i] = alpha;
+	    found = 1;
+	}
+	if (alpha == alphas[i])
+	    found = 1;
+    }
+    if (!found)
+	error("Invalid alpha value in PDF");
+    return i;
+}
+/*
+ * colAlpha graphics state parameter dictionaries are named
+ * /GS1 to /GS256
+ * fillAlpha graphics state parameter dictionaries are named
+ * /GS257 to /GS512
+ */
+static int colAlphaIndex(int alpha, PDFDesc *pd) {
+    return alphaIndex(alpha, pd->colAlpha);
+}
+static int fillAlphaIndex(int alpha, PDFDesc *pd) {
+    return alphaIndex(alpha, pd->fillAlpha) + 256;
+}
+/*
+ * Does the version support alpha transparency?
+ */
+static int alphaVersion(PDFDesc *pd) {
+    return (pd->versionMajor > 1  ||
+	    (pd->versionMajor == 1 && pd->versionMinor >= 4));
+}
+/*
+ * Do we need to bother with semi-transparency?
+ */
+static int semiTransparent(int col)
+{
+    return !(R_OPAQUE(col) || R_TRANSPARENT(col));
+}
 static void PDF_SetLineColor(int color, NewDevDesc *dd)
+{
     PDFDesc *pd = (PDFDesc *) dd->deviceSpecific;
     if(color != pd->current.col) {
+	if (alphaVersion(pd)) {
+	    /*
+	     * Apply graphics state parameter dictionary
+	     * to set alpha
+	     */
+	    fprintf(pd->pdffp, "/GS%i gs\n",
+		    colAlphaIndex(R_ALPHA(color), pd));
+	}
 	fprintf(pd->pdffp, "%.3f %.3f %.3f RG\n",
 		R_RED(color)/255.0,
 		R_GREEN(color)/255.0,
 		R_BLUE(color)/255.0);
 	pd->current.col = color;
 static void PDF_SetFill(int color, NewDevDesc *dd)
+{
     PDFDesc *pd = (PDFDesc *) dd->deviceSpecific;
     if(color != pd->current.fill) {
+	if (alphaVersion(pd)) {
+	    /*
+	     * Apply graphics state parameter dictionary
+	     * to set alpha
+	     */
+	    fprintf(pd->pdffp, "/GS%i gs\n",
+		    fillAlphaIndex(R_ALPHA(color), pd));
+	}
 	fprintf(pd->pdffp, "%.3f %.3f %.3f rg\n",
 		   R_RED(color)/255.0,
 		   R_GREEN(color)/255.0,
 		   R_BLUE(color)/255.0);
 	pd->current.fill = color;
+{
     fprintf(pd->pdffp, "ET\n");
     pd->inText = FALSE;
+}
-static void PDF_EncodeFont(PDFDesc *pd, int nobj)
+static void PDF_Encodings(PDFDesc *pd)
+{
-    char *encname = pd->encname;
+    encodinglist enclist = pd->encodings;
+    while (enclist) {
+	encodinginfo encoding = enclist->encoding;
+	pd->pos[++pd->nobjs] = (int) ftell(pd->pdffp);
-    fprintf(pd->pdffp, "%d 0 obj\n<<\n/Type /Encoding\n", nobj);
+	fprintf(pd->pdffp, "%d 0 obj\n<<\n/Type /Encoding\n", pd->nobjs);
-    if (strcmp(encname, "WinAnsiEncoding") == 0 ||
+	if (strcmp(encoding->name, "WinAnsiEncoding") == 0 ||
-	strcmp(encname, "MacRomanEncoding") == 0 ||
+	    strcmp(encoding->name, "MacRomanEncoding") == 0 ||
-	strcmp(encname, "PDFDocEncoding") == 0) {
+	    strcmp(encoding->name, "PDFDocEncoding") == 0) {
-	fprintf(pd->pdffp, "/BaseEncoding /%s\n", encname);
+	    fprintf(pd->pdffp, "/BaseEncoding /%s\n", encoding->name);
-	fprintf(pd->pdffp, "/Differences [ 45/minus ]\n");
+	    fprintf(pd->pdffp, "/Differences [ 45/minus ]\n");
-    } else if (strcmp(encname, "ISOLatin1Encoding") == 0) {
+	} else if (strcmp(encoding->name, "ISOLatin1Encoding") == 0) {
-	fprintf(pd->pdffp, "/BaseEncoding /PDFDocEncoding\n");
+	    fprintf(pd->pdffp, "/BaseEncoding /PDFDocEncoding\n");
-	fprintf(pd->pdffp, "/Differences [ 45/minus 96/quoteleft\n144/dotlessi /grave /acute /circumflex /tilde /macron /breve /dotaccent\n/dieresis /.notdef /ring /cedilla /.notdef /hungarumlaut /ogonek /caron /space]\n");
+	    fprintf(pd->pdffp, "/Differences [ 45/minus 96/quoteleft\n144/dotlessi /grave /acute /circumflex /tilde /macron /breve /dotaccent\n/dieresis /.notdef /ring /cedilla /.notdef /hungarumlaut /ogonek /caron /space]\n");
-    } else {
+	} else {
-	fprintf(pd->pdffp, "/BaseEncoding /PDFDocEncoding\n");
+	    fprintf(pd->pdffp, "/BaseEncoding /PDFDocEncoding\n");
-	fprintf(pd->pdffp, "/Differences [ 0 %s ]\n", enccode);
+	    fprintf(pd->pdffp, "/Differences [ 0 %s ]\n", encoding->enccode);
+	}
+	fprintf(pd->pdffp, ">>\nendobj\n");
+	enclist = enclist->next;
+    }
-    fprintf(pd->pdffp, ">>\nendobj\n");
+}
 #include <time.h>
 #include <Rversion.h>
 static void PDF_startfile(PDFDesc *pd)
+{
-    int i;
     struct tm *ltm;
     time_t ct;
     pd->nobjs = 0;
     pd->pageno = 0;
-    fprintf(pd->pdffp, "%%PDF-1.1\n%%âãÏÓ\r\n");
+    fprintf(pd->pdffp, "%%PDF-%i.%i\n%%âãÏÓ\r\n",
+	    pd->versionMajor, pd->versionMinor);
     pd->pos[++pd->nobjs] = (int) ftell(pd->pdffp);
     /* Object 1 is Info node. Date format is from the PDF manual */
     ct = time(NULL);
     pd->pos[++pd->nobjs] = (int) ftell(pd->pdffp);
     fprintf(pd->pdffp, "2 0 obj\n<<\n/Type /Catalog\n/Pages 3 0 R\n>>\nendobj\n");
     /* Object 3 will be at the end */
-    /* Object 4 is the standard resources dict for each page */
     ++pd->nobjs;
-    pd->pos[++pd->nobjs] = (int) ftell(pd->pdffp);
-    fprintf(pd->pdffp,
-	    "4 0 obj\n<<\n/ProcSet [/PDF /Text]\n/Font << %s %s %s %s %s %s >>\n>>\nendobj\n",
-	    "/F1 6 0 R","/F2 7 0 R","/F3 8 0 R","/F4 9 0 R","/F5 10 0 R",
-	    "/F6 11 0 R");
-    /* Object 5 is the encoding for text fonts */
+    /* Object 4 will be at the end */
-    pd->pos[++pd->nobjs] = (int) ftell(pd->pdffp);
-    PDF_EncodeFont(pd, pd->nobjs);
+    ++pd->nobjs;
-    /* Objects 6, 7, 8, 9 are the fonts for the text family */
-    /* Object 10 is the Symbol font */
-    /* Object 11 is Dingbats, used for (small) circles */
+    /* Object 5 is Dingbats, used for (small) circles */
-    for (i = 0; i < 4; i++) {
-	pd->pos[++pd->nobjs] = (int) ftell(pd->pdffp);
-	fprintf(pd->pdffp, "%d 0 obj\n<<\n/Type /Font\n/Subtype /Type1\n/Name /F%d\n/BaseFont /%s\n/Encoding 5 0 R\n>>\nendobj\n",
-		i+6, i+1, familyname[i]);
-    }
-    pd->pos[++pd->nobjs] = (int) ftell(pd->pdffp);
-    fprintf(pd->pdffp, "10 0 obj\n<<\n/Type /Font\n/Subtype /Type1\n/Name /F5\n/BaseFont /Symbol\n>>\nendobj\n");
     pd->pos[++pd->nobjs] = (int) ftell(pd->pdffp);
-    fprintf(pd->pdffp, "11 0 obj\n<<\n/Type /Font\n/Subtype /Type1\n/Name /F6\n/BaseFont /ZapfDingbats\n>>\nendobj\n");
+    fprintf(pd->pdffp, "5 0 obj\n<<\n/Type /Font\n/Subtype /Type1\n/Name /F1\n/BaseFont /ZapfDingbats\n>>\nendobj\n");
+}
 static void PDF_endfile(PDFDesc *pd)
+{
-    int i, startxref;
+    int i, startxref, tempnobj, nenc, nfonts, firstencobj;
     /* object 3 lists all the pages */
     pd->pos[3] = (int) ftell(pd->pdffp);
     fprintf(pd->pdffp, "3 0 obj\n<<\n/Type /Pages\n/Kids [\n");
     for(i = 0; i < pd->pageno; i++)
     fprintf(pd->pdffp,
 	    "]\n/Count %d\n/MediaBox [0 0 %d %d]\n>>\nendobj\n",
 	    pd->pageno,
 	    (int) (0.5 + 72*pd->width), (int) (0.5 + 72*pd->height));
+    /* Object 4 is the standard resources dict for each page */
+    pd->pos[4] = (int) ftell(pd->pdffp);
+    /* fonts */
+    /* Dingbats always first */
+    fprintf(pd->pdffp,
+	    "4 0 obj\n<<\n/ProcSet [/PDF /Text]\n/Font << /F1 5 0 R ");
+    /* Count how many encodings will be included
+     * fonts come after encodings */
+    nenc = 0;
+    if (pd->encodings) {
+	encodinglist enclist = pd->encodings;
+	while (enclist) {
+	    nenc++;
+	    enclist = enclist->next;
+	}
+    }
+    /* Should be a default text font at least, plus possibly others */
+    nfonts = 0;
+    tempnobj = pd->nobjs + nenc;
+    if (pd->fonts) {
+	type1fontlist fontlist = pd->fonts;
+	while (fontlist) {
+	    for (i=0; i<5; i++) {
+		fprintf(pd->pdffp, "/F%d %d 0 R ",
+			/* /F1 is dingbats */
+			nfonts + 2, ++tempnobj);
+		nfonts++;
+	    }
+	    fontlist = fontlist->next;
+	}
+    }
+    fprintf(pd->pdffp, ">>\n");
+    /* graphics state parameter dictionaries */
+    fprintf(pd->pdffp, "/ExtGState << ");
+    tempnobj = pd->nobjs + nenc + nfonts;
+    for (i = 0; i < 256 && pd->colAlpha[i] >= 0; i++) {
+	fprintf(pd->pdffp, "/GS%i %d 0 R ", i + 1, ++tempnobj);
+    }
+    for (i = 0; i < 256 && pd->fillAlpha[i] >= 0; i++) {
+	fprintf(pd->pdffp, "/GS%i %d 0 R ", i + 257, ++tempnobj);
+    }
+    fprintf(pd->pdffp, ">>\n");
+    fprintf(pd->pdffp, ">>\nendobj\n");
+    /*
+     * Write out objects representing the encodings
+     */
+    firstencobj = pd->nobjs;
+    PDF_Encodings(pd);
+    /*
+     * Write out objects representing the fonts
+     */
+    nfonts = 0;
+    if (pd->fonts) {
+	type1fontlist fontlist = pd->fonts;
+	while (fontlist) {
+	    /*
+	     * Find the index of the device encoding
+	     * This really should be there
+	     */
+	    int encIndex;
+	    encodinginfo encoding =
+		findDeviceEncoding(fontlist->family->encoding->encpath,
+				   pd->encodings, &encIndex);
+	    if (!encoding)
+		error("Corrupt encodings in PDF device");
+	    for (i=0; i<4; i++) {
+		pd->pos[++pd->nobjs] = (int) ftell(pd->pdffp);
+		fprintf(pd->pdffp, "%d 0 obj\n<<\n/Type /Font\n/Subtype /Type1\n/Name /F%d\n/BaseFont /%s\n/Encoding %d 0 R\n>>\nendobj\n",
+			pd->nobjs,
+			nfonts + 2,
+			fontlist->family->fonts[i]->name,
+			/* Encodings come after dingbats font which is
+			 * object 5 */
+			encIndex + firstencobj);
+		nfonts++;
+	    }
+	    /* Symbol face does not use encoding */
+	    pd->pos[++pd->nobjs] = (int) ftell(pd->pdffp);
+	    fprintf(pd->pdffp, "%d 0 obj\n<<\n/Type /Font\n/Subtype /Type1\n/Name /F%d\n/BaseFont /%s\n>>\nendobj\n",
+		    pd->nobjs,
+		    nfonts + 2,
+		    fontlist->family->fonts[4]->name);
+	    nfonts++;
+	    fontlist = fontlist->next;
+	}
+    }
+    /*
+     * Write out objects representing the graphics state parameter
+     * dictionaries for alpha transparency
+     *
+     * NOTE:  R considers alpha=0 opaque, in PDF it is transparent
+     * so we must take 1 - alpha value
+     */
+    for (i = 0; i < 256 && pd->colAlpha[i] >= 0; i++) {
+	pd->pos[++pd->nobjs] = (int) ftell(pd->pdffp);
+	fprintf(pd->pdffp, "%d 0 obj\n<<\n/Type /ExtGState\n/CA %1.3f >>\nendobj\n",
+		pd->nobjs, 1 - pd->colAlpha[i]/255.0);
+    }
+    for (i = 0; i < 256 && pd->fillAlpha[i] >= 0; i++) {
+	pd->pos[++pd->nobjs] = (int) ftell(pd->pdffp);
+	fprintf(pd->pdffp, "%d 0 obj\n<<\n/Type /ExtGState\n/ca %1.3f\n>>\nendobj\n",
+		pd->nobjs, 1 - pd->fillAlpha[i]/255.0);
+    }
     /* write out xref table */
     startxref = (int) ftell(pd->pdffp);
     /* items here must be exactly 20 bytes including terminator */
     fprintf(pd->pdffp, "xref\n0 %d\n", pd->nobjs+1);
 static Rboolean PDF_Open(NewDevDesc *dd, PDFDesc *pd)
+{
     char buf[512];
-    int i;
-    if (!LoadEncoding(pd->encpath, pd->encname, TRUE)) {
-	warning("problem loading encoding file");
-	return FALSE;
-    }
-    for(i = 0; i < 4 ; i++) {
-	char const *p = Family[pd->fontfamily].afmfile[i];
-	if(!PostScriptLoadFontMetrics(p, &(pd->metrics[i]),
-				      familyname[i], 1)) {
-	    warning("cannot read afm file %s", p);
-	    return FALSE;
-	}
-    }
-    if(!PostScriptLoadFontMetrics("sy______.afm", &(pd->metrics[4]),
-				  familyname[4], 0)) {
-	warning("cannot read afm file sy______.afm");
-	return FALSE;
-    }
     /* NB: this must be binary to get tell positions and line endings right */
     snprintf(buf, 512, pd->filename, pd->fileno + 1); /* file 1 to start */
     pd->pdffp = R_fopen(R_ExpandFileName(buf), "wb");
+{
     PDFDesc *pd = (PDFDesc *) dd->deviceSpecific;
     if(pd->pageno > 0) PDF_endpage(pd);
     PDF_endfile(pd);
+    freeDeviceFontList(pd->fonts);
+    freeDeviceEncList(pd->encodings);
+    pd->fonts = NULL;
+    pd->encodings = NULL;
     free(pd->pos); free(pd->pageobj); free(pd);
+}
 static void PDF_Activate(NewDevDesc *dd) {}
 static void PDF_Deactivate(NewDevDesc *dd) {}
 		     NewDevDesc *dd)
+{
     PDFDesc *pd = (PDFDesc *) dd->deviceSpecific;
     int code;
+    /*
-    code = 2 * (R_ALPHA(gc->fill) == 0) + (R_ALPHA(gc->col) == 0);
+     * Only try to do real transparency if version at least 1.4
-    if (code) {
+     */
+    if ((semiTransparent(gc->col) ||
+	 semiTransparent(gc->fill)) &&
+	alphaVersion(pd)) {
 	if(pd->inText) textoff(pd);
+	PDF_SetFill(gc->fill, dd);
+	PDF_SetLineColor(gc->col, dd);
+	PDF_SetLineStyle(gc->lty, gc->lwd, dd);
+	fprintf(pd->pdffp, "%.2f %.2f %.2f %.2f re B\n", x0, y0, x1-x0, y1-y0);
+    } else {
+	code = 2 * (R_ALPHA(gc->fill) == 0) + (R_ALPHA(gc->col) == 0);
+	if (code) {
+	    if(pd->inText) textoff(pd);
-	if(code & 2)
+	    if(code & 2)
-	    PDF_SetFill(gc->fill, dd);
+		PDF_SetFill(gc->fill, dd);
-	if(code & 1) {
+	    if(code & 1) {
-	    PDF_SetLineColor(gc->col, dd);
+		PDF_SetLineColor(gc->col, dd);
-	    PDF_SetLineStyle(gc->lty, gc->lwd, dd);
+		PDF_SetLineStyle(gc->lty, gc->lwd, dd);
-	}
+	    }
-	fprintf(pd->pdffp, "%.2f %.2f %.2f %.2f re", x0, y0, x1-x0, y1-y0);
+	    fprintf(pd->pdffp, "%.2f %.2f %.2f %.2f re", x0, y0, x1-x0, y1-y0);
-	switch(code){
+	    switch(code){
-	case 1: fprintf(pd->pdffp, " S\n"); break;
+	    case 1: fprintf(pd->pdffp, " S\n"); break;
-	case 2: fprintf(pd->pdffp, " f\n"); break;
+	    case 2: fprintf(pd->pdffp, " f\n"); break;
-	case 3: fprintf(pd->pdffp, " B\n"); break;
+	    case 3: fprintf(pd->pdffp, " B\n"); break;
+	    }
+	}
+    }
+}
 /* r is in device coords */
+{
     PDFDesc *pd = (PDFDesc *) dd->deviceSpecific;
     int code, tr;
     double xx, yy, a;
+    /*
-    code = 2 * (R_ALPHA(gc->fill) == 0) + (R_ALPHA(gc->col) == 0);
+     * Only try to do real transparency if version at least 1.4
+     */
-    if (code) {
+    if ((semiTransparent(gc->col) ||
+	 semiTransparent(gc->fill)) &&
-	if(code & 2)
+	alphaVersion(pd)) {
-	    PDF_SetFill(gc->fill, dd);
+	PDF_SetFill(gc->fill, dd);
-	if(code & 1) {
-	    PDF_SetLineColor(gc->col, dd);
+	PDF_SetLineColor(gc->col, dd);
-	    PDF_SetLineStyle(gc->lty, gc->lwd, dd);
+	PDF_SetLineStyle(gc->lty, gc->lwd, dd);
-	}
+	/*
-	if(r > 10) { /* somewhat arbitrary, use font up to 20pt */
+	 * Due to possible bug in Acrobat Reader for rendering
-            /* Use four Bezier curves, hand-fitted to quadrants */
+	 * semi-transparent text, only every draw Bezier curves
+	 * regardless of circle size.
+	 */
+	{
 	    double s = 0.55 * r;
 	    if(pd->inText) textoff(pd);
 	    fprintf(pd->pdffp, "  %.2f %.2f m\n", x - r, y);
 	    fprintf(pd->pdffp, "  %.2f %.2f %.2f %.2f %.2f %.2f c\n",
-		   x - r, y + s, x - s, y + r, x, y + r);
+		    x - r, y + s, x - s, y + r, x, y + r);
 	    fprintf(pd->pdffp, "  %.2f %.2f %.2f %.2f %.2f %.2f c\n",
-		   x + s, y + r, x + r, y + s, x + r, y);
+		    x + s, y + r, x + r, y + s, x + r, y);
 	    fprintf(pd->pdffp, "  %.2f %.2f %.2f %.2f %.2f %.2f c\n",
-		   x + r, y - s, x + s, y - r, x, y - r);
+		    x + r, y - s, x + s, y - r, x, y - r);
 	    fprintf(pd->pdffp, "  %.2f %.2f %.2f %.2f %.2f %.2f c\n",
-		   x - s, y - r, x - r, y - s, x - r, y);
+		    x - s, y - r, x - r, y - s, x - r, y);
+	    fprintf(pd->pdffp, "B\n");
+	}
+    } else {
+	code = 2 * (R_ALPHA(gc->fill) == 0) + (R_ALPHA(gc->col) == 0);
+	if (code) {
+	    if(code & 2)
+		PDF_SetFill(gc->fill, dd);
+	    if(code & 1) {
+		PDF_SetLineColor(gc->col, dd);
+		PDF_SetLineStyle(gc->lty, gc->lwd, dd);
+	    }
+	    if(r > 10) { /* somewhat arbitrary, use font up to 20pt */
+		/* Use four Bezier curves, hand-fitted to quadrants */
+		double s = 0.55 * r;
+		if(pd->inText) textoff(pd);
+		fprintf(pd->pdffp, "  %.2f %.2f m\n", x - r, y);
+		fprintf(pd->pdffp, "  %.2f %.2f %.2f %.2f %.2f %.2f c\n",
+			x - r, y + s, x - s, y + r, x, y + r);
+		fprintf(pd->pdffp, "  %.2f %.2f %.2f %.2f %.2f %.2f c\n",
+			x + s, y + r, x + r, y + s, x + r, y);
+		fprintf(pd->pdffp, "  %.2f %.2f %.2f %.2f %.2f %.2f c\n",
+			x + r, y - s, x + s, y - r, x, y - r);
+		fprintf(pd->pdffp, "  %.2f %.2f %.2f %.2f %.2f %.2f c\n",
+			x - s, y - r, x - r, y - s, x - r, y);
-	    switch(code){
+		switch(code){
-	    case 1: fprintf(pd->pdffp, "S\n"); break;
+		case 1: fprintf(pd->pdffp, "S\n"); break;
-	    case 2: fprintf(pd->pdffp, "f\n"); break;
+		case 2: fprintf(pd->pdffp, "f\n"); break;
-	    case 3: fprintf(pd->pdffp, "B\n"); break;
+		case 3: fprintf(pd->pdffp, "B\n"); break;
+		}
+	    } else {
+		/* Use char 108 in Dingbats, which is a solid disc
+		   afm is C 108 ; WX 791 ; N a71 ; B 35 -14 757 708 ;
+		   so diameter = 0.722 * size
+		   centre = (0.396, 0.347) * size
+		*/
+		a = 2./0.722 * r;
+		xx = x - 0.396*a;
+		yy = y - 0.347*a;
+		tr = (R_ALPHA(gc->fill) == 0) +
+* (R_ALPHA(gc->col) == 0) - 1;
+		if(!pd->inText) texton(pd);
+		fprintf(pd->pdffp,
+			"/F1 1 Tf %d Tr %.2f 0 0 %.2f %.2f %.2f Tm",
+			tr, a, a, xx, yy);
+		fprintf(pd->pdffp, " (l) Tj 0 Tr\n");
+	    }
-	} else {
-	    /* Use char 108 in Dingbats, which is a solid disc
-	       afm is C 108 ; WX 791 ; N a71 ; B 35 -14 757 708 ;
-	       so diameter = 0.722 * size
-	       centre = (0.396, 0.347) * size
-	    */
-	    a = 2./0.722 * r;
-	    xx = x - 0.396*a;
-	    yy = y - 0.347*a;
-	    tr = (R_ALPHA(gc->fill) == 0) + 2 * (R_ALPHA(gc->col) == 0) - 1;
-	    if(!pd->inText) texton(pd);
-	    fprintf(pd->pdffp,
-		    "/F6 1 Tf %d Tr %.2f 0 0 %.2f %.2f %.2f Tm",
-		    tr, a, a, xx, yy);
-	    fprintf(pd->pdffp, " (l) Tj 0 Tr\n");
+	}
+    }
+}
 static void PDF_Line(double x1, double y1, double x2, double y2,
 		     R_GE_gcontext *gc,
 		     NewDevDesc *dd)
+{
     PDFDesc *pd = (PDFDesc *) dd->deviceSpecific;
+    /*
+     * Only try to do real transparency if version at least 1.4
+     */
+    if ((semiTransparent(gc->col) && alphaVersion(pd)) ||
-    if(R_ALPHA(gc->col) == 0) {
+	(R_ALPHA(gc->col) == 0)) {
 	PDF_SetLineColor(gc->col, dd);
 	PDF_SetLineStyle(gc->lty, gc->lwd, dd);
 	if(pd->inText) textoff(pd);
 	fprintf(pd->pdffp, "%.2f %.2f m %.2f %.2f l S\n", x1, y1, x2, y2);
+    }
+{
     PDFDesc *pd = (PDFDesc *) dd->deviceSpecific;
     double xx, yy;
     int i, code;
+    /*
-    code = 2 * (R_ALPHA(gc->fill) == 0) + (R_ALPHA(gc->col) == 0);
+     * Only try to do real transparency if version at least 1.4
+     */
+    if ((semiTransparent(gc->col) ||
+	 semiTransparent(gc->fill)) &&
-    if (code) {
+	alphaVersion(pd)) {
 	if(pd->inText) textoff(pd);
-	if(code & 2)
-	    PDF_SetFill(gc->fill, dd);
+	PDF_SetFill(gc->fill, dd);
-	if(code & 1) {
-	    PDF_SetLineColor(gc->col, dd);
+	PDF_SetLineColor(gc->col, dd);
-	    PDF_SetLineStyle(gc->lty, gc->lwd, dd);
+	PDF_SetLineStyle(gc->lty, gc->lwd, dd);
-	}
 	xx = x[0];
 	yy = y[0];
 	fprintf(pd->pdffp, "  %.2f %.2f m\n", xx, yy);
 	for(i = 1 ; i < n ; i++) {
 	    xx = x[i];
 	    yy = y[i];
 	    fprintf(pd->pdffp, "  %.2f %.2f l\n", xx, yy);
+	}
+	fprintf(pd->pdffp, "b\n");
+    } else {
+	code = 2 * (R_ALPHA(gc->fill) == 0) + (R_ALPHA(gc->col) == 0);
+	if (code) {
+	    if(pd->inText) textoff(pd);
+	    if(code & 2)
+		PDF_SetFill(gc->fill, dd);
+	    if(code & 1) {
+		PDF_SetLineColor(gc->col, dd);
+		PDF_SetLineStyle(gc->lty, gc->lwd, dd);
+	    }
+	    xx = x[0];
+	    yy = y[0];
+	    fprintf(pd->pdffp, "  %.2f %.2f m\n", xx, yy);
+	    for(i = 1 ; i < n ; i++) {
+		xx = x[i];
+		yy = y[i];
+		fprintf(pd->pdffp, "  %.2f %.2f l\n", xx, yy);
+	    }
-	switch(code){
+	    switch(code){
-	case 1: fprintf(pd->pdffp, "s\n"); break;
+	    case 1: fprintf(pd->pdffp, "s\n"); break;
-	case 2: fprintf(pd->pdffp, "h f\n"); break;
+	    case 2: fprintf(pd->pdffp, "h f\n"); break;
-	case 3: fprintf(pd->pdffp, "b\n"); break;
+	    case 3: fprintf(pd->pdffp, "b\n"); break;
+	    }
+	}
+    }
+}
 static void PDF_Polyline(int n, double *x, double *y,
 			 R_GE_gcontext *gc,
 			 NewDevDesc *dd)
+{
     PDFDesc *pd = (PDFDesc*) dd->deviceSpecific;
     double xx, yy;
     int i;
+    /*
+     * Only try to do real transparency if version at least 1.4
+     */
-    if(pd->inText) textoff(pd);
+    if ((semiTransparent(gc->col) ||
-    if(R_ALPHA(gc->col) == 0) {
+	 semiTransparent(gc->fill)) &&
+	alphaVersion(pd)) {
+	if(pd->inText) textoff(pd);
 	PDF_SetLineColor(gc->col, dd);
 	PDF_SetLineStyle(gc->lty, gc->lwd, dd);
 	xx = x[0];
 	yy = y[0];
 	fprintf(pd->pdffp, "%.2f %.2f m\n", xx, yy);
 	    xx = x[i];
 	    yy = y[i];
 	    fprintf(pd->pdffp, "%.2f %.2f l\n", xx, yy);
+	}
 	fprintf(pd->pdffp, "S\n");
+    } else {
+	if(pd->inText) textoff(pd);
+	if(R_ALPHA(gc->col) == 0) {
+	    PDF_SetLineColor(gc->col, dd);
+	    PDF_SetLineStyle(gc->lty, gc->lwd, dd);
+	    xx = x[0];
+	    yy = y[0];
+	    fprintf(pd->pdffp, "%.2f %.2f m\n", xx, yy);
+	    for(i = 1 ; i < n ; i++) {
+		xx = x[i];
+		yy = y[i];
+		fprintf(pd->pdffp, "%.2f %.2f l\n", xx, yy);
+	    }
+	    fprintf(pd->pdffp, "S\n");
+	}
+    }
+}
+static int PDFfontNumber(char *family, int face, PDFDesc *pd)
+{
+    /* DingBats is font 1 */
+    int num = 1 + face;
+    if (strlen(family) > 0) {
+	int fontIndex;
+	/*
+	 * Try to find font in already loaded fonts
+	 */
+	type1fontfamily fontfamily = findDeviceFont(family, pd->fonts,
+						    &fontIndex);
+	if (fontfamily)
+	    num = (fontIndex - 1)*5 + 1 + face;
+	else {
+	    /*
+	     * Try to load the font
+	     */
+	    fontfamily = addFont(family, 1);
+	    if (fontfamily) {
+		if (addPDFfont(fontfamily, pd, &fontIndex)) {
+		    num = (fontIndex - 1)*5 + 1 + face;
+		} else {
+		    fontfamily = NULL;
+		}
+	    }
+	}
+	if (!fontfamily)
+	    error("Failed to find or load PDF font");
+    }
+    return num;
+}
 static void PDF_Text(double x, double y, char *str,
 		     double rot, double hadj,
 		     R_GE_gcontext *gc,
 		     NewDevDesc *dd)
+    }
     rot1 = rot * DEG2RAD;
     a = size * cos(rot1);
     b = size * sin(rot1);
     if(!pd->inText) texton(pd);
+    /*
+     * Only try to do real transparency if version at least 1.4
+     */
+    if ((pd->versionMajor >= 1 && pd->versionMinor >= 4) ||
-    if(R_ALPHA(gc->col) == 0) {
+	(R_ALPHA(gc->col) == 0)) {
 	PDF_SetFill(gc->col, dd);
 	fprintf(pd->pdffp, "/F%d 1 Tf %.2f %.2f %.2f %.2f %.2f %.2f Tm ",
+		PDFfontNumber(gc->fontfamily, face, pd),
-		face, a, b, -b, a, x, y);
+		a, b, -b, a, x, y);
 	PostScriptWriteString(pd->pdffp, str);
 	fprintf(pd->pdffp, " Tj\n");
+    }
+}
 static void PDF_Hold(NewDevDesc *dd)
+{
+}
+static FontMetricInfo *PDFmetricInfo(char *family, int face,
+				     PDFDesc *pd)
+{
+    FontMetricInfo *result = &(pd->fonts->family->fonts[face-1]->metrics);
+    if (strlen(family) > 0) {
+	int dontcare;
+	/*
+	 * Find the family in pd->fonts
+	 */
+	type1fontfamily fontfamily = findDeviceFont(family, pd->fonts,
+						    &dontcare);
+	if (fontfamily)
+	    result = &(fontfamily->fonts[face-1]->metrics);
+	else {
+	    /*
+	     * Try to load the font
+	     */
+	    fontfamily = addFont(family, 1);
+	    if (fontfamily) {
+		if (addPDFfont(fontfamily, pd, &dontcare)) {
+		    result = &(fontfamily->fonts[face-1]->metrics);
+		} else {
+		    fontfamily = NULL;
+		}
+	    }
+	}
+	if (!fontfamily)
+	    error("Failed to find or load PDF font");
+    }
+    return result;
+}
 static double PDF_StrWidth(char *str,
 			   R_GE_gcontext *gc,
 			   NewDevDesc *dd)
+{
     PDFDesc *pd = (PDFDesc *) dd->deviceSpecific;
     if(gc->fontface < 1 || gc->fontface > 5) gc->fontface = 1;
     return floor(gc->cex * gc->ps + 0.5) *
 	PostScriptStringWidth((unsigned char *)str,
-			      &(pd->metrics[gc->fontface-1]));
+			      PDFmetricInfo(gc->fontfamily,
+					    gc->fontface, pd));
+}
 static void PDF_MetricInfo(int c,
 			   R_GE_gcontext *gc,
 			   double* ascent, double* descent,
+{
     PDFDesc *pd = (PDFDesc *) dd->deviceSpecific;
     if(gc->fontface < 1 || gc->fontface > 5) gc->fontface = 1;
     PostScriptMetricInfo(c, ascent, descent, width,
-			 &(pd->metrics[gc->fontface-1]));
+			 PDFmetricInfo(gc->fontfamily,
+				       gc->fontface, pd));
     *ascent = floor(gc->cex * gc->ps + 0.5) * *ascent;
     *descent = floor(gc->cex * gc->ps + 0.5) * *descent;
     *width = floor(gc->cex * gc->ps + 0.5) * *width;
+}

The R Project SVN R

(root)/branches/djm-source/src/main/devPS.c @ 34412 – Rev 29864 → 30691