diff options
Diffstat (limited to 'xgen.scm')
| -rwxr-xr-x | xgen.scm | 176 |
1 files changed, 100 insertions, 76 deletions
@@ -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) |