[Gnome-devtools] genmarshal.el

["Masatake YAMATO" <masata-y is aist-nara ac jp>]

Hi, 

I've written a small elisp program that generates
gtk_marshal_foo__bar_baz. I've tested genmarshal.el on XEmacs 21.1.

;; genmarshal.el --- Generate marshal function of gtk object system
;;
;; Copyright (C) 2000  Masatake YAMATO
;;
;; Author: Masatake YAMATO <jet gyve org>
;; Created: Mon Jul 31 01:33:02 2000

;; 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 of the License, 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 program; if not, write to the Free Software
;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.

;; Install:
;; (require 'genmarshal)
;; or
;; (autoload 'genmarshal "genmarshal" "Generate marshal function of gtk object system" t)
;; Usage:
;; M-x genmarshal
;;  Function name: gtk_marshal_FLOAT__FLOAT_FLOAT  (e.g.)

(defvar genmarshal-assoc
  '(("NONE" . "void") 
    ("CHAR" . "char")
    ("BOOL" . "gboolean") 
    ("INT" . "gint")
    ("UINT" . "guint") 
    ("LONG" . "glong")
    ("ULONG" . "gulong") 
    ("FLOAT" . "gfloat")
    ("DOUBLE" . "gdouble")
    ("STRING" . "gpointer")
    ("ENUM" . "gint") 
    ("FLAGS" . "gint")
    ("BOXED" . "gpointer")
    ("POINTER" . "gpointer")
    ("OBJECT" . "gpointer")))
(defun genmarshal-trans (key)
  (cdr (assoc key genmarshal-assoc)))

(defun genmarshal (funcname)
  "Insert implementation of given Gtk Marshal function(FUNCNAME). "
  (interactive "sFunction name: ")
  (if (string-match "gtk_marshal_\\([A-Z]+\\)_\\(.+\\)" funcname)
      (let ((RETURN)
	    (ARGS)
	    (RESULT))
	(setq RETURN (match-string 1 funcname))
	(setq ARGS (genmarshal-args-split (match-string 2 funcname)))
	(setq RESULT (genmarshal-generate RETURN funcname ARGS))
	(insert (format "/* Generated automatically by genmarshal.el /*\n"))
	(insert (car RESULT))
	(insert (cdr RESULT)))
    ))

(defun genmarshal-args-split (args-string)
  (let ((args-list))
    (while (string-match "_\\([^_]+\\)\\(.*\\)" args-string)
      (setq args-list (cons 
		       (match-string 1 args-string)
		       args-list))
      (setq args-string (match-string 2 args-string) ))
    (nreverse args-list)))

(defun genmarshal-generate (RETURN FUNCNAME ARGS)
  ;; /* 1. signal-function-return
  ;;    2. signal-function-name
  ;;    3. signal-function-args */
  ;;            1                     2                        3->
  ;; typedef gpointer (*GtkSignal_POINTER__INT_POINTER) (GtkObject *object,
  ;; gint arg1, 						  
  ;; gpointer arg2,
  ;; gpointer user_data);
  ;;
  ;; /* 4. marshal-function-decl 
  ;;    5. marshal-function-name */
  ;; 4->
  ;; void           5
  ;; gtk_marshal_POINTER__INT_POINTER (GtkObject * object,
  ;;				  GtkSignalFunc func,
  ;;				  gpointer func_data,
  ;;				  GtkArg * args)  <-4
  ;;
  ;; {
  ;;   GtkSignal_POINTER__INT_POINTER rfunc; /* marshal-rfunc-decl */
  ;;   gpointer * return_val;                /* marshal-rval-decl */
  ;;   return_val = GTK_RETLOC_POINTER (args[2]); /* marshal-rval-set */
  ;;   rfunc = (GtkSignal_POINTER__INT_POINTER)func; /* marshal-rfunc-set */
  ;;   /* marshal-invoke */
  ;;   (*return_val) = (*rfunc) (object,            
  ;;			    GTK_VALUE_INT (args[0]), /* marshal-args */
  ;;			    GTK_VALUE_POINTER (args[1]),
  ;;			    func_data);
  ;; }
  (let ((signal-function-decl)
	(signal-function-return "")
	(signal-function-type "")
	(signal-function-args "")
	(marshal-function-imp)
	(marshal-function-decl "")
	(marshal-function-name FUNCNAME)
	(marshal-rfunc-decl)
	(marshal-rfunc-set)
	(marshal-rval-decl)
	(marshal-rval-set)
	(marshal-invoke)
	(marshal-invoke-args "")
	(tmp)
	(i 1))
    ;;
    ;; Signal
    ;;
    (setq signal-function-return (genmarshal-trans RETURN))
    (setq signal-function-type (format "GtkSignal_%s_" RETURN))

    (setq tmp ARGS)
    (while tmp
      (setq signal-function-type (format "%s_%s" 
					 signal-function-type
					 (car tmp)))
      (setq tmp (cdr tmp)))

    (setq signal-function-args "GtkObject *object,\n")
    (setq tmp ARGS)
    (while tmp
      (setq signal-function-args (concat signal-function-args
					 (format 
					  "%s arg%d,\n" 
					  (genmarshal-trans(car tmp))
					  i)))
      (setq tmp (cdr tmp))
      (setq i (1+ i)))
    (setq signal-function-args (concat signal-function-args
				       "gpointer user_data"))
    (setq signal-function-decl (format 
				"typedef %s (* %s) (%s);\n"
				signal-function-return
				signal-function-type
				signal-function-args))
    ;;
    ;; Marshal
    ;;
    (setq marshal-function-decl 
	  (format "void\n%s (%s,\n\t%s,\n\t%s,\n\t%s)"
		  marshal-function-name
		  "GtkObject *object"
		  "GtkSignalFunc func"
		  "gpointer func_data"
		  "GtkArg       *args"))
    (setq marshal-rfunc-decl (format "\t%s rfunc;\n" 
				     signal-function-type))
    (setq marshal-rfunc-set  (format "\trfunc = (%s) func;\n"
				     signal-function-type))
    (setq i 0)
    (setq tmp ARGS)
    (while tmp
      (setq marshal-invoke-args (concat 
				 marshal-invoke-args
				 (format 
				  "\tGTK_VALUE_%s(args[%d]),\n"
				  (car tmp) i)))
      (setq tmp (cdr tmp))
      (setq i (1+ i)))
    
    marshal-invoke-args
    (if (string= RETURN "NONE")
	(progn
	  (setq marshal-invoke (format
				"\t(*rfunc) (object,\n%s\tfunc_data);\n"
				marshal-invoke-args))
	  (setq marshal-function-imp
	    (format "%s\n{\n%s%s%s}"
		    marshal-function-decl
		    marshal-rfunc-decl
		    marshal-rfunc-set
		    marshal-invoke))
	  )
      (setq marshal-rval-decl (format "\t%s * return_val;\n"
				      (genmarshal-trans RETURN)))
      (setq marshal-rval-set (format 
			      "\treturn_val = GTK_RETLOC_%s (args[%d]);\n"
			      RETURN (length ARGS)))
      (setq marshal-invoke (format 
			    "\t(*return_val) = (*rfunc) (object,\n%s\tfunc_data);\n"
			    marshal-invoke-args))
      (setq marshal-function-imp
	    (format "%s\n{\n%s%s%s%s%s}"
		    marshal-function-decl
		    marshal-rfunc-decl
		    marshal-rval-decl
		    marshal-rfunc-set
		    marshal-rval-set
		    marshal-invoke)))
    (cons signal-function-decl marshal-function-imp)
    ))

(provide 'genmarshal)
;; genmarshal ends here