diff options
Diffstat (limited to 'inc2scm')
| -rwxr-xr-x | inc2scm | 190 |
1 files changed, 190 insertions, 0 deletions
@@ -0,0 +1,190 @@ +#! /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. + +;;;; "inc2scm", Convert numeric C #defines to Scheme definitions. +;;; Author: Aubrey Jaffer. + +(define (go-script) + (cond ((not *script*)) + ((< 1 (- (length *argv*) *optind*)) + (apply inc2scm (list-tail *argv* *optind*))) + (else + (display "\ +\ +Usage: inc2scm defines.scm [pre:] [/usr/include/] file1.h file2.h ... +\ + Appends to DEFINES.SCM the Scheme translations of the numeric + #define statements in /USR/INCLUDE/FILE1.H, /USR/INCLUDE/FILE2.H, ... + + PRE: is prepended to those scheme names lacking a prefix. + + /USR/INCLUDE/ defaults to /usr/include/. +" + (current-error-port)) + (exit #f)))) + +(require 'string-search) +(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 sid (< sid 3)) (string-set! nstr sid #\:) + nstr) + (pre (string-append pre (StudlyCaps->dashed-name nstr))) + (else (StudlyCaps->dashed-name nstr))))) + +(define (extract-defineds port) + (define sharp (string #\newline #\#)) + (define defineds '()) + (do ((find? (find-string-from-port? sharp port) + (find-string-from-port? sharp port))) + ((not find?) (reverse defineds)) + (do ((chr (read-char port) (read-char port))) + ((or (eof-object? chr) (not (char-whitespace? chr))) + (and (eqv? chr #\d) + (let ((op #f) (va #f)) + (fscanf port "efine%*[ \t]%s%*[ \t]%s" op va) + (if (and op va + (not (string-index op #\()) + (not (eqv? #\_ (string-ref op 0))) + (not (equal? "int" va))) + (set! defineds (cons op defineds))))))))) + +(define (scm<-includes scmname pre non-local? . filenames) + (define tmpprog "tmpprog") + (call-with-output-file (string-append tmpprog ".c") + (lambda (cport) + (for-each (lambda (filename) + (fprintf cport + (if non-local? + "#include <%s>\\n" + "#include \"%s\"\\n") + filename)) + filenames) + (for-each + (lambda (args) (apply fprintf cport args)) + `(("#include <stdio.h>\\n") + ("void pSl(sname, value)\\n") + (" char sname[];\\n") + (" int value;\\n") + ("{\\n") + ("%s\\n" " printf(\"(define %s %d)\\n\", sname, value);") + ("}\\n") + ("\\n") + ("int main(argc, argv)\\n") + (" int argc;\\n") + (" char *argv[];\\n") + ("{\\n") + )) + (for-each + (lambda (filename) + (if non-local? + (set! filename (string-append non-local? filename))) + (fprintf cport "/* Extract #define values from %s */\\n" filename) + (fprintf cport "%s %s%s\\n" + " printf(\";;inc2scm extracted #define values from" + filename + "\\n\");") + (for-each + (lambda (name) (fprintf cport " pSl(\"%s\", %s);\\n" + (schemeify-name pre name) name)) + (call-with-input-file filename extract-defineds))) + filenames) + (fprintf cport "}\\n"))) + (cond + ((not (zero? (system (sprintf #f "cc -o %s %s.c" tmpprog tmpprog))))) + ((not (zero? (system (sprintf #f "./%s >> %s" tmpprog scmname))))))) + +(define (scm<-usr/includes scmname . filenames) + (define pre (let ((first (car filenames))) + (cond ((substring-ci? ".h" first) #f) + (else (set! filenames (cdr filenames)) first)))) + (define include-path "/usr/include/") + (let* ((first (car filenames))) + (cond ((memv (string-ref first (+ -1 (string-length first))) '(#\\ #\/)) + (set! include-path first) + (set! filenames (cdr filenames))))) + (apply scm<-includes scmname pre include-path filenames) + (delete-file "tmpprog.c") + (delete-file "tmpprog")) +(define inc2scm scm<-usr/includes) + +(define (scm<-h* scmname . filenames) + (define pre (let ((first (car filenames))) + (cond ((substring-ci? ".h" first) first) + (else (set! filenames (cdr filenames)) #f)))) + (apply scm<-includes scmname pre #f filenames) + (delete-file "tmpprog.c") + (delete-file "tmpprog")) +(define h2scm scm<-h*) + +(go-script) + +;;; Local Variables: +;;; mode:scheme +;;; End: |