Import Upstream version 5d6upstream/5d6

1 files changed, 100 insertions, 76 deletions

diff --git a/xgen.scm b/xgen.scm
index 19db1cc..6c5bd4b 100755
--- a/xgen.scm
+++ b/xgen.scm
@@ -1,6 +1,6 @@
 #! /usr/local/bin/scm \ %0 %1 %2 %3 %4 %5 %6 %7 %8 %9
 - !#
-;; Copyright (C) 1991-1999 Free Software Foundation, Inc.
+;; Copyright (C) 1991-2000 Free Software Foundation, Inc.
 ;;
 ;; 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
@@ -17,26 +17,26 @@
 ;; the Free Software Foundation, 59 Temple Place, Suite 330, Boston, MA 02111, USA.
 ;;
 ;; As a special exception, the Free Software Foundation gives permission
-;; for additional uses of the text contained in its release of GUILE.
+;; for additional uses of the text contained in its release of SCM.
 ;;
-;; The exception is that, if you link the GUILE library with other files
+;; The exception is that, if you link the SCM library with other files
 ;; to produce an executable, this does not by itself cause the
 ;; resulting executable to be covered by the GNU General Public License.
 ;; Your use of that executable is in no way restricted on account of
-;; linking the GUILE library code into it.
+;; linking the SCM library code into it.
 ;;
 ;; This exception does not however invalidate any other reasons why
 ;; the executable file might be covered by the GNU General Public License.
 ;;
 ;; This exception applies only to the code released by the
-;; Free Software Foundation under the name GUILE.  If you copy
+;; Free Software Foundation under the name SCM.  If you copy
 ;; code from other Free Software Foundation releases into a copy of
-;; GUILE, as the General Public License permits, the exception does
+;; SCM, as the General Public License permits, the exception does
 ;; not apply to the code that you add in this way.  To avoid misleading
 ;; anyone as to the status of such modified files, you must delete
 ;; this exception notice from them.
 ;;
-;; If you write modifications of your own for GUILE, it is your choice
+;; If you write modifications of your own for SCM, it is your choice
 ;; whether to permit this exception to apply to your modifications.
 ;; If you do not wish that, delete this exception notice.
 
