#! /bin/sh
# -*- scheme -*-
exec guile -s $0 $*
!#

;;	Copyright (C) 1997 Marius Vollmer
;; 
;; 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, 675 Mass Ave, Cambridge, MA 02139,
;; USA.

(use-modules (ice-9 slib) (ice-9 common-list))
(require 'format)

;; Get verbose error reporting. If you feel this looks much too
;; involved, you are right.

(define-public (call-with-error-catching thunk . opt-label)
  (let ((label (and (pair? opt-label) (car opt-label)))
	(the-last-stack #f)
	(stack-saved? #f))
    
    (define (handle-error key args)
      (let ((cep (current-error-port)))
	(if label (begin
		    (display label cep)
		    (newline cep)))
	(if the-last-stack
	    (display-backtrace the-last-stack cep)
	    (display "no backtrace available.\n" cep))
	(apply display-error the-last-stack cep args)
	(force-output cep)
	(throw 'abort key)))

    (define (save-stack)
      (cond (stack-saved?)
	    ((not (memq 'debug (debug-options-interface)))
	     (set! the-last-stack #f)
	     (set! stack-saved? #t))
	    (else
	     (set! the-last-stack (make-stack #t lazy-dispatch 4))
	     (set! stack-saved? #t))))

    (define (lazy-dispatch key . args)
      (save-stack)
      (apply throw key args))

    (start-stack #t
		 (catch #t
			(lambda ()
			  (lazy-catch #t
				      thunk
				      lazy-dispatch))
			(lambda (key . args)
			  (if (= (length args) 4)
			      (handle-error key args)
			      (apply throw key args)))))))

(define-macro (with-error-catching . body)
  `(call-with-error-catching (lambda () ,@body)))

(define (read-file name)
  (with-input-from-file name
    (lambda ()
      (let loop ((res '())
		 (obj (read)))
	(if (eof-object? obj)
	    (reverse res)
	    (loop (cons obj res) (read)))))))

(define (->string obj)
  (cond ((symbol? obj)
	 (symbol->string obj))
	((string? obj)
	 obj)
	(else
	 (error "only strings or symbols" obj))))

(define (@ fmt . args)
  (apply format #t fmt args))

(define (@@ fmt . args)
  (apply format #f fmt args))

;; string stunts

(define (string-map thunk str)
  (list->string (map thunk (string->list str))))

(define (string-upcase str)
  (string-map char-upcase str))

(define (string-downcase str)
  (string-map char-downcase str))

(define (string-capitalize str)
  (let ((newstr (string-copy str)))
    (cond ((> (string-length newstr) 0)
	   (string-set! newstr 0 (char-upcase (string-ref newstr 0)))))
    newstr))

(define (canonicalize str)
  (let loop ((res '())
	     (cur "")
	     (chars (string->list str))
	     (prevlower #f))
    (cond ((null? chars)
	   (reverse (cons cur res)))
	  ((or (char=? (car chars) #\-)
	       (char=? (car chars) #\_))
	   (loop (cons cur res) "" (cdr chars) #f))
	  ((and (char-upper-case? (car chars))
		prevlower)
	   (loop (cons cur res) "" chars #f))
	  (else
	   (loop res (string-append cur 
				    (string (char-downcase (car chars))))
		 (cdr chars) (char-lower-case? (car chars)))))))

(define (syllables->string syls del)
  (cond ((null? syls)
	 "")
	((null? (cdr syls))
	 (car syls))
	(else
	 (string-append (car syls) del
			(syllables->string (cdr syls) del)))))

(define (macroname canon)
  (syllables->string (map string-upcase canon) "_"))

(define (funcname canon)
  (syllables->string canon "_"))

(define (typename canon)
  (syllables->string (map string-capitalize canon) ""))

(define (scmname canon)
  (syllables->string canon "-"))

(define (defined-name form)
  (if (and (pair? form) (pair? (cdr form)) (symbol? (cadr form)))
      (canonicalize (cadr form))
      (error "unsupported definition" form)))

(define (short-name name)
  (if (string=? (car name) "gtk") (cdr name) name))  

;; details

(define undeferred-functions '())
(define type-conversions '())

(define (read-detail-file name)
  (let loop ((details (read-file name)))
    (cond ((null? details))
	  ((not (pair? (car details)))
	   (loop (cdr details)))
	  ((eq? (caar details) 'undeferred)
	   (set! undeferred-functions (append (cdar details)
					      undeferred-functions))
	   (loop (cdr details)))
	  ((eq? (caar details) 'type-conversion)
	   (set! type-conversions (cons (cdar details)
				       type-conversions))
	   (loop (cdr details)))
	  (else
	   (loop (cdr details))))))

(define (undeferred? sym)
  (memq sym undeferred-functions))

(define (type-conversion sym)
  (let ((f (assq sym type-conversions)))
    (and f (cdr f))))

;; emitters

(define (emit-enum/flags-info defs)

  (define (emit-lits form)
    (if (memq (car form) '(define-enum define-flags))
	(let* ((name (defined-name form))
	       (literals (cddr form))
	       (nlits (length literals)))
	  (@ "static sgtk_enum_literal _~a_literals[~a] = {~%"
	     (funcname name) nlits)
	  (for-each (lambda (lit)
		      (@ "  { ~s, ~a },~%"
			 (->string (car lit)) (cadr lit)))
		    literals)
	  (@ "};~%~%"))))

  (define (emit-enum/flags-map kind tag)
    (@ "sgtk_enum_info sgtk_~a_infos[] = {~%" kind)
    (for-each (lambda (form)
		(if (eq? (car form) tag)
		    (let ((name (defined-name form)))
		      (@ "  { ~s, ~a, _~a_literals },~%"
			 (typename name)
			 (length (cddr form))
			 (funcname name)))))
	      defs)
    (@ "  { NULL }~%};~%~%"))

  (for-each emit-lits defs)
  (emit-enum/flags-map "enum" 'define-enum)
  (emit-enum/flags-map "flags" 'define-flags))

(define (emit-boxed-info defs)
  (@ "sgtk_boxed_info sgtk_boxed_infos[] = {~%")
  (for-each (lambda (form)
	      (if (eq? (car form) 'define-boxed)
		  (let ((name (defined-name form))
			(copy (caddr form))
			(destroy (cadddr form))
			(size (if (> (length form) 4) (list-ref form 4) "0")))
		    (@ "  { ~s,~%" (typename name))
		    (@ "    (void *(*)(void*))~a,~%" copy)
		    (@ "    (void (*)(void*))~a,~%" destroy)
		    (@ "    ~a },~%" size))))
	    defs)
  (@ "  { NULL }~%};~%~%"))

(define (emit-infomac defs)
  (let loop ((n-enums 0)
	     (n-flags 0)
	     (n-boxed 0)
	     (defs defs))
    (cond ((null? defs))
	  ((eq? (caar defs) 'define-enum)
	   (@ "#define sgtk_~a_info (sgtk_enum_infos[~a])~%"
	      (funcname (short-name (defined-name (car defs))))
	      n-enums)
	   (loop (1+ n-enums) n-flags n-boxed (cdr defs)))
	  ((eq? (caar defs) 'define-flags)
	   (@ "#define sgtk_~a_info (sgtk_flags_infos[~a])~%"
	      (funcname (short-name (defined-name (car defs))))
	      n-flags)
	   (loop n-enums (1+ n-flags) n-boxed (cdr defs)))
	  ((eq? (caar defs) 'define-boxed)
	   (@ "#define sgtk_~a_info (sgtk_boxed_infos[~a])~%"
	      (funcname (short-name (defined-name (car defs))))
	      n-boxed)
	   (loop n-enums n-flags (1+ n-boxed) (cdr defs)))
	  (else
	   (loop n-enums n-flags n-boxed (cdr defs))))))

(define (emit-idmacs defs)
  (let loop ((i 0)
	     (defs defs))
    (if (pair? defs)
	(let ((form (car defs)))
	  (if (and (pair? form) 
		   (memq (car form) '(define-enum define-flags define-boxed)))
	      (let* ((name (defined-name form))
		     (sname (short-name name)))
		(@ "#define GTK_TYPE_~a (gtk_type_builtins[~a])~%"
		   (macroname sname) i)
		(loop (1+ i) (cdr defs)))
	      (loop i (cdr defs))))
	(@ "#define GTK_TYPE_NUM_BUILTINS ~a~%" i))))

(define (emit-ids defs)
  (for-each (lambda (form)
	      (if (and (pair? form) 
		       (memq (car form)
			     '(define-enum define-flags define-boxed)))
		  (let ((name (cadr form)))
		    (@ "  { ~s, ~a },~%" 
		       (->string name)
		       (case (car form)
			 ((define-enum) "GTK_TYPE_ENUM")
			 ((define-flags) "GTK_TYPE_FLAGS")
			 ((define-boxed) "GTK_TYPE_BOXED"))))))
	    defs))

(define (emit-idfuncproto form)
  (if (pair? form)
      (case (car form)
	((define-enum define-flags define-boxed)
	 (let ((name (defined-name form)))
	   (@ "GtkType ~a_get_typeid ();~%" (funcname name)))))))

(define (emit-idfunc form)
  (define (emit-flags/enum/boxed name kind)
    (let ((sname (short-name name)))
      (@ "GtkType~%~a_get_typeid ()~%" (funcname name))
      (@ "{~%")
      (@ "  static GtkType type = GTK_TYPE_INVALID;~%")
      (@ "  if (type == GTK_TYPE_INVALID)~%")
      (@ "     type = gtk_type_register_~a (~s);~%"
	 kind (typename name))
      (@ "  return type;~%")
      (@ "}~%~%")))
  (define name (defined-name form))
  (if (pair? form)
      (case (car form)
	((define-enum)
	 (emit-flags/enum/boxed name "enum"))
	((define-flags)
	 (emit-flags/enum/boxed name "flags"))
	((define-boxed)
	 (emit-flags/enum/boxed name "boxed"))
	(else
	 (error "unsupported definition" form)))))

(define (emit-funcs defs)

  (define (make-type ctype isa scm2c c2scm . opt-c2args)
    (if (null? opt-c2args)
	(make-type ctype isa scm2c c2scm id)
	(vector ctype isa scm2c c2scm (car opt-c2args))))

  (define (type-cname t) (vector-ref t 0))
  (define (type-isa t x) ((vector-ref t 1) x))
  (define (type-scm2c t x) ((vector-ref t 2) x))
  (define (type-c2scm t x) ((vector-ref t 3) x))
  (define (type-c2args t x) ((vector-ref t 4) x))

  (define types '())
  (define (register-type sym def)
    (set! types (acons sym def types)))
  (define (lookup-type sym)
    (let ((cell (assq sym types)))
      (if cell (cdr cell) (error "unknown type" sym))))

  (define (get-opt opts sym)
    (let loop ((opts opts))
      (cond ((null? opts)
	     #f)
	    ((eq? (caar opts) sym)
	     (car opts))
	    (else
	     (loop (cdr opts))))))

  (define (get-opt-val opts sym def)
    (let ((opt (get-opt opts sym)))
      (if opt (cadr opt) def)))

  (define (short-func-name canon)
    (if (string=? (car (last-pair canon)) "interp")
	(butlast canon 1)
	canon))

  (define (emit-func ret name parms scm-name defer? emit-body)
    (let* ((sname (short-name name))
	   (fname (short-func-name name))
	   (rtype (lookup-type ret))
	   (ptypes (map (lambda (p)
			  (lookup-type (car p)))
			parms))
	   (n-parms (length parms))
	   (n-opt 0))
      (for-each (lambda (p)
		  (if (not (get-opt (cddr p) '=))
		      (if (> n-opt 0)
			  (error "defaulted parameters must come at the end"))
		      (set! n-opt (1+ n-opt))))
		parms)
      (@ "SCM_PROC (s_~a, ~s, ~a, ~a, 0, sgtk_~a);~%"
	 (funcname name) (if scm-name scm-name (scmname fname))
	 (- n-parms n-opt) n-opt (funcname sname))
      (@ "SCM~%")
      (@ "sgtk_~a (~a)~%" 
	 (funcname sname)
	 (syllables->string (map (lambda (p) 
				   (string-append "SCM p_" (cadr p)))
				 parms) ", "))
      (@ "{~%")
      (if (not (eq? ret 'none))
	  (@ "  ~a c_ret;~%" (type-cname rtype)))
      (for-each (lambda (t p)
		  (@ "  ~a c_~a;~%" (type-cname t) (cadr p)))
		ptypes parms)
      (for-each (lambda (p)
		  (let ((conv (type-conversion (car p))))
		    (if conv
			(@ "  p_~a = ~a (p_~a);~%" 
			   (cadr p) (car conv) (cadr p)))))
		parms)
      (let ((i 1))
	(for-each (lambda (t p)
		    (let* ((n (cadr p))
			   (p_n (string-append "p_" n)))
		      (if (get-opt (cddr p) '=)
			  (@ "  if (p_~a != SCM_UNDEFINED)~%  " n))
		      (@ "  SCM_ASSERT (~a~a, "
			 (if (get-opt (cddr p) 'null-ok)
			     (@@ "~a == SCM_BOOL_F || " p_n) "")
			 (type-isa t (string-append "p_" n)))
		      (@ "p_~a, SCM_ARG~a, s_~a);~%"
			 n (if (< i 8) i "n") (funcname name))
		      (set! i (1+ i))))
		  ptypes parms))
      (if defer?
	  (@ "~%  SCM_DEFER_INTS;~%"))
      (for-each (lambda (t p)
		  (let ((n (cadr p)))
		      (cond
		       ((get-opt (cddr p) '=)
			(@ "  if (p_~a == SCM_UNDEFINED)~%" n)
			(@ "    c_~a = ~a;~%"  n (get-opt-val (cddr p) '= #f))
			(@ "  else~%  ")))
		      (@ "  c_~a = ~a;~%"
			 n (type-scm2c t (string-append "p_" n)))))
		ptypes parms)
      (@ "  ")
      (emit-body (if (eq? ret 'none) #f "c_ret")
		 (map (lambda (p t)
			(type-c2args
			 t (string-append "c_" (cadr p))))
		      parms ptypes))
      (if defer?
	  (@ "  SCM_ALLOW_INTS;~%"))
      (@ "~%  return ~a;~%}~%~%" (type-c2scm rtype "c_ret"))))

  (define (emit-defined-func form)
    (let ((name  (cadr form))
	  (ret   (caddr form))
	  (parms (cdddr form)))
      (emit-func ret (canonicalize name) parms #f (not (undeferred? name))
		 (lambda (cret cparms)
		   (@ "~a~a (~a);~%" 
		      (if cret (string-append cret " = ") "")
		      name (syllables->string cparms ", "))))))

  (define (emit-object-predicate sym)
    (let ((type (lookup-type sym))
	  (name (canonicalize sym)))
      (emit-func 'bool (append name '("p")) '((SCM obj)) 
		 (string-append (scmname name) "?") #f
		 (lambda (cret cparms)
		   (@ "~a = ~a;" cret (type-isa type (car cparms)))))))

  (define (emit-field-accessors typesym fields)
    (define typename (canonicalize typesym))
    (define (emit-accessor field)
      (let* ((ret (car field))
	     (fieldsym (cadr field))
	     (name (append typename (canonicalize fieldsym))))
	(emit-func ret name `((,typesym obj)) #f #f
		   (lambda (cret cparms)
		     (@ "~a = ~a->~a;~%" cret (car cparms) fieldsym)))))
    (for-each emit-accessor fields))

  (define (info-name name)
    (string-append "sgtk_" 
		   (funcname (short-name (canonicalize name)))
		   "_info"))

  (define (register-enum-converter name kind)
    (let ((iname (info-name name)))
      (register-type 
       name
       (make-type name
		  (lambda (x)
		    (@@ "sgtk_valid_~a (~a, &~a)" kind x iname))
		  (lambda (x)
		    (@@ "sgtk_scm2~a (~a, &~a)" kind x iname))
		  (lambda (x)
		    (@@ "sgtk_~a2scm (~a, &~a)" kind x iname))))))

  (define (register-boxed-converter name copy)
    (let ((iname (info-name name))
	  (sname (string-append name "*")))
      (register-type 
       name
       (make-type sname
		  (lambda (x)
		    (@@ "sgtk_valid_boxed (~a, &~a)" x iname))
		  (lambda (x)
		    (@@ "(~a)sgtk_scm2boxed (~a)" sname x))
		  (lambda (x)
		    (@@ "sgtk_boxed2scm (~a, &~a~a)"
			    x iname (if copy ", 1" ", 0")))))))

  (define (register-object-type name)
    (let ((tname (string-append (funcname (canonicalize name))
				"_get_type ()")))
      (register-type
       name
       (make-type (string-append name "*")
		  (lambda (x)
		    (@@ "sgtk_is_a_gtkobj (~a, ~a)" tname x))
		  (lambda (x)
		    (@@ "(~a*)sgtk_get_gtkobj (~a)" name x))
		  (lambda (x)
		    (@@ "sgtk_wrap_gtkobj ((GtkObject*)~a)" x))))))

  (@ "#include <libguile.h>~%")
  (@ "#include <gtk/gtk.h>~%~%")
  (@ "#include \"guile-gtk.h\"~%")
  (@ "#include \"gtk-compat.h\"~%")
  (@ "#include \"gtk-types.h\"~%~%")

  (register-type
   'none 
   (make-type "void"
	      (lambda (x) (error "can't pass `none' type"))
	      (lambda (x) (error "can't pass `none' type"))
	      (lambda (x) "SCM_UNSPECIFIED")))

  (register-type
   'SCM
   (make-type "SCM" (lambda (x) "TRUE") id id))

  (register-type 
   'string 
   (make-type "char*"
	      (lambda (x) 
		(@@ "(SCM_NIMP(~a) && SCM_STRINGP(~a))" x x))
	      (lambda (x) 
		(@@ "((~a) == SCM_BOOL_F? NULL : SCM_CHARS(~a))" x x))
	      (lambda (x) 
		(error "strings can't be returned yet."))))

  (register-type 
   'static_string 
   (make-type "char*"
	      (lambda (x) 
		(error "can't pass `static-string' type"))
	      (lambda (x) 
		(error "can't pass `static-string' type"))
	      (lambda (x) 
		(@@ "(~a == NULL? SCM_BOOL_F : scm_makfrom0str (~a))" x x))))

  ; XXX
  (register-type 
   'int 
   (make-type "int"
	      (lambda (x) 
		(@@ "SCM_INUMP (~a)" x))
	      (lambda (x) 
		(@@ "SCM_INUM (~a)" x))
	      (lambda (x) 
		(@@ "SCM_MAKINUM (~a)" x))))

  ; XXX
  (register-type 
   'uint 
   (make-type "unsigned int"
	      (lambda (x) 
		(@@ "SCM_INUMP (~a)" x))
	      (lambda (x) 
		(@@ "SCM_INUM (~a)" x))
	      (lambda (x) 
		(@@ "SCM_MAKINUM (~a)" x))))

  (register-type 
   'float 
   (make-type "gfloat"
	      (lambda (x) 
		(@@ "sgtk_valid_float (~a)" x))
	      (lambda (x) 
		(@@ "sgtk_scm2float (~a)" x))
	      (lambda (x) 
		(@@ "sgtk_float2scm (~a)" x))))

  (register-type 
   'bool 
   (make-type "int"
	      (lambda (x) 
		; XXX should accept every object
		(@@ "((~a) == SCM_BOOL_T || (~a) == SCM_BOOL_F)" x x))
	      (lambda (x) 
		(@@ "SCM_NFALSEP (~a)" x))
	      (lambda (x) 
		(@@ "((~a)? SCM_BOOL_T : SCM_BOOL_F)" x))))

  (register-type
   'callback
   (make-type "SCM"
	      (lambda (x)
		(@@ "(scm_procedure_p(~a) == SCM_BOOL_T)" x))
	      (lambda (x)
		(@@ "sgtk_protect_scm (~a)" x))
	      (lambda (x)
		(error "can't return a `callback'"))
	      (lambda (x)
		(@@ "sgtk_callback_marshal, (gpointer)~a, sgtk_callback_destroy" x))))
	      
  (register-object-type 'GtkObject)

  (for-each (lambda (form)
	      (let ((name (cadr form)))
		(case (car form)
		  ((define-enum)
		   (register-enum-converter name "enum"))
		  ((define-flags)
		   (register-enum-converter name "flags"))
		  ((define-boxed)
		   (register-boxed-converter name #t))
		  ((define-object)
		   (register-object-type name)
		   (emit-object-predicate name)
		   (let ((fields (get-opt (cddr form) 'fields)))
		     (if fields
			 (emit-field-accessors name (cdr fields)))))
		  ((define-func)
		   (emit-defined-func form)))))
	    defs)

  (@ "void~%sgtk_init_gtk_defs ()~%")
  (@ "{~%#include \"gtk-funcs.x\"~%")
  (@ "}~%"))

;; main

(if (< (length (program-arguments)) 4)
    (error "usage: gen-typeinfo op def-file detail-file"))

(define opsym (string->symbol (cadr (program-arguments))))
(define defs-file (caddr (program-arguments)))
(define detail-file (cadddr (program-arguments)))

(define defs (read-file defs-file))
(read-detail-file detail-file)

(@ "/* Generated by gen-typeinfo ~a from ~s. */~%~%" opsym defs-file)

(with-error-catching
  (case opsym
    ((info)
     (@ "#include <gtk/gtk.h>~%")
     (@ "#include \"guile-gtk.h\"~%")
     (@ "#include \"gtk-compat.h\"~%~%")
     (emit-enum/flags-info defs)
     (emit-boxed-info defs))
    ((infomac)
     (emit-infomac defs))
    ((idmac)
     (emit-idmacs defs))
    ((id)
     (emit-ids defs))
    ((func)
     (emit-funcs defs))
    (else
     (error "unknown operation"))))
