;;; Convert a type-specification .EL file into C include files

(require 'cl)

(defun begin-xtfunc-conversion (&optional def-file sym-file)
  (setq def-buffer (find-file-noselect def-file))
  (setq sym-buffer (find-file-noselect sym-file))
  (setq var-buffer (get-buffer-create " xtfunc-var-buffer"))
  (setq type-buffer (get-buffer-create " xtfunc-type-buffer"))
  (save-excursion
    (set-buffer def-buffer)
    (erase-buffer)
    (set-buffer sym-buffer)
    (erase-buffer)
    (set-buffer var-buffer)
    (erase-buffer)
    (set-buffer type-buffer)
    (erase-buffer))
  (setq xtfunc-count 0)
)

(defun end-xtfunc-conversion ()
  (save-excursion
    (let ((string
	   "/*
This file is automatically generated by xtfunc.el, for inclusion into
xtfunc.c.  Don't touch!  Any modifications you make will get wiped out
the next time xtfunc.el is run on the same input file.
*/

"))
    (set-buffer def-buffer)
    (beginning-of-buffer)
    (princ string def-buffer)
    (insert-buffer-substring var-buffer)
    (insert-buffer-substring type-buffer)
    (save-buffer)
    (set-buffer sym-buffer)
    (beginning-of-buffer)
    (princ string sym-buffer)
    (save-buffer))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;; various functions for converting Lisp names to C names.
;; Typically these involve converting dashes to underscores (or removing
;; them), capitalizing words or converting everything to all caps, etc.

; remove the dashes from a string
(defun string-to-c-no-underscore (str)
  (mapconcat '(lambda (x) (if (eq x ?-) "" (char-to-string x))) str ""))

; convert dashes to underscores
(defun string-to-c (str)
  (mapconcat '(lambda (x) (if (eq x ?-) "_" (char-to-string x))) str ""))

; convert to "caps" C format (i.e. capitalize each word and remove dashes)
(defun string-to-c-caps (str)
  (string-to-c-no-underscore (capitalize str)))

; same as string-to-c-caps but don't capitalize first word
(defun string-to-c-caps-no-first (str)
  (let ((s (string-to-c-caps str)))
    (concat (downcase (substring s 0 1)) (substring s 1))))

; convert to "manifest constant" C format (i.e. all caps, convert
; dashes to underscores)
(defun string-to-c-constant (str)
  (upcase (string-to-c str)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

; for type names, the following properties are defined:
;
;     type-c-struct = string specifying name of corresponding xtf_type
;                     struct (usually "xxxx_type_" plus the type name)

(defun next-number () (prog1 xtfunc-count (setq xtfunc-count
						(1+ xtfunc-count))))

(defun type-equiv (x y)
  (put x 'type-equiv y))

(defun parse-structure (s)
  (mapcar (function
	   (lambda (car)
	     (if (consp car) car
	      (cond ((get 'struct-equiv car))
		    (t (signal 'error
			       (list (gettext "Invalid structure element")
				     car)))))))
	  s))

(defun typedef-struct (x y)
  (put x 'struct-equiv (parse-structure y)))

(defun type-parse (type)
  (let ((equiv (and (symbolp type) (get type 'type-equiv))))
    (if equiv (type-parse equiv)
      (let* ((tag (if (consp type) (car type) type))
	     (data (if (consp type) (cdr type) nil))
	     (c-struct (format "xxxx_type_%d" (next-number)))
	     (result (if (get tag 'has-data)
			 (concat "(XtArgVal) &"
				 (funcall (intern (concat "process-"
							  (symbol-name tag)))
					  data))
		       "0"))
	     (class-struct
	      (cond ((get tag 'type-class-struct))
		    (t (signal 'error
			       (list (gettext "Undefined type class")
				     tag))))))
	(princ (format "xtf_type %s = {&%s, %s};\n"
		       c-struct class-struct result)
	       type-buffer)
	c-struct))))

(defun parse-properties (properties c-name)
  (list (if (memq 'no-l2c properties) "NULL"
	  (format "L2C_%s" c-name))
	(if (memq 'no-c2l properties) "NULL"
	  (format "C2L_%s" c-name))
	(if (memq 'stage2 properties) (format "stage2_%s" c-name)
	  "NULL")
	(memq 'slot properties)
	(memq 'data properties)
))

(defun typedef (type &rest properties)
  (let* ((c-name (string-to-c (symbol-name type)))
	 (c-struct (format "xxxx_type_class_%s" c-name))
	 (converters (parse-properties properties c-name)))
    (princ (format "xtf_type_class %s = { %s, %s, %s, \"%s\", {%d}};\n"
		   c-struct
		   (first converters)
		   (second converters)
		   (third converters)
		   c-name
		   (if (fourth converters) 1 0))
	   type-buffer)
    (put type 'type-class-struct c-struct)
    (if (fifth converters) (put type 'has-data t))
))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;; Process an enum quantifier list.
;; For a specification 'drag-drop, output in the appropriate places:
;;   1. static Lisp_Object Qdrag_drop;
;;   2. { Qdrag_drop, XmDRAG_DROP },
;;   3. Qdrag_drop = intern("drag-drop");

(defun process-enum (list)
  (process-enum-1 list 'enum))

(defun process-set (list)
  (process-enum-1 list 'set))

(defun process-enum-1 (list type)
  (let* ((count 0)
	 (id (if (eq type 'set) "set" "enum"))
	 (num (next-number))
	 (data-struct (format "xxxx_%s_%d" id num))
	 (spec-struct (format "xxxx_%s_spec_%d" id num)))
    (princ (format "xtf_%s_spec %s[] = {\n" id spec-struct)
	   type-buffer)
    (while list
      (let* ((car (car list))
	     (lisp-name (symbol-name (if (consp car) (car car) car)))
	     (c-enum (if (and (consp car) (not (null (second car))))
			 (symbol-name (second car))
		       (concat "Xm" (string-to-c-constant lisp-name))))
	     (mask (if (consp car) (third car) c-enum)))
	(princ (format "  {0, %s%s},\n" c-enum
		       (if (eq type 'set) (concat ", " mask) ""))
	       type-buffer)
	(princ (format "  %s[%d].lisp = intern(\"%s\");\n"
		       spec-struct count lisp-name)
	       sym-buffer)
      (setq list (cdr list))
      (setq count (1+ count))))
    (princ (format "};

xtf_%s %s = { %d, %s };

" id data-struct count spec-struct) type-buffer)
    (princ "\n" sym-buffer)
    data-struct))

(defun process-list (list)
  (let ((type-struct (type-parse (first list)))
	(numr (if (null (second list)) "NULL" (second list)))
	(struct (format "xxxx_list_%d" (next-number))))
    (princ (format "xtf_list %s = { &%s, %s };\n"
		   struct type-struct numr)
	   type-buffer)
    struct))
  
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun get-access-value (access)
  (get-access-value-1
   (if (not (or (memq 'c access) (memq 's access) (memq 'g access)))
       (append '(c s g) access)
     access)
   nil))

(defun get-access-value-1 (access join)
  (cond ((null access) nil)
	(t (concat join 
		(case (car access)
		  ('d "access_no_def")
		  ('c "access_create")
		  ('s "access_set")
		  ('g "access_get"))
		(get-access-value-1 (cdr access) "|")))))
	
(defun defwidget (class super-class resource-list)
  (let* ((count 0)
	 (lisp-widget-class (symbol-name class))
	 (c-widget-class (string-to-c-caps lisp-widget-class))
	 (lisp-var-widget-class (concat "Q" c-widget-class))
	 (c-resource-struct (format "xxxx_resource_spec_%s" c-widget-class)))
    (princ (format "xtf_resource_spec %s[] = {\n"
		   c-resource-struct) def-buffer)
    (while resource-list
      (let* ((spec (car resource-list))
	     (spec1 (first spec))
	     (lisp-name (symbol-name (if (consp spec1) (first spec1) spec1)))
	     (lisp-class (if (consp spec1) (symbol-name (second spec1))
			   (concat (capitalize (substring lisp-name 0 1))
				   (substring lisp-name 1))))
	     (lisp-var-class (concat "Q" (string-to-c lisp-class)))
	     (c-name (string-to-c-caps-no-first lisp-name))
	     (c-class (string-to-c-caps lisp-class))
	     (c-type-struct (type-parse (second spec)))
	     (access (get-access-value (third spec))))
	(princ (format "  { NULL, NULL, \"%s\", \"%s\", &%s, %s },\n"
		       c-name c-class
		       c-type-struct access) def-buffer)
	(princ (format "  %s[%d].lisp_name = intern (\"%s\");\n"
		       c-resource-struct count lisp-name)
	       sym-buffer)
	(princ (format "  %s[%d].lisp_class = %s;\n"
		       c-resource-struct count "Qnil") ; lisp-var-class
	       sym-buffer)
	(setq count (1+ count))
	(setq resource-list (cdr resource-list))))
    (princ "};\n\n" def-buffer)
    (princ (format "static Lisp_Object %s;\n" lisp-var-widget-class)
	   var-buffer)
    (princ (format "\n  %s = intern(\"%s\");\n"
		   lisp-var-widget-class
		   lisp-widget-class) sym-buffer)
    (princ (format (concat "  Fset (%s, classobj = make_widget_class "
			   "(Qnil, %s, %sWidgetClass, %d, %s));\n")
		   lisp-var-widget-class
		   lisp-var-widget-class
		   (string-to-c-caps-no-first c-widget-class)
		   count
		   c-resource-struct) sym-buffer)
    (princ (format "struct Lisp_Widget_Class *xxxx_class_%s;\n\n"
		   c-widget-class) var-buffer)
    (princ (format "  xxxx_class_%s = XWIDGET_CLASS (classobj);\n"
		   c-widget-class) sym-buffer)
    (princ "\n" sym-buffer)
))