@@ -44,8 +44,9 @@
 ;;; Author: Aubrey Jaffer.
 
 (define (go-script)
-  (cond ((not *script*))
+  (cond ;;((not *script*))
 	((>= 1 (- (length *argv*) *optind*))
+	 (xatoms)
 	 (apply xgen.scm (list-tail *argv* *optind*)))
 	(else
 	 (display "\
@@ -60,28 +61,14 @@ Usage: xgen.scm /usr/include/X11/Xlib.h
 
 (require 'common-list-functions)
 (require 'string-search)
+(require 'string-case)
 (require 'line-i/o)
 (require 'printf)
 (require 'scanf)
 
-(define (StudlyCaps->dashed-name nstr)
-  (do ((idx (+ -1 (string-length nstr)) (+ -1 idx)))
-      ((> 2 idx))
-    (cond ((and (char-upper-case? (string-ref nstr (+ -1 idx)))
-		(char-lower-case? (string-ref nstr idx)))
-	   (set! nstr
-		 (string-append (substring nstr 0 (+ -1 idx))
-				"-"
-				(substring nstr (+ -1 idx)
-					   (string-length nstr)))))
-	  ((and (char-lower-case? (string-ref nstr (+ -1 idx)))
-		(char-upper-case? (string-ref nstr idx)))
-	   (set! nstr
-		 (string-append (substring nstr 0 idx)
-				"-"
-				(substring nstr idx
-					   (string-length nstr)))))))
-  nstr)
+(define progname (if (defined? *optind*)
+		     (list-ref *argv* (+ -1 *optind*))
+		     (car (program-arguments))))
 
 ;; SCHEMEIFY-NAME:
 ;; * Changes _ to -
@@ -93,8 +80,8 @@ Usage: xgen.scm /usr/include/X11/Xlib.h
   (let ((sid (string-index nstr #\-)))
     (cond ((and pre sid (< sid 3)) (string-set! nstr sid #\:)
 	   nstr)
-	  (pre (string-append pre (StudlyCaps->dashed-name nstr)))
-	  (else (StudlyCaps->dashed-name nstr)))))
+	  (pre (string-append pre (StudlyCapsExpand nstr)))
+	  (else (StudlyCapsExpand nstr)))))
 
 (define (extract-structs port)
   (define typedef-struct (string-append (string #\newline) "typedef struct {"))
@@ -241,54 +228,91 @@ Usage: xgen.scm /usr/include/X11/Xlib.h
   (let ((structs (remove-if-not
 		  (lambda (struct) (substring? "Event" (car struct)))
 		  (call-with-input-file filename extract-structs))))
-    (call-with-output-file "xevent.h"
-      (lambda (xevent.h)
-	(fprintf xevent.h "/* %s extracted typedef structs from %s */\n"
-		 (car *argv*) filename)
-	(fprintf xevent.h
-		 "#ifdef SCM_EVENT_FIELDS\n")
-	(call-with-output-file "xevent.scm"
-	  (lambda (xevent.scm)
-	    (define evs #f)
-	    (fprintf xevent.scm ";; %s extracted typedef structs from %s\n"
-		     (car *argv*) filename)
-	    (for-each
-	     (lambda (struct)
-	       (define name (car struct))
-	       (set! evs (assoc name event-map))
-	       (and
-		evs
-		(for-each
-		 (lambda (decl)
-		   (define typ (string->symbol (car decl)))
-		   (casev typ
-		     ((,Bool ,Time int char)
-		      (fprintf xevent.h "  ")
-		      (for-each (lambda (event-name)
-				  (fprintf xevent.h "case (%s<<8)+0x%02x: "
-					   event-name
-					   (do-field xevent.scm (cadr decl))))
-				(cdr evs))
-		      (fprintf xevent.h "return %s(((%s *) x)->%s);\n"
-			       (casev typ
-				 ((,Bool) "x_make_bool")
-				 ((,Time) "ulong2num")
-				 ((int char) "MAKINUM"))
-			       name
-			       (cadr decl)))
-		     ;;(else (print 'typ typ))
-		     ))
-		 (cdr struct))))
-	     structs)))
-	(fprintf xevent.h "#else\n")
-	(for-each (lambda (apr)
-		    (for-each (lambda (evnt)
-				(fprintf xevent.h
-					 "  {%-20s \"%s\"},\n"
-					 (string-append evnt ",") evnt))
-			      (cdr apr)))
-		  event-map)
-	(fprintf xevent.h "#endif\n")))))
+    (call-with-open-ports
+     (open-file "xevent.h" "w")
+     (open-file "xevent.scm" "w")
+     (lambda (xevent.h xevent.scm)
+       (define evs #f)
+       (fprintf xevent.h "/* %s extracted typedef structs from %s */\n"
+		progname filename)
+       (fprintf xevent.h
+		"#ifdef SCM_EVENT_FIELDS\n")
+       (fprintf xevent.scm ";; %s extracted typedef structs from %s\n"
+		progname filename)
+       (for-each
+	(lambda (struct)
+	  (define name (car struct))
+	  (set! evs (assoc name event-map))
+	  (and
+	   evs
+	   (for-each
+	    (lambda (decl)
+	      (define typ (string->symbol (car decl)))
+	      (qase typ
+		((,Bool ,Time int char)
+		 (fprintf xevent.h "  ")
+		 (for-each (lambda (event-name)
+			     (fprintf xevent.h "case (%s<<8)+0x%02x: "
+				      event-name
+				      (do-field xevent.scm (cadr decl))))
+			   (cdr evs))
+		 (fprintf xevent.h "return %s(((%s *) x)->%s);\n"
+			  (qase typ
+			    ((,Bool) "x_make_bool")
+			    ((,Time) "ulong2num")
+			    ((int char) "MAKINUM"))
+			  name
+			  (cadr decl)))
+		;;(else (print 'typ typ))
+		))
+	    (cdr struct))))
+	structs)
+       (fprintf xevent.h "#else\n")
+       (for-each (lambda (apr)
+		   (for-each (lambda (evnt)
+			       (fprintf xevent.h
+					"  {%-20s \"%s\"},\n"
+					(string-append evnt ",") evnt))
+			     (cdr apr)))
+		 event-map)
+       (fprintf xevent.h "#endif\n")))))
+
+(define (xatoms)
+  (define /usr/include/X11/Xatom.h "/usr/include/X11/Xatom.h")
+  (define /usr/include/X11/Xcms.h "/usr/include/X11/Xcms.h")
+  (call-with-open-ports
+   (open-file /usr/include/X11/Xatom.h "r")
+   (open-file "/usr/include/X11/Xcms.h" "r")
+   (open-file "xatoms.scm" "w")
+   (lambda (xatom.h xcms.h xatoms.scm)
+     (fprintf xatoms.scm ";; %s extracted definitions from %s\n"
+	      progname /usr/include/X11/Xatom.h)
+     (do ((line (read-line xatom.h) (read-line xatom.h)))
+	 ((eof-object? line))
+       (let ((lst (scanf-read-list "#define XA_%s ((Atom) %d)" line)))
+	 (and (list? lst)
+	      (case (length lst)
+		((2) (fprintf xatoms.scm "(define %s %d)\n"
+			      (string-subst (car lst) "_" "-")
+			      (cadr lst)))
+		((0) #f)		;(write-line line)
+		(else (slib:error 'xatom.h 'line line))))))
+     (fprintf xatoms.scm ";; %s extracted definitions from %s\n"
+	      progname /usr/include/X11/Xcms.h)
+     (do ((line (read-line xcms.h) (read-line xcms.h)))
+	 ((eof-object? line))
+       (let ((lst (scanf-read-list "#define Xcms%s (XcmsColorFormat)0x%4x%4x"
+				   line)))
+	 (and (list? lst)
+	      (case (length lst)
+		((3) (apply fprintf xatoms.scm "(define\tX:%s\t#x%04x%04x)\n"
+			    (string-subst (car lst) "Format" "")
+			    (cdr lst)))
+		((2) (fprintf xatoms.scm "(define\tX:%s\t#x%08x)\n"
+			      (string-subst (car lst) "Format" "")
+			      (cadr lst)))
+		((0 1) #f)
+		(else (slib:error 'xcms.h 'line line)))))))))
 
 (go-script)