1 files changed, 137 insertions, 0 deletions
diff --git a/gtk/gentypeinfo.el b/gtk/gentypeinfo.el
new file mode 100644
index 000000000..2de6a92d2
--- /dev/null
+++ b/gtk/gentypeinfo.el
@@ -0,0 +1,137 @@
+(require 'cl)
+
+;;; file access
+
+(defun read-file (name)
+  (let ((buf (generate-new-buffer "infile"))
+	(res nil))
+    (save-excursion
+      (set-buffer buf)
+      (insert-file-contents name)
+      (condition-case nil
+	  (while t
+	    (setq res (cons (read buf) res)))
+	(end-of-file (reverse res))))))
+
+(defun setup-outfile ()
+  (setq standard-output (generate-new-buffer "outfile")))
+
+(defun write-outfile (name)
+  (save-excursion
+    (set-buffer standard-output)
+    (write-region (point-min) (point-max) name)))
+
+;;; string stunts
+
+(defun char-upper-case-p (ch)
+  (eql (upcase ch) ch))
+
+(defun char-lower-case-p (ch)
+  (eql (downcase ch) ch))
+
+(defun canonicalize (str)
+  (if (symbolp str)
+      (setq str (symbol-name str)))
+  (let ((res nil)
+	(start 0)
+	(pos 0)
+	(end (length str))
+	(prevlower nil))
+    (while (< pos end)
+      (let ((ch (elt str pos)))
+	(cond ((memq ch '(?- ?_))
+	       (setq res (cons (substring str start pos) res)
+		     prevlower nil
+		     pos (1+ pos)
+		     start pos))
+	      ((and (char-upper-case-p ch)
+		    prevlower)
+	       (setq res (cons (substring str start pos) res)
+		     start pos
+		     pos (1+ pos)
+		     prevlower nil))
+	      (t
+	       (setq pos (1+ pos)
+		     prevlower (char-lower-case-p ch))))))
+    (reverse (mapcar 'downcase (cons (substring str start end) res)))))
+
+(defun syllables-to-string (syls del)
+  (let ((res ""))
+    (while syls
+      (setq res (format "%s%s%s" res (car syls)
+			(if (cdr syls) del ""))
+	    syls (cdr syls)))
+    res))
+
+(defun macroname (canon)
+  (syllables-to-string (mapcar 'upcase canon) "_"))
+
+(defun funcname (canon)
+  (syllables-to-string canon "_"))
+
+(defun typename (canon)
+  (syllables-to-string (mapcar 'capitalize canon) ""))
+
+(defun scmname (canon)
+  (syllables-to-string canon "-"))
+
+(defun short-name (canon)
+  (if (equal (car canon) "gtk") (cdr canon) canon))
+
+;;; Code generation
+
+(defun printf (&rest args)
+  (princ (apply 'format args)))
+
+(defun interestingp (form)
+  (and (listp form)
+       (memq (car form) '(define-enum define-flags define-boxed))))
+
+(defun map-interesting (func defs)
+  (mapcar #'(lambda (form)
+	      (if (interestingp form)
+		  (funcall func form)))
+	  defs))
+
+(defun emit-idmacs (defs)
+  (let ((i 0))
+    (map-interesting 
+     #'(lambda (form)
+	 (let ((name (canonicalize (cadr form))))
+	   (printf "#define GTK_TYPE_%s (gtk_type_builtins[%d])\n"
+		   (macroname (short-name name)) i))
+	 (setq i (1+ i)))
+     defs)
+    (printf "#define GTK_TYPE_NUM_BUILTINS %d\n" i)))
+
+(defun emit-ids (defs)
+  (map-interesting
+   #'(lambda (form)
+       (printf "  { %S, %s },\n"
+	       (symbol-name (cadr form))
+	       (case (car form)
+		 ((define-enum) "GTK_TYPE_ENUM")
+		 ((define-flags) "GTK_TYPE_FLAGS")
+		 ((define-boxed) "GTK_TYPE_BOXED"))))
+   defs))
+
+       
+       
+(if (< (length command-line-args-left) 3)
+    (error "args: op def-file output-file"))
+
+(setq op (intern (car command-line-args-left)))
+(setq defs (read-file (cadr command-line-args-left)))
+(setq outfile (caddr command-line-args-left))
+(setq command-line-args-left nil)
+
+(setup-outfile)
+(printf "/* generated by gentypeinfo from \"gtk.defs\" */\n\n")
+(case op
+  ((idmac)
+   (emit-idmacs defs))
+  ((id)
+   (emit-ids defs))
+  (else
+   (error "supported ops are: idmac id")))
+(write-outfile outfile)