From 6bc272fdd12e11f49d37da9ee8599a4b341310d6 Mon Sep 17 00:00:00 2001
From: Stephen Adams <edu/mit/csail/zurich/adams>
Date: Sat, 17 Sep 1994 17:35:12 +0000
Subject: [PATCH] Added X-LIST-FONTS primitive.

---
 v7/src/microcode/x11base.c | 48 ++++++++++++++++++++++++++++++++++++--
 1 file changed, 46 insertions(+), 2 deletions(-)

diff --git a/v7/src/microcode/x11base.c b/v7/src/microcode/x11base.c
index 34362e03b..7ab89336a 100644
--- a/v7/src/microcode/x11base.c
+++ b/v7/src/microcode/x11base.c
@@ -1,6 +1,6 @@
 /* -*-C-*-
 
-$Id: x11base.c,v 1.54 1994/09/16 21:20:13 cph Exp $
+$Id: x11base.c,v 1.55 1994/09/17 17:35:12 adams Exp $
 
 Copyright (c) 1989-93 Massachusetts Institute of Technology
 
@@ -1998,7 +1998,8 @@ DEFINE_PRIMITIVE ("X-FONT-STRUCTURE", Prim_x_font_structure, 2, 2,
 }
 
 DEFINE_PRIMITIVE ("X-WINDOW-FONT-STRUCTURE", Prim_x_window_font_structure, 1, 1,
-		  0)
+ "(x-window)\n\
+  Returns the font-structure for the font currently associated with X-WINDOW")
 {
   XFontStruct *font;
   PRIMITIVE_HEADER (1);
@@ -2006,3 +2007,46 @@ DEFINE_PRIMITIVE ("X-WINDOW-FONT-STRUCTURE", Prim_x_window_font_structure, 1, 1,
   font = XW_FONT (x_window_arg (1));
   PRIMITIVE_RETURN (convert_font_struct (ulong_to_integer (font->fid), font));
 }
+
+DEFINE_PRIMITIVE ("X-LIST-FONTS", Prim_x_list_fonts, 3, 3,
+ "(display pattern limit)\n\
+  LIMIT is an exact non-negative integer or #F for no limit\n\
+  Returns #F or a vector of at least one string.")
+{
+    PRIMITIVE_HEADER (1);
+    {
+	SCHEME_OBJECT result;
+	Display *display = XD_DISPLAY (x_display_arg (1));
+	char *pattern = STRING_ARG (2);
+	int maxnames =
+	  (FIXNUM_P (ARG_REF (3))) ? FIXNUM_TO_LONG (ARG_REF (3))
+                                   : 1000000;
+	int actual_count = 0;
+	int words;
+	int i;
+	char **names = XListFonts (display, pattern, maxnames, &actual_count);
+
+	if (!names)
+	  PRIMITIVE_RETURN (SHARP_F);
+
+	words = actual_count + 1; /* the vector of strings */
+
+	for (i=0; i<actual_count; i++)
+	    words += STRING_LENGTH_TO_GC_LENGTH (strlen (names[i]));
+	
+	if (GC_Check (words)) {
+	    /* this causes the primitive to be restarted, so deallocate names */
+	    XFreeFontNames (names);
+	    Primitive_GC (words);
+	    /* notreached */
+	}
+
+	result = allocate_marked_vector (TC_VECTOR, actual_count, false);
+
+	for (i = 0;  i<actual_count;  i++)
+	  VECTOR_SET (result, i, char_pointer_to_string (names[i]));
+	
+	XFreeFontNames (names);
+	PRIMITIVE_RETURN (result);
+    }
+}
-- 
2.25.1