summaryrefslogtreecommitdiffstats
path: root/inc2scm
diff options
context:
space:
mode:
authorBryan Newbold <bnewbold@robocracy.org>2017-02-20 00:05:25 -0800
committerBryan Newbold <bnewbold@robocracy.org>2017-02-20 00:05:25 -0800
commit3278b75942bdbe706f7a0fba87729bb1e935b68b (patch)
treedcad4048dfc0b38367047426b2b14501bf5ff257 /inc2scm
parentdb04688faa20f3576257c0fe41752ec435beab9a (diff)
downloadscm-3278b75942bdbe706f7a0fba87729bb1e935b68b.tar.gz
scm-3278b75942bdbe706f7a0fba87729bb1e935b68b.zip
Import Upstream version 5d2upstream/5d2
Diffstat (limited to 'inc2scm')
-rwxr-xr-xinc2scm190
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: