diff options
Diffstat (limited to 'xgen.scm')
| -rwxr-xr-x | xgen.scm | 297 |
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: |