summaryrefslogtreecommitdiffstats
path: root/xgen.scm
diff options
context:
space:
mode:
authorBryan Newbold <bnewbold@robocracy.org>2017-02-20 00:05:26 -0800
committerBryan Newbold <bnewbold@robocracy.org>2017-02-20 00:05:26 -0800
commitdeda2c0fd8689349fea2a900199a76ff7ecb319e (patch)
treec9726d54a0806a9b0c75e6c82db8692aea0053cf /xgen.scm
parent3278b75942bdbe706f7a0fba87729bb1e935b68b (diff)
downloadscm-deda2c0fd8689349fea2a900199a76ff7ecb319e.tar.gz
scm-deda2c0fd8689349fea2a900199a76ff7ecb319e.zip
Import Upstream version 5d6upstream/5d6
Diffstat (limited to 'xgen.scm')
-rwxr-xr-xxgen.scm176
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)