;; -*-theme-d-*-

;; Copyright (C) 2015-2020 Tommi Höynälänmaa

(define-proper-program generate-theme-d-code

  (import (standard-library core)
	  (standard-library string-utilities)
	  (standard-library list-utilities)
	  (standard-library system)
	  (standard-library text-file-io)
	  (standard-library console-io)
	  (standard-library object-string-conversion)
	  (standard-library dynamic-list)
	  (standard-library hash-table))

  (define flush-all-ports
    (prim-proc flush-all-ports () <none> nonpure))

  (define-simple-proc disp (((o <object>)) <none> nonpure)
    (console-display o)
    (console-newline)
    (flush-all-ports))

  (define debug? #f)

  (define-simple-proc dw (((obj <object>)) <none> nonpure)
    (if debug? (console-display obj)))

  (define-simple-proc dwl (((obj <object>)) <none> nonpure)
    (if debug? (disp obj)))

  (define-simple-proc dwl2 (((obj <object>)) <none> nonpure)
    null)

  (define <my-hash-table> (:string-hash-table <integer>))

  (define-class <target-module>
    (inheritance-access hidden)
    (fields
     (str-name <string> public public)
     (ht-explicit (:string-hash-table <string>) public public)
     (ht-ignored <my-hash-table> public public)
     (str-ignored-pattern <string> public public "")
     (ht-ignored-types <my-hash-table> public public)
     (ht-overridden <my-hash-table> public public)))

  (define <module-name> (:union <symbol> (:nonempty-uniform-list <symbol>)))

  (define-class <translator>
    (inheritance-access hidden)
    (fields
     (mod-current (:maybe <target-module>) public public null)
     (ht-flags-and-enums (:string-hash-table <symbol>) public public)
     (ht-interfaces <my-hash-table> public public)
     (ht-no-methods (:string-hash-table (:uniform-list <string>)) public public)
     (ht-no-creators <my-hash-table> public public)
     (lst-toplevel-imports (:uniform-list <string>) public public null)
     (lst-external-imports (:uniform-list <module-name>) public public null)
     (processing-source? <boolean> public public #f)
     (s-toplevel-mode <symbol> public public)
     (lst-source-path (:uniform-list <string>) public public)
     (str-mod-path <string> public public)
     (str-override-path <string> public public)
     (str-default-parent <string> public public)
     (str-current-unit <string> public public "")
     (op <output-port> public public)
     (op-statistics (:maybe <output-port>) public public)))

  (define-mutable gl-translator (:maybe <translator>) null)

  (define <raw-param> (:tuple <symbol> (:pair <string>
					      (:pair <string> <object>))))
  
  (define str-small-letters "abcdefghijklmnopqrstuvwxyz")

  (define str-capital-letters "ABCDEFGHIJKLMNOPQRSTUVWXYZ")

  (define gl-str-pred "-new")

  (define gl-i-pred-len 4)

  (define-simple-proc warning (((str-msg <string>)) <none> nonpure)
    (console-display "warning: ")
    (console-display str-msg)
    (console-newline))

  (define-simple-proc compute-file-path
      (((str-path <string>) (str-name <string>)) <string> pure)
    (cond
     ((equal? (string-length str-path) 0)
      str-name)
     ((equal? (string-last-char str-path) #\/)
      (string-append str-path str-name))
     (else
      (string-append str-path "/" str-name))))

  (define-simple-proc search-file (((str-filename <string>)
				    (lst-dirs (:uniform-list <string>)))
				   <string>
				   force-pure)
    (let-mutable ((str-found <string> ""))
      (do ((lst-cur (:uniform-list <string>) lst-dirs
		    (cdr (cast (:nonempty-uniform-list <string>) lst-cur))))
	  ((or (null? lst-cur) (not (string-empty? str-found))))
	(let* ((str-cur-dir (car (cast (:pair <string> <object>) lst-cur)))
	       (str-cur-name (compute-file-path str-cur-dir str-filename)))
	  (if (file-exists? str-cur-name)
	      (set! str-found str-cur-name))))
      str-found))

  (define-simple-proc capital->small (((ch <character>)) <character> pure)
    (let ((i (string-char-index str-capital-letters ch)))
      (if (not (= i -1))
	  (string-ref str-small-letters i)
	  ch)))

  (define-simple-proc intercap->dashes
      (((str <string>)) <string> force-pure)
    (let ((i-len <integer> (string-length str)))
      (let-mutable ((str-result <string> ""))
	(let ((ch-first (string-ref str 0)))
	  (set! str-result
	  	(string
	  	 (cond
	  	  ((string-contains-char? str-small-letters ch-first)
	  	   ch-first)
	  	  ((string-contains-char? str-capital-letters ch-first)
	  	   (capital->small ch-first))
	  	  (else
		   (console-display str)
		   (console-newline)
	  	   (raise 'illegal-character))))))
	(do ((i <integer> 1 (+ i 1))) ((>= i i-len))
	  (let ((ch (string-ref str i)))
	    (cond
	     ((string-contains-char? str-small-letters ch)
	      (set! str-result (string-append str-result (string ch))))
	     ((string-contains-char? str-capital-letters ch)
	      (set! str-result
		    (string-append str-result "-"
				   (string (capital->small ch)))))
	     (else
	      (console-display str)
	      (console-newline)
	      (raise 'illegal-character)))))
	str-result)))

  (define-simple-proc drop-last-star
      (((str <string>)) <string> pure)
    (let ((i-len (string-length str)))
      (cond
       ((equal? i-len 0)  "")
       ((equal? (string-ref str (- i-len 1)) #\*)
	(substring str 0 (- i-len 1)))
       (else str))))

  (define-simple-proc ends-with-two-stars?
      (((str <string>)) <boolean> pure)
    (let ((i-len (string-length str)))
      (and (>= i-len 2)
	   (equal? (string-ref str (- i-len 2)) #\*)
	   (equal? (string-ref str (- i-len 1)) #\*))))

  (define-simple-proc ends-with-brackets?
      (((str <string>)) <boolean> pure)
    (let ((i-len (string-length str)))
      (and (>= i-len 2)
	   (equal? (string-ref str (- i-len 2)) #\[)
	   (equal? (string-ref str (- i-len 1)) #\]))))

  (define-simple-proc drop-const
      (((str <string>)) <string> pure)
    (let ((i-len (string-length str)))
      (if (>= i-len 6)
	  (if (string=? (substring str 0 6) "const-")
	      (substring str 6 i-len)
	      str)
	  str)))

  (define-simple-proc get-theme-d-type-name
      (((str-name <string>))
       <string>
       pure)
    (string-append "<"
		   (intercap->dashes str-name)
		   ">"))

  (define-simple-proc get-current-module
      (((translator <translator>)) <target-module> pure)
    (cast <target-module> (field-ref translator 'mod-current)))

  ;; Even though a method is ignored by this procedure the corresponding
  ;; procedure is still generated.
  (define-simple-proc ignore-method?
      (((translator <translator>) (str-method <string>) (str-self <string>))
       <boolean>
       pure)
    (let* ((ht-no-methods (field-ref translator 'ht-no-methods))
	   (l-match (hash-ref ht-no-methods str-method null)))
      (and
       (not-null? l-match)
       (member? str-self l-match))))

  (define-simple-proc process-flags-and-enums
      (((translator <translator>) (lst-input <nonempty-list>)
	(s-mode <symbol>) (sym-type <symbol>))
       <none> nonpure)
    (dwl "process-flags-and-enums")
    (assert (member? sym-type '(flags enum)))
    (let* ((al (cast (:alist <symbol> <object>)
		     (gen-cdr (gen-cdr lst-input))))
	   (pr-c-name (:maybe (:pair <symbol> <object>))
		      (assoc 'c-name al null))
	   (str-c-name
	    (if (not-null? pr-c-name)
		(let ((par
		       (cdr (cast (:pair <symbol>
					 (:pair <string> <object>))
				  pr-c-name))))
		  (if (not-null? par)
		      (car par)
		      (raise 'invalid-c-name)))
		(raise 'missing-c-name)))
	   (str-name (get-theme-d-type-name str-c-name)))
      (hash-set! (field-ref translator 'ht-flags-and-enums)
			str-name sym-type)))

  (define-simple-proc strip-brackets (((str <string>)) <string> pure)
    (let ((i-len <integer> (string-length str)))
      (if (equal? i-len 0)
	  ""
	  (let ((ch-first <character> (string-ref str 0))
		(ch-last <character> (string-ref str (- i-len 1))))
	    (if (and (equal? ch-first #\<)
		     (equal? ch-last #\>))
		(substring str 1 (- i-len 1))
		str)))))

  (define-simple-proc get-target-class-name
      (((translator <translator>) (str-raw-name <string>))
       (:pair <string> <string>)
       pure)
    (let ((str-explicit (hash-ref
			 (field-ref (get-current-module translator)
				    'ht-explicit)
			 str-raw-name null)))
      (if (null? str-explicit)
	  (let* ((str-name0
		  (intercap->dashes str-raw-name))
		 (str-name (string-append "<" str-name0 ">")))
	    (cons str-name str-name0))
	  (let* ((str-expl (cast <string> str-explicit))
		 (str-expl0 <string> (strip-brackets str-expl)))
	    (cons str-expl str-expl0)))))

  (define-simple-proc process-object-type
      (((translator <translator>) (lst-input <nonempty-list>)
	(s-mode <symbol>) (s-metatype <symbol>))
       <none> nonpure)

    (assert (member? s-mode '(interface body import)))
    (assert (member? s-metatype '(object interface boxed)))

    (dwl "process-object-type")

    ;; TO BE REMOVED
    ;; (disp "process-object-type")
    ;; (disp lst-input)
    ;; (disp (car (cast <nonempty-list> (cdr lst-input))))
    ;; (disp (class-of (car (cast <nonempty-list> (cdr lst-input)))))

    (let* ((al (cast (:uniform-list (:pair <symbol> <object>))
		     (gen-cdr (gen-cdr lst-input))))
	   (pr-c-name (:maybe (:pair <symbol> <object>))
		      (assoc 'c-name al null))
	   (str-c-name
	    (if (not-null? pr-c-name)
		(let ((par
		       (cdr (cast (:pair <symbol>
					 (:pair <string> <object>))
				  pr-c-name))))
		  (if (not-null? par)
		      (car par)
		      (raise 'invalid-c-name)))
		(raise 'missing-c-name)))
	   (mod-current (get-current-module translator))
	   (ht-ignored-types (field-ref mod-current 'ht-ignored-types))
	   (ht-overridden (field-ref mod-current 'ht-overridden))) 
      (if (and (not (hash-exists? ht-ignored-types str-c-name))
	       (not (hash-exists? ht-overridden str-c-name)))
	  ;; If neither of the conditions in the following statement are true
	  ;; do nothing.
	  (cond
	   ((equal? s-metatype 'interface)
	    (let ((ht-interfaces (field-ref translator 'ht-interfaces)))
	      (hash-set! ht-interfaces str-c-name 1))
	    (if (equal? s-mode 'interface)
		(let* ((pr1 (get-target-class-name translator str-c-name))
		       (str-name (car pr1))
		       (op (field-ref translator 'op)))
		  (display-string op "(define ")
		  (display-string op str-name)
		  (display-string op " <object>)\n"))))
	   ((equal? s-mode 'interface)
	    (let* ((pr1 (get-target-class-name translator str-c-name))
		   (str-name (car pr1))
		   (str-name0 (cdr pr1))
		   (pr-parent (:maybe (:pair <symbol> <object>))
			      (assoc 'parent al null))
		   (str-raw-parent
		    (if (not-null? pr-parent)
			(let ((par
			       (cdr
				(cast (:pair <symbol>
					     (:pair <string> <object>))
				      pr-parent))))
			  (if (not-null? par)
			      (car par)
			      ""))
			""))
		   (str-parent 
		    (if (equal? (string-length str-raw-parent) 0)
			(if (equal? s-metatype 'boxed)
			    "<object>"
			    (field-ref translator 'str-default-parent))
			(car (get-target-class-name translator
						    str-raw-parent))))
		   (op (field-ref translator 'op)))
	      (for-each1
	       (lambda (((str <string>)) <none> nonpure)
		 (display-string op str))
	       (list
		"(define-normal-goops-class "
		str-name " "
		str-name " "
		str-parent
		" #t #f #f)\n"))))))))


  (define-simple-proc process-arg-basic-type
      (((translator <translator>) (str-type <string>)) <string> nonpure)
    (let ((str-match1 (:maybe <string>)
		      (hash-ref
		       (field-ref
			(get-current-module translator)
			'ht-explicit)
		       str-type null)))
      (cond
       ((not-null? str-match1)
	(cast <string> str-match1))
       ((or (ends-with-two-stars? str-type)
	    (ends-with-brackets? str-type))
	"<object>")
       (else
	(let* ((str-type1 (drop-const (drop-last-star str-type)))
	       (str-type2
		(get-theme-d-type-name str-type1))
	       (s-match2 (:maybe <symbol>)
			 (hash-ref
			  (field-ref translator 'ht-flags-and-enums)
			  str-type2 null)))
	  (if (null? s-match2)
	      str-type2
	      (let ((sym (cast <symbol> s-match2)))
		(cond
		 ((symbol=? sym 'flags) "<object>")
		 ((symbol=? sym 'enum) "<symbol>")
		 (else
		  (raise 'internal-error))))))))))

  (define-simple-proc process-arg-type
      (((translator <translator>) (str-type <string>)
	(null-ok? <boolean>)) <string> nonpure)
    (dwl "process-arg-type")
    (dwl str-type)
    (let ((str-basic-type (process-arg-basic-type translator str-type)))
      (if null-ok?
	  (string-append "(:alt-maybe " str-basic-type ")")
	  str-basic-type)))

  (define-simple-proc get-param-type (((lst-raw <raw-param>))
				      (:pair <string> <boolean>) pure)
    (let* ((lst-actual-param (tuple-ref lst-raw 1))
	   (str-param-type <string> (car lst-actual-param))
	   (lst-options (cast <list> (cdr (cdr lst-actual-param))))
	   (null-ok? <boolean>
		     (member? (cast <object> '(null-ok)) lst-options)))
      (cons str-param-type null-ok?)))

  (define-simple-proc write-proc-output
      (((translator <translator>)
	(s-mode <symbol>)
	(s-type <symbol>)
	(make-method? <boolean>)
	(str-name <string>)
	(str-method-name <string>)
	(str-self <string>)
	(lst-arg-types (:uniform-list <string>))
	(str-result-type <string>)
	(ctr? <boolean>)
	(str-ctr-proc <string>)
	(str-ctr-class <string>))
       <none>
       nonpure)
    (dwl "write-proc-output")
    (let* ((op (field-ref translator 'op))
	   (disp (lambda (((str <string>)) <none> nonpure)
		   (display-string op str)))
	   (lst-arg-types1 (if (symbol=? s-type 'method)
			       (cons str-self lst-arg-types)
			       lst-arg-types)))
      (cond
       ((symbol=? s-mode 'interface)
	(for-each1 disp
		   (list
		    "(declare "
		    str-name
		    " (:simple-proc ("
		    (join-strings-with-sep lst-arg-types1 " ")
		    ") "
		    str-result-type
		    " nonpure))\n"))
	(if make-method?
	    (for-each1 disp
		       (list
			"(declare-method "
			str-method-name
			" (:simple-proc ("
			(join-strings-with-sep lst-arg-types1 " ")
			") "
			str-result-type
			" nonpure))\n")))
	(if ctr?
	    (for-each1 disp
		       (list
			"(declare "
			str-ctr-proc
			" (:simple-proc ("
			(join-strings-with-sep lst-arg-types1 " ")
			") "
			str-ctr-class
			" nonpure))\n"))))
       ((symbol=? s-mode 'body)
	(for-each1 disp
		   (list
		    "(define "
		    str-name
		    " (prim-proc "
		    str-name
		    " ("
		    (join-strings-with-sep lst-arg-types1 " ")
		    ") "
		    str-result-type
		    " nonpure))\n"))
	(if make-method?
	    (for-each1 disp
		       (list
			"(add-method "
			str-method-name
			" "
			str-name
			")\n")))
	(if ctr?
	    (for-each1 disp
		       (list
			"(define "
			str-ctr-proc
			;; It is good to have prim-proc here instead of
			;; unchecked-prim-proc because the Glib constructor
			;; result type may be some superclass 
			;; (usually <gtk-widget>) of the class to be
			;; constructed.
			" (prim-proc "
			str-name
			" ("
			(join-strings-with-sep lst-arg-types1 " ")
			") "
			str-ctr-class
			" nonpure))\n"))))
       (else
	(console-display s-mode)
	(console-newline)
	(console-display s-type)
	(console-newline)
	(raise 'logical-error)))))

  (define-simple-proc matches-ignored?
      (((translator <translator>) (str-name <string>)) <boolean> pure)
    (let ((str-pattern (field-ref (get-current-module translator)
				  'str-ignored-pattern)))
      (string-exact-match? str-pattern str-name)))

  (define-simple-proc compute-creator-name
      (((str-name <string>) (i-new <integer>) (i-pred-len <integer>))
       <string> pure)
    (assert (>= i-new 0))
    (assert (>= i-pred-len 0))
    (string-append
     (substring str-name 0 i-new)
     "-create"
     (substring str-name (+ i-new i-pred-len) (string-length str-name))))

  (define-simple-proc process-proc
      (((translator <translator>) (lst-input <nonempty-list>) (s-mode <symbol>)
	(s-type <symbol>))
       <none> nonpure)
    (dwl "process-proc")
    (assert (member? s-mode '(interface body import)))
    (assert (member? s-type '(simple-proc method)))
    (if (or (equal? s-mode 'interface) (equal? s-mode 'body))
	(let* ((lst1 
		(cast 
		 (:pair <object> (:pair <object> <object>))
		 lst-input))
	       (al (cast (:alist <symbol> <object>)
			 (cdr (cdr lst1))))
	       (str-defined-name
		<string>
		(let ((s-defined-name
		       (cast <symbol>
			     (car (cdr lst1)))))
		  (symbol->string s-defined-name)))
	       (str-method-name
		<string>
		(if (equal? s-type 'method)
		    (replace-char str-defined-name #\_ #\-)
		    ""))
	       (obj-overrides (assoc 'overrides al null))
	       (str-overrides
		(if (not-null? obj-overrides)
		    (car (cdr (cast (:tuple <symbol> <string>)
				    obj-overrides)))
		    ""))
	       (str-orig-name
		(if (not (string-empty? str-overrides))
		    str-overrides
		    (let ((obj-c-name (assoc 'c-name al null)))
		      (if (not-null? obj-c-name)
			  (car (cdr (cast (:tuple <symbol> <string>)
					  obj-c-name)))
			  (raise 'missing-c-name)))))
	       (str-name
		(replace-char str-orig-name #\_ #\-))
	       (mod-current (get-current-module translator))
	       (ht-overridden (field-ref mod-current 'ht-overridden))
	       (ht-ignored (field-ref mod-current 'ht-ignored))
	       (ht-no-creators (field-ref translator 'ht-no-creators)))
	  (dwl "process-proc/1")
	  (dwl str-name)
	  (if (and (not (hash-exists? ht-ignored str-orig-name))
		   (not (matches-ignored? translator str-orig-name))
		   (not (hash-exists? ht-overridden str-orig-name)))
	      (begin
		(dwl "process-proc/2")
		(if (not (string-empty? str-overrides))
		    (hash-set! ht-overridden str-overrides 2))
		(dwl "process-proc/3")
		(let* ((str-self0
			(if (symbol=? s-type 'method)
			    (let ((obj-self (assoc 'of-object al null)))
			      (if (not-null? obj-self)
				  (car (cdr
					(cast (:tuple <symbol> <string>)
					      obj-self)))
				  (raise 'missing-self-class)))
			    ""))
		       (str-self
			(if (symbol=? s-type 'method)
			    (process-arg-type translator str-self0 #f)
			    ""))
		       (make-method?
			(and (symbol=? s-type 'method)
			     (let ((ht-interfaces (field-ref translator
							     'ht-interfaces)))
			       (not (hash-exists? ht-interfaces
						  str-self0)))
			     (not
			      (ignore-method? translator
					      str-defined-name
					      str-self0))))
		       (str-ctr-class0
			<string>
			(let ((o-ctr (assoc 'is-constructor-of al null)))
			  (if (not-null? o-ctr)
			      (match-type
				  (car (cdr
					(cast (:tuple
					       <symbol>
					       (:union <string> <symbol>))
					      o-ctr)))
				((str <string>) str)
				((s <symbol>) (symbol->string s))
				;; We should never arrive in the else part.
				(else (raise 'internal-error)))
			      "")))
		       (ctr0?
			(and
			 (not (string-empty? str-ctr-class0))
			 (not
			  (hash-exists? ht-no-creators str-orig-name))
			 (>= (string-length str-name) gl-i-pred-len)))
		       (i-new (if ctr0?
				  (search-substring-from-end str-name
							     gl-str-pred)
				  -1))
		       (ctr? (and ctr0? (>= i-new 0)))
		       (str-ctr-class
			(if ctr?
			    (process-arg-type translator str-ctr-class0 #f)
			    ""))
		       (str-ctr-proc
			(if ctr?
			    (compute-creator-name str-name i-new
						  gl-i-pred-len)
			    ""))
		       (lst-raw-args0 (assoc 'parameters al null))
		       (lst-raw-args
			(:uniform-list <raw-param>)
			(if (not-null? lst-raw-args0)
			    (cdr
			     (cast (:pair <symbol>
					  (:uniform-list <raw-param>))
				   lst-raw-args0))
			    '()))
		       (lst-arg-types0 (map1 get-param-type lst-raw-args))
		       (lst-arg-types
			(map-nonpure1
			 (lambda (((obj-type (:pair <string> <boolean>)))
				  <string> nonpure)
			   (process-arg-type translator
					     (car obj-type)
					     (cdr obj-type)))
			 lst-arg-types0))
		       (obj-result-type (assoc 'return-type al null))
		       (str-result-type0
			(if (not-null? obj-result-type)
			    (tuple-ref
			     (cast (:tuple <symbol> <string>) obj-result-type)
			     1)
			    ""))
		       ;; We don't accept nulls for procedure results.
		       (str-result-type
			(if (not (string-empty? str-result-type0))
			    (process-arg-type translator str-result-type0 #f)
			    "<none>")))
		  (dwl "process-proc/3")
		  (write-proc-output translator
				     s-mode
				     s-type
				     make-method?
				     str-name
				     str-method-name
				     str-self
				     lst-arg-types
				     str-result-type
				     ctr?
				     str-ctr-proc
				     str-ctr-class)))))))
    
  (define-simple-proc add-ignore-pattern!
      (((translator <translator>) (str-pattern <string>))
       <none>
       nonpure)
    (let* ((mod-current (get-current-module translator))
	   (str-old (field-ref mod-current 'str-ignored-pattern)))
      (if (string-empty? str-old)
	  (field-set! mod-current 'str-ignored-pattern str-pattern)
	  (field-set! mod-current 'str-ignored-pattern
		      (string-append str-old "|" str-pattern)))))

  (declare process-sourcefile
	   (:procedure (<translator> <string> <symbol>
				     (:uniform-list <string>))
		       <none> nonpure))

  (define-simple-proc process-sourcefile0
      (((translator <translator>) (str-file-path <string>) (s-mode <symbol>))
       <none> nonpure)
    (dwl "process-sourcefile0")
    (dwl str-file-path)
    (let* ((fl (if (not (string-empty? str-file-path))
		   (open-input-file str-file-path)
		   (begin
		     (console-display-line "file name: ")
		     (console-display-line str-file-path)
		     (raise 'source-file-not-found))))
	   (lst-split (cast (:nonempty-uniform-list <string>)
				 (split-string str-file-path #\/)))
	   (str-name (last lst-split))
	   (str-cur-path (join-strings-with-sep (drop-right lst-split 1) "/")))
      (dwl "process-sourcefile0/1")
      (dwl str-cur-path)
      (let-mutable ((o-input <object> '())
		    (stop? <boolean> #f))
	(until (stop?)
	  (set! o-input (read fl))
	  (if (eof? o-input)
	      (set! stop? #t)
	      (let* ((lst-input <nonempty-list> (cast <nonempty-list> o-input))
		     (o-kw <object> (car lst-input)))
		(console-display o-kw)
		(let ((tl (cdr lst-input)))
		  (if (not-null? tl)
		      (begin
			(console-display " ")
			(console-display
			 (car (cast <nonempty-list> tl))))))
		(console-newline)
		(cond
		 ((equal? o-kw 'ignore)
		  (let* ((lst-vars (cast (:uniform-list <string>)
					 (cdr lst-input)))
			 (mod-current (get-current-module translator))
			 (ht-ignored (field-ref mod-current 'ht-ignored)))
		    (for-each1 (lambda (((str <string>)) <none> nonpure)
				 (hash-set! ht-ignored str 1))
			       lst-vars)))
		 ((equal? o-kw 'ignore-types)
		  (let* ((lst-vars (cast (:uniform-list <string>)
					 (cdr lst-input)))
			 (mod-current (get-current-module translator))
			 (ht-ignored-types
			  (field-ref mod-current 'ht-ignored-types)))
		    (for-each1 (lambda (((str <string>)) <none> nonpure)
				 (hash-set! ht-ignored-types str 1))
			       lst-vars)))
		 ((equal? o-kw 'ignore-glob)
		  (let* ((lst-patterns0
			  (cast (:uniform-list <string>) (cdr lst-input)))
			 (lst-patterns
			  (map1 (lambda (((str-pattern <string>)) <string> pure)
				  (replace-char-with-string str-pattern #\*
							    ".*"))
				lst-patterns0)))
		    (for-each1 (lambda (((str-pattern <string>)) <none> nonpure)
				 (add-ignore-pattern! translator str-pattern))
			       lst-patterns)))
		 ((equal? o-kw 'explicit-class)
		  (let* ((lst1 (cast (:tuple <symbol> <string> <string>)
				     lst-input))
			 (str-source <string> (tuple-ref lst1 1))
			 (str-target <string> (tuple-ref lst1 2))
			 (mod-current (get-current-module translator)))
		    (hash-set! (field-ref mod-current 'ht-explicit)
				      str-source str-target)))
		 ((equal? o-kw 'define-flags)
		  (process-flags-and-enums translator lst-input s-mode 'flags))
		 ((equal? o-kw 'define-enum)
		  (process-flags-and-enums translator lst-input s-mode 'enum))
		 ((equal? o-kw 'define-object)
		  (process-object-type translator lst-input s-mode 'object))
		 ((equal? o-kw 'define-interface)
		  (process-object-type translator lst-input s-mode 'interface))
		 ;; Not sure if the following is correct.
		 ((equal? o-kw 'define-boxed)
		  (process-object-type translator lst-input s-mode 'boxed))
		 ((equal? o-kw 'define-function)
		  (process-proc translator lst-input s-mode 'simple-proc))
		 ((equal? o-kw 'define-method)
		  (process-proc translator lst-input s-mode 'method))
		 ((equal? o-kw 'include)
		  (dwl "include")
		  (let ((o-source-filename
			 (car (cdr
			       (cast (:tuple <symbol> <object>)
				     lst-input)))))
		    (match-type o-source-filename
		      ((str-source-filename <string>)
		       (let ((lst-source-path
				  (cons
				   (if (not (string-empty? str-cur-path))
				       str-cur-path
				       ".")
				   (field-ref translator 'lst-source-path))))
			 (process-sourcefile translator
					     str-source-filename
					     s-mode
					     lst-source-path)))
		      ((sym <symbol>)
		       (cond
			((equal? sym 'type-ignores)
			 (let ((s-path
				(compute-file-path
				 (field-ref translator 'str-override-path)
				 (string-append str-name "-type-ignores"))))
			   (process-sourcefile0 translator s-path s-mode)))
			((equal? sym 'overrides)
			 (let ((s-path
				(compute-file-path
				 (field-ref translator 'str-override-path)
				 str-name)))
			   (process-sourcefile0 translator s-path s-mode)))
			(else (raise 'syntax-error-in-include-1))))
		      (else
		       (raise 'syntax-error-in-include-2)))))
		 (else
		  (console-display o-kw)
		  (console-newline)
		  (raise 'unknown-expr-type)))))))
      (close-input-port fl)))
  
  (define-simple-proc process-sourcefile
      (((translator <translator>) (str-filename <string>) (s-mode <symbol>)
	(lst-source-path (:uniform-list <string>)))
       <none> nonpure)
    (dwl "process-sourcefile")
    (dwl str-filename)
    (let ((str-file-path (search-file str-filename lst-source-path)))
      (process-sourcefile0 translator str-file-path s-mode)))

  (define-simple-proc write-external-import
      (((op <output-port>) (module-name <module-name>))
       <none>
       nonpure)
    (display op "  ")
    (display op module-name)
    (newline op))

  (define-simple-proc write-internal-import
      (((op <output-port>) (str-name <string>)
	(str-path <string>))
       <none>
       nonpure)
    (display op "  (")
    (display op str-path)
    (display op " ")
    (display op str-name)
    (display op ")")
    (newline op))

  (define-simple-proc write-imports
      (((op <output-port>)
	(lst-ext (:uniform-list <module-name>))
	(lst-names (:uniform-list <string>))
	(str-path <string>))
       <none>
       nonpure)
    (display op "(import\n")
    ;;    (display op "  (standard-library core)\n")
    (for-each1 (lambda (((module-name <module-name>)) <none> nonpure)
		 (write-external-import op module-name))
	       lst-ext)
    (for-each1 (lambda (((str-name <string>)) <none> nonpure)
		 (write-internal-import op str-name str-path))
	       lst-names)
    (display op "  )")
    (newline op))

  (define-simple-proc write-header
      (((translator <translator>) (s-mode <symbol>)
	(str-unit-name <string>))
       <none>
       nonpure)
    (dwl "write-header")
    (let ((op (field-ref translator 'op))
	  (str-mod-path (field-ref translator 'str-mod-path)))
      (cond
       ((equal? s-mode 'interface)
	(display op "(define-interface (")
	(display op str-mod-path)
	(display op " ")
	(display op str-unit-name)
	(display op ")")
	(newline op)
	(newline op)
	(write-imports op
		       (field-ref translator 'lst-external-imports)
		       (field-ref translator 'lst-toplevel-imports)
		       str-mod-path)
	(newline op)
	(newline op))
       ((equal? s-mode 'body)
	(display op "(define-body (")
	(display op str-mod-path)
	(display op " ")
	(display op str-unit-name)
	(display op ")")
	(newline op)
	(newline op))
       (else '()))))

  (define-simple-proc write-trailer
      (((translator <translator>)) <none> nonpure)
    (let ((op (field-ref translator 'op)))
      (display op ")")
      (newline op)))

  (declare process-metafile
	   (:procedure (<translator> <string> <string> <symbol>
				     (:uniform-list <string>))
		       <none>
		       nonpure))

  (declare process-unit
	   (:procedure (<translator> <string> <symbol> (:uniform-list <string>))
		       <none>
		       nonpure))

  (define-simple-proc import-external
      (((translator <translator>) (lst-expr <nonempty-list>) (s-mode <symbol>))
       <none> nonpure)
    (if (equal? (field-ref translator 's-toplevel-mode) 'interface)
	(if (field-ref translator 'processing-source?)
	    (raise 'illegal-import-external-expression)
	    (if (not (symbol=? s-mode 'import))
		(let ((lst-submodules <list> (cdr lst-expr)))
		  (for-each1
		   (lambda (((o-mod <object>)) <none> nonpure)
		     (let* ((module-name (cast <module-name> o-mod)))
		       (field-set! translator 'lst-external-imports
				   (append
				    (field-ref translator
					       'lst-external-imports)
				    (list module-name)))))
		   lst-submodules))))))

  (define-simple-proc process-metafile-expr
      (((translator <translator>) (obj-expr <object>)
	(str-unit-name <string>)
	(s-mode <symbol>)
	(lst-visited (:uniform-list <string>)))
       <none>
       nonpure)
    (let* ((lst-input-expr
	    (cast <nonempty-list> obj-expr))
	   (lst-next-visited
	    (cons str-unit-name lst-visited))
	   (sym-keyword
	    (cast <symbol> (car lst-input-expr))))
      (cond
       ((symbol=? sym-keyword 'import)
	(dwl "import")
	(if (field-ref translator 'processing-source?)
	    (raise 'illegal-import-expression)
	    (if (not (symbol=? s-mode 'import))
		(let ((lst-submodules <list> (cdr lst-input-expr)))
		  (for-each1
		   (lambda (((o-mod <object>)) <none> nonpure)
		     (let* ((s-mod (cast <symbol> o-mod))
			    (str-mod (symbol->string s-mod)))
		       (process-unit translator str-mod 'import
				     lst-next-visited)))
		   lst-submodules)))))
       ((symbol=? sym-keyword 'import-external)
	(dwl "import-external")
	(import-external translator lst-input-expr s-mode))
       ((symbol=? sym-keyword 'source)
	(dwl "source")
	(let ((str-source-filename (car (cdr
					 (cast (:tuple <symbol> <string>)
					       lst-input-expr)))))
	  (process-sourcefile translator str-source-filename s-mode
			      (field-ref translator 'lst-source-path))))
       ((symbol=? sym-keyword 'no-method)
	(let* ((l-1 (cast (:tuple <symbol> <string> <string>) lst-input-expr))
	       (str-method <string> (tuple-ref l-1 1))
	       (str-self <string> (tuple-ref l-1 2))
	       (ht-no-methods (field-ref translator 'ht-no-methods))
	       (l-old (hash-ref ht-no-methods str-method null)))
	  (hash-set! ht-no-methods str-method
		     (cast (:uniform-list <string>)
			   (cons str-self l-old)))))
       ((symbol=? sym-keyword 'no-creator)
	(let* ((l-1 (cast (:tuple <symbol> <string>) lst-input-expr))
	       (str-proc <string> (car (cdr l-1)))
	       (ht-no-creators (field-ref translator 'ht-no-creators)))
	  (hash-set! ht-no-creators str-proc 1)))
       ((symbol=? sym-keyword 'generate-header)
	(if (or (symbol=? s-mode 'interface) (symbol=? s-mode 'body))
	    (if (not (field-ref translator 'processing-source?))
		(begin
		  (write-header translator s-mode str-unit-name)
		  (field-set! translator 'processing-source? #t))
		(raise 'duplicate-generate-header))))
       (else
	(console-display "Unknown keyword ")
	(console-display sym-keyword)
	(console-display-line ". Aborted.")
	(console-newline)
	(exit 1)))))


  (define-simple-proc process-metafile
      (((translator <translator>)
	(str-filename <string>)
	(str-unit-name <string>)
	(s-mode <symbol>)
	(lst-visited (:uniform-list <string>)))
       <none>
       nonpure)
    (dwl "process-metafile")
    (let ((ip-desc (:maybe <input-port>)
		   (guard-nonpure (exc (else null))
				  (open-input-file str-filename))))
      (dwl str-filename)
      (if (not-null? ip-desc)
	  (let ((ip (cast <input-port> ip-desc))
		(lst-next-visited
		 (cons str-unit-name lst-visited)))
	    (dwl "process-metafile/1")
	    (let-mutable ((stop? <boolean> #f))
	      (until (stop?)
		(let ((obj-expr (read ip)))
		  (if (eof? obj-expr)
		      (set! stop? #t)
		      (process-metafile-expr translator obj-expr
					     str-unit-name s-mode
					     lst-next-visited)))))
	    (close-input-port ip)))))


  (define-simple-proc make-my-hash-table
      (((i-size <integer>)) (:string-hash-table <integer>) pure)
    ((param-proc-instance make-string-hash-table-with-size <integer>) i-size))


  (define-simple-proc make-target-module
      (((str-name <string>)) <target-module> pure)
    (let* ((ht-explicit
	    ((param-proc-instance make-string-hash-table-with-size <string>)
	     2000))
	   (ht-ignored (make-my-hash-table 10000))
	   (ht-ignored-types (make-my-hash-table 10000))
	   (ht-overridden (make-my-hash-table 10000))
	   (mod (make <target-module>
		      str-name
		      ht-explicit ht-ignored
		      ht-ignored-types ht-overridden)))
      mod))

  (define-simple-proc display-module-statistics
      (((mod <target-module>) (op <output-port>)) <none> nonpure)
    (display op "Module: ")
    (display op (field-ref mod 'str-name))
    (newline op)
    (display op "Number of explicit classes: ")
    (display op
	     (hash-count-elements (field-ref mod 'ht-explicit)))
    (newline op)
    (display op "Number of ignored procedures: ")
    (display op
	     (hash-count-elements (field-ref mod 'ht-ignored)))
    (newline op)
    (display op "Length of the ignored procedure patterns: ")
    (display op
	     (string-length (field-ref mod 'str-ignored-pattern)))
    (newline op)
    (display op "Number of ignored types: ")
    (display op
	     (hash-count-elements (field-ref mod 'ht-ignored-types)))
    (newline op)
    (display op "Number of overridden definitions: ")
    (display op
	     (hash-count-elements (field-ref mod 'ht-overridden)))
    (newline op))

  (define-simple-proc display-translator-statistics
      (((translator <translator>)) <none> nonpure)
    (assert (not-null? (field-ref translator 'op-statistics)))
    (let ((op (cast <output-port> (field-ref translator 'op-statistics))))
      (display op "Translator statistics:\n")
      (display op "Number of flags and enums: ")
      (display op (hash-count-elements
		   (field-ref translator 'ht-flags-and-enums)))
      (newline op)))

  (define-simple-proc process-unit
      (((translator <translator>) (str-unit-name <string>)
	(s-mode <symbol>) (lst-visited (:uniform-list <string>)))
       <none> nonpure)
    (dwl "process-unit")
    (dwl str-unit-name)
    (dwl s-mode)
    (assert (member? s-mode '(interface body import)))
    (if (member? str-unit-name lst-visited)
	'()
	(let* ((mod (make-target-module str-unit-name))
	       (mod-old (field-ref translator 'mod-current)))
	  (field-set! translator 'mod-current mod)
	  (field-set! mod 'str-name str-unit-name)
	  (if (and
	       (equal? (field-ref translator 's-toplevel-mode) 'interface)
	       (equal? s-mode 'import))
	      (field-set! translator 'lst-toplevel-imports
			  (append
			   (field-ref translator 'lst-toplevel-imports)
			   (list str-unit-name))))
	  (let ((str-filename <string>
			      (string-append str-unit-name ".mod")))
	    (process-metafile translator str-filename str-unit-name s-mode
			      lst-visited))
	  (let ((op-statistics (field-ref translator 'op-statistics)))
	    (if (not-null? op-statistics)
		(display-module-statistics mod
					   (cast <output-port> op-statistics))))
	  (field-set! translator 'mod-current mod-old))))


  (define-simple-proc make-translator
      (((lst-source-path (:uniform-list <string>))
	;;					(str-prefix <string>)
	(s-mode <symbol>)
	(str-mod-path <string>)
	(str-override-path <string>)
	(op <output-port>)
	(op-stat (:maybe <output-port>)))
       <translator>
       force-pure)
    (strong-assert (member? s-mode '(interface body)))
    (let* ((ht-flags-and-enums
	    ((param-proc-instance make-string-hash-table-with-size <symbol>)
	     2000))
	   (ht-interfaces (make-my-hash-table 2000))
	   (ht-no-methods
	    ((param-proc-instance make-string-hash-table-with-size
				  (:uniform-list <string>))
	     200))
	   (ht-no-creators (make-my-hash-table 200))
	   (translator
	    (make <translator>
		  ht-flags-and-enums
		  ht-interfaces
		  ht-no-methods
		  ht-no-creators
		  s-mode lst-source-path str-mod-path
		  str-override-path
		  "<gobject>" op op-stat)))
      translator))


  (define-simple-proc main (((lst-args (:uniform-list <string>)))
			    <none> nonpure)
    (let ((i-args (length lst-args)))
      (if (and (not (equal? i-args 6)) (not (equal? i-args 7)))
	  (raise 'invalid-arguments)
	  (let ((str-unit-name <string> (uniform-list-ref lst-args 1))
		(str-output-filename <string> (uniform-list-ref lst-args 2))
		(str-mode <string> (uniform-list-ref lst-args 3))
		(str-mod-path0 <string> (uniform-list-ref lst-args 4))
		(str-override-path <string> (uniform-list-ref lst-args 5))
		(str-stat-file <string>
			       (if (equal? i-args 7)
				   (uniform-list-ref lst-args 6)
				   "")))
	    (let* ((str-source-path (:maybe <string>)
				    (getenv "THEME_D_GNOME_SOURCE_PATH"))
		   (lst-source-path
		    (:uniform-list <string>)
		    (if (not-null? str-source-path)
			(split-string (cast <string> str-source-path) #\:)
			(list "."))))
	      (let ((s-mode <symbol> (string->symbol str-mode))
		    (str-mod-path (replace-char str-mod-path0 #\/ #\ )))
		(strong-assert (member? s-mode '(interface body)))
		(let* ((op <output-port> (open-output-file str-output-filename))
		       (op-stat (if (not (string-empty? str-stat-file))
				    (open-output-file str-stat-file)
				    null))
		       (translator (make-translator lst-source-path
						    s-mode
						    str-mod-path
						    str-override-path
						    op op-stat)))
		  (set! gl-translator translator)
		  (process-unit translator str-unit-name s-mode null)
		  (write-trailer translator)
		  (if (not-null? op-stat)
		      (display-translator-statistics translator))
		  (close-output-port op)
		  (if (not-null? op-stat)
		      (close-output-port (cast <output-port> op-stat))))))))))

  )