Import Upstream version 5d2upstream/5d2

1 files changed, 297 insertions, 0 deletions

diff --git a/xgen.scm b/xgen.scm
new file mode 100755
index 0000000..19db1cc
--- /dev/null
+++ b/xgen.scm
@@ -0,0 +1,297 @@
+#! /usr/local/bin/scm \ %0 %1 %2 %3 %4 %5 %6 %7 %8 %9
+- !#
+;; Copyright (C) 1991-1999 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
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+;;
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;; GNU General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with this software; see the file COPYING.  If not, write to
+;; 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.
+;;
+;; The exception is that, if you link the GUILE 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.
+;;
+;; 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
+;; code from other Free Software Foundation releases into a copy of
+;; GUILE, 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
+;; whether to permit this exception to apply to your modifications.
+;; If you do not wish that, delete this exception notice.
+
+;;;; "xgen.scm", Convert C Event structs to xevent.h and xevent.scm.
+;;; Author: Aubrey Jaffer.
+
+(define (go-script)
+  (cond ((not *script*))
+	((>= 1 (- (length *argv*) *optind*))
+	 (apply xgen.scm (list-tail *argv* *optind*)))
+	(else
+	 (display "\
+\
+Usage: xgen.scm /usr/include/X11/Xlib.h
+\
+  Creates xevent.h and xevent.scm, from the `typedef struct's
+  in /usr/include/X11/xlib.h.
+"
+		  (current-error-port))
+	 (exit #f))))
+
+(require 'common-list-functions)
+(require 'string-search)
+(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)
+
+;; SCHEMEIFY-NAME:
+;; * Changes _ to -
+;; * Changes the first - to : if it is within the first 3 characters.
+;; * inserts dashes between `StudlyCaps'
+
+(define (schemeify-name pre name)
+  (define nstr (string-subst name "_" "-"))
+  (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)))))
+
+(define (extract-structs port)
+  (define typedef-struct (string-append (string #\newline) "typedef struct {"))
+  (define structs '())
+  (do ((find? (find-string-from-port? typedef-struct port)
+	      (find-string-from-port? typedef-struct port)))
+      ((not find?) (reverse structs))
+    (set! structs (cons (extract-struct port) structs))))
+
+(define (extract-struct port)
+  (define elts '())
+  (do ((typ (read-token port) (read-token port)))
+      ((or (eof-object? typ) (eq? #\} typ))
+       (let ((name (read-token port)))
+	 (let ((chr (read-token port)))
+	   (cond ((eqv? #\; chr))
+		 (else (slib:error 'expected #\; 'but-read chr)))
+	   (cons name (reverse elts)))))
+    (letrec ((loop
+	      (lambda (name)
+		;;(print 'typ= typ 'name= name)
+		(case name
+		  ((#\*)
+		   (case (string->symbol typ)
+		     ((char) (set! typ "string"))
+		     (else (set! typ (string-append typ "*"))))
+		   (loop (read-token port)))
+		  (else
+		   (let loop2 ((chr (read-token port)))
+		     (case chr
+		       ((#\;)
+			(set! elts (cons (list typ name) elts)))
+		       ((#\,)
+			(set! elts (cons (list typ name) elts))
+			(loop (read-token port)))
+		       ((#\[)
+			(find-string-from-port? "]" port)
+			(case (string->symbol typ)
+			  ((char) (set! typ "string"))
+			  (else (set! typ (string-append typ "*"))))
+			(loop2 (read-token port)))
+		       (else (slib:error 'expected #\; 'read chr))))))
+		)))
+      (case (string->symbol typ)
+	((unsigned)
+	 (set! typ (read-token port))
+	 (case (string->symbol typ)
+	   ((long short char int) (set! typ "int")
+	    (loop (read-token port)))
+	   (else (loop typ))))
+	((struct)
+	 (set! typ (read-token port))
+	 (loop (read-token port)))
+	((union)
+	 (find-string-from-port? close-brace-string port)
+	 ;;(set! typ "union")
+	 (loop (read-token port)))
+	(else (loop (read-token port)))))))
+
+(define close-brace-string (string #\}))
+
+(define (read-token port)
+  (let ((chr (peek-char port)))
+    (cond ((eqv? chr #\newline)
+	   (read-char port)
+	   (do ((fchr (peek-char port) (peek-char port)))
+	       ((not (eqv? #\# fchr)))
+	     (read-char port)
+	     (if (eq? 'if (read port))
+		 (do ((fchr (peek-char port) (peek-char port)))
+		     ((eqv? #\# fchr))
+		   (read-line port)))
+	     (read-line port))
+	   (read-token port))
+	  ((char-whitespace? chr)
+	   (read-char port)
+	   (read-token port))
+	  ((eqv? #\/ chr)
+	   (cond ((and (find-string-from-port? "/*" port)
+		       (find-string-from-port? "*/" port
+					       ;;(lambda (chr) (display chr) #f)
+					       ))
+		  ;;(newline)
+		  (read-token port))
+		 (else
+		  (slib:error 'botched-comment (read-line port)))))
+	  ((or (char-alphabetic? chr) (eqv? #\_ chr))
+	   (car (scanf-read-list "%[a-zA-Z_0-9]" port)))
+	  ;;((string-index "[]*" chr) (string->symbol (string chr)))
+	  (else (read-char port)))))
+
+(defconst Bool (string->symbol "Bool"))
+(defconst Time (string->symbol "Time"))
+
+(define event-map
+  '(
+    ("XMotionEvent"		"MotionNotify")
+    ("XKeyEvent"		"KeyPress"	"KeyRelease")
+    ("XButtonEvent"		"ButtonPress"	"ButtonRelease")
+    ("XPointerMovedEvent"	"MotionNotify")
+    ("XCrossingEvent"		"EnterNotify"	"LeaveNotify")
+    ("XFocusChangeEvent"	"FocusIn"	"FocusOut")
+    ("XKeymapEvent"		"KeymapNotify")
+    ("XExposeEvent"		"Expose")
+    ("XGraphicsExposeEvent"	"GraphicsExpose")
+    ("XNoExposeEvent"		"NoExpose")
+    ("XVisibilityEvent"		"VisibilityNotify")
+    ("XCreateWindowEvent"	"CreateNotify")
+    ("XDestroyWindowEvent"	"DestroyNotify")
+    ("XUnmapEvent"		"UnmapNotify")
+    ("XMapEvent"		"MapNotify")
+    ("XMapRequestEvent"		"MapRequest")
+    ("XReparentEvent"		"ReparentNotify")
+    ("XConfigureEvent"		"ConfigureNotify")
+    ("XConfigureRequestEvent"	"ConfigureRequest")
+    ("XGravityEvent"		"GravityNotify")
+    ("XResizeRequestEvent"	"ResizeRequest")
+    ("XCirculateEvent"		"CirculateNotify")
+    ("XCirculateRequestEvent"	"CirculateRequest")
+    ("XPropertyEvent"		"PropertyNotify")
+    ("XSelectionClearEvent"	"SelectionClear")
+    ("XSelectionRequestEvent"	"SelectionRequest")
+    ("XSelectionEvent"		"SelectionNotify")
+    ("XColormapEvent"		"ColormapNotify")
+    ("XClientMessageEvent"	"ClientMessage")
+    ("XMappingEvent"		"MappingNotify")
+    ))
+
+(define event-fields '())
+(define event-field-idx #x10)
+(define (do-field xevent.scm fname)
+  (define apr (assoc fname event-fields))
+  (cond (apr (cdr apr))
+	(else
+	 (set! event-fields (acons fname event-field-idx event-fields))
+	 (fprintf xevent.scm "(define X-event:%s #x%02x)\n"
+		  (schemeify-name #f fname)
+		  event-field-idx)
+	 (set! event-field-idx (+ 1 event-field-idx))
+	 (+ -1 event-field-idx))))
+
+(define (xgen.scm . filename)
+  (set! filename (if (null? filename) "/usr/include/X11/Xlib.h" (car filename)))
+  (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")))))
+
+(go-script)
+
+;;; Local Variables:
+;;; mode:scheme
+;;; End: