Import Upstream version 5d2upstream/5d2

1 files changed, 190 insertions, 0 deletions

diff --git a/inc2scm b/inc2scm
new file mode 100755
index 0000000..58a9540
--- /dev/null
+++ b/inc2scm
@@ -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: