summaryrefslogtreecommitdiffstats
path: root/xgen.scm
diff options
context:
space:
mode:
authorJames LewisMoss <dres@debian.org>2000-03-12 09:04:17 -0500
committerBryan Newbold <bnewbold@robocracy.org>2017-02-20 00:05:26 -0800
commit8cfce36c6a4fc2e0a0ab6ef2db66a23cbe462693 (patch)
tree17427e4f777ca85990a449fe939fbae29770b346 /xgen.scm
parenta47af30d2f0e96afcd1f14b1984575c359faa3d6 (diff)
parent3278b75942bdbe706f7a0fba87729bb1e935b68b (diff)
downloadscm-8cfce36c6a4fc2e0a0ab6ef2db66a23cbe462693.tar.gz
scm-8cfce36c6a4fc2e0a0ab6ef2db66a23cbe462693.zip
Import Debian changes 5d2-3debian/5d2-3
scm (5d2-3) unstable frozen; urgency=low * Fix libncurses4-dev -> libncurses5-dev build depend (Closes: #58435) * Fix libreadline2-dev -> libreadline4-dev build depend. * Fix license location in copyright file (lintian warning) * Add tetex-bin as a build depend (needs makeinfo) (Closes: #53197) * Add -isp option to dpkg-gencontrol (lintian error) * Move scm to section interpreters. scm (5d2-2) unstable; urgency=low * Apply patch from upstream for bug in eval.c. (Picked up from comp.lang.scheme) * Add Build-Depends on slib, librx1g-dev, libncurses4-dev, libreadlineg2-dev. * Up standards version. * Correct description: this is an R5RS implementation now * Make sure no optimizations are done on m68k. (Closes: #52434) scm (5d2-1) unstable; urgency=low * New upstream. scm (5d1-2) unstable; urgency=low * Remove TAGS on clean (cut the diff back down to reasonable size). scm (5d1-1) unstable; urgency=low * New upstream. * move stuff to /usr/share. scm (5d0-3) unstable; urgency=low * Change scmlit call to ./scmlit call (missed one) (Fixes bugs #37455 and #35545) * Change man file permissions to 644 (fixes lintian warning) scm (5d0-2) unstable; urgency=low * Removed call to add_final in init_crs. lendwin doesn't do anything and scm was crashing when quit everytime in final_scm. * Changed copyright to reflect new source. scm (5d0-1) unstable; urgency=low * New upstream. * Changed (terms) to access "/usr/doc/copyright/GPL". * Changed regex to use -lrx scm (5c3-6) unstable; urgency=low * New maintainer.
Diffstat (limited to 'xgen.scm')
-rwxr-xr-xxgen.scm297
1 files changed, 297 insertions, 0 deletions
diff --git a/xgen.scm b/xgen.scm
new file mode 100755
index 0000000..bac5668
--- /dev/null
+++ b/xgen.scm
@@ -0,0 +1,297 @@
+#! /usr/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: