(define c-output #f)
(define sch-output #f)

(define (select-functions)
  (do ((functions functions (cdr functions)))
      ((null? functions))
    (referenced! (car functions))))

(define (generate-translation)
  (delete-file "C-OUTPUT")
  (delete-file "SCH-OUTPUT")
  (set! c-output (open-output-file "C-OUTPUT"))
  (set! sch-output (open-output-file "SCH-OUTPUT"))
  (display "#include \"chez-stdlib.h\"" c-output) (newline c-output)
  (display "#include \"stdlib.h\"" c-output) (newline c-output)
  
  (dump-structs)
  (dump-unions)
  (dump-functions)
  (dump-variables)
  (dump-enums)
  (dump-macros)
  
  (close-output-port c-output)
  (close-output-port sch-output)
  
  #t)

(define (chez-type type)
  (case (record-tag type)
    ((pointer) 'unsigned-32)
    ((int long enum) 'integer-32)
    ((unsigned unsigned-long) 'unsigned-32)
    ((char unsigned-char signed-char) 'char)
    ((void) 'void)
    ((double) 'double-float)
    ((float) 'single-float)
    ((***invalid***) '***invalid***)
    (else
     (warn "Cannot translate this type: " type)
     (string->symbol (string-append (symbol->string '***invalid:)
                                    (symbol->string (record-tag type))
                                    "***")))))

(define (dump-structs)
  (dump-struct/union structs struct-names "struct"))

(define (dump-unions)
  (dump-struct/union unions union-names "union"))
(define (dump-struct/union records typedef-name-getter qualifier)
  (for-each 
   (lambda (structure) 
     (if (referenced? structure)
         (begin
           (if (user-defined-tag? (tag structure))
               (dump-struct/union-def structure qualifier (tag structure)))
           (for-each (lambda (n)
                       (if (user-defined-tag? (tag structure))
                           (generate-reference-to-structure structure n qualifier)
                           (dump-struct/union-def structure "" n)))
                     (typedef-name-getter structure)))))
   records))
(define (generate-reference-to-structure structure typedef-name qualifier)
  (for-each (lambda (n)
              (let ((newname (compute-newname n typedef-name (tag structure) qualifier)))
                (display `(define ,newname ,n) sch-output)
                (newline sch-output)))
            (cached-names structure)))
(define (compute-newname oldname typedef-name tag qualifier)
  (let ((q (string-append qualifier "_" tag)))
    (let ((get   (string-append "_get_" q))
          (set   (string-append "_set_" q))
          (alloc (string-append "_alloc_" q))
          (free  (string-append "_free_" q)))
      (cond ((string-prefix=? oldname get)
             (string-append "_get_" typedef-name (substring oldname (string-length get)
                                                            (string-length oldname))))
            ((string-prefix=? oldname set)
             (string-append "_set_" typedef-name (substring oldname (string-length set)
                                                            (string-length oldname))))
            ((string-prefix=? oldname alloc) (string-append "_alloc_" typedef-name))
            ((string-prefix=? oldname free) (string-append "_free_" typedef-name))
            (else (error "compute-newname: can't handle: " oldname))))))
(define (dump-struct/union-def structure qualifier name)
  (if (not (null? (fields structure)))
      (let* ((funcname (if (string=? qualifier "")
                           name
                           (string-append qualifier "_" name)))
             (cast     (if (string=? qualifier "")
                           name
                           (string-append qualifier " " name))))
        (generate-constructor-and-destructor structure funcname cast)
        (generate-accessors-and-mutators structure funcname cast ""))))
(define (generate-constructor-and-destructor structure funcname cast)
  (function-pair constructor-template 
                 (vector funcname cast)
                 (string-append "_alloc_" funcname)
                 '((void ()))
                 `(pointer ,(struct/union-ref structure)))
  (function-pair destructor-template 
                 (vector funcname cast)
                 (string-append "_free_" funcname)
                 `((pointer ,(struct/union-ref structure)))
                 '(void ()))
  (cache-name structure (string-append "_alloc_" funcname))
  (cache-name structure (string-append "_free_" funcname)))
(define constructor-template
  "unsigned _alloc_@0(void) { 
     @1 *_p = (@1 *)malloc(sizeof(@1)); return (_p == 0 ? 0 : (unsigned)_p);
   }")

(define destructor-template
  "void _free_@0(unsigned _p) { if (_p == 0) abort(); free((@1 *)_p); }")
(define (generate-accessors-and-mutators structure funcname cast selector)
  (for-each 
   (lambda (field)
     (let ((funcname (string-append funcname "_" (canonical-name (name field))))
           (selector (string-append selector (if (string=? selector "") "" ".") (name field))))
       (cond ((basic-type? (type field))
              (getset-basic-type structure funcname cast selector field))
             ((array-type? (type field))
              (getset-array-type structure funcname cast selector field))
             ((structured-type? (type field))
              (getset-structured-type structure funcname cast selector field))
             (else (error 'generate-accessors-and-mutators "Unknown: " field)))))
   (fields structure)))
(define (getset-basic-type struct funcname cast selector field)
  (let* ((typename   (basic-type-name (type field)))
         (fieldtype  (c-cast-expression (type field))))
    (function-pair accessor-template 
                   (vector typename funcname cast selector)
                   (string-append "_get_" funcname)
                   `((pointer ,(struct/union-ref struct)))
                   (type field))
    (function-pair mutator-template
                   (vector typename funcname cast selector fieldtype)
                   (string-append "_set_" funcname)
                   `((pointer ,(struct/union-ref struct)) ,(type field))
                   `(void ()))
    (cache-name struct (string-append "_get_" funcname))
    (cache-name struct (string-append "_set_" funcname))))
(define accessor-template 
  "@0 _get_@1( unsigned _p ) { return (@0)((@2*)_p)->@3; }")

(define mutator-template 
  "void _set_@1( unsigned _p, @0 _v ) { ((@2*)_p)->@3 = (@4)_v; }")
(define (getset-array-type structure funcname cast selector field)
  (function-pair array-accessor-template
                 (vector funcname cast selector)
                 (string-append "_get_" funcname)
                 `((pointer ,(struct/union-ref structure)))
                 '(unsigned))
  (cache-name structure (string-append "_get_" funcname)))

(define array-accessor-template 
  "unsigned _get_@0( unsigned _p ) { return (unsigned)(((@1*)_p)->@2); }")
(define (getset-structured-type structure funcname cast selector field)
  (let (;(selector (string-append selector "." (name field)))
        ;(funcname (string-append funcname "_" (canonical-name (name field))))
        (struct   (if (eq? (record-tag (type field)) 'struct-ref)
                      (lookup (tag (type field)) structs)
                      (lookup (tag (type field)) unions))))
    (generate-accessors-and-mutators struct funcname cast selector)))

(define (dump-variables)
  (for-each (lambda (v)
              (let ((n (canonical-name (name v))))
                (function-pair global-template 
                               (vector n (name v))
                               (string-append "_glob_" n)
                               '((void ()))
                               `(pointer ,(type v)))))
            vars))

(define global-template 
  "unsigned _glob_@0( void ) { return (unsigned)&@1; }")

(define (dump-functions)
  (for-each (lambda (f) (define-foreign (name f) (type f))) 
            functions))
(define (define-foreign name type)
  (let ((argtypes (arglist type))
        (returntype (rett type)))
    (let loop ((l argtypes))
      (cond ((null? l) #t)
            ((structured-type? (car l))
             (warn "Cannot pass structured value of type" 
                   (rational-typename (car l))
                   "to function" 
                   name)
             (set-car! l '(***invalid***))
             (loop (cdr l)))
            (else
             (loop (cdr l)))))
    (if (structured-type? returntype)
        (begin (warn "Cannot receive structured value of type"
                     (rational-typename returntype)
                     "from function"
                     name)
               (set! returntype '(***invalid***))))

    (write
     `(define ,(string->symbol (canonical-name name))
        (foreign-function ,name
                          ,(chez-map-args argtypes name)
                          ,(chez-type returntype)))
     sch-output)
    (newline sch-output)))
(define (chez-map-args args name)
  (cond ((and (= (length args) 1)
              (eq? (caar args) 'void))
         '())
        ((= (length args) 0)
         (warn "Function without prototype assumed to take no arguments:"
               name)
         '())
        (else
         (map (lambda (x)
                (if (eq? (record-tag x) 'void)
                    (begin (warn "Varargs *cannot* be handled for" name)
                           '***invalid***)
                    (chez-type x)))
              args))))

(define (dump-enums)
  (for-each (lambda (x)
              (display (instantiate "(define @0 @1)"
                                    (vector (canonical-name (name x))
                                            (number->string (value x))))
                       sch-output)
              (newline sch-output))
            enum-idents))

(define (dump-macros)
    (for-each (lambda (m)
                (if (and (valid-ident? (name m))
                         (valid-number? (value m)))
                    (begin 
                      (display `(define ,(canonical-name (name m)) 
                                  ,(evaluate-number (value m)))
                               sch-output)
                      (newline sch-output))))
              macros))
(define (valid-ident? s)
    (andmap (lambda (c)
              (or (char-upper-case? c)
                  (char-lower-case? c)
                  (char-numeric? c)
                  (char=? c #\_)))
            (string->list s)))

(define (valid-number? s)
  (let ((n (evaluate-number s)))
    n))

(define (function-pair c-template template-args scheme-name arglist rett)
  (display (instantiate c-template template-args) c-output)
  (newline c-output)
  (define-foreign scheme-name
    `(function ,arglist ,rett)))
(define (basic-type-name type)
  (let ((probe (assq (record-tag type)
                     '((char . "char")
                       (signed-char . "signed char")
                       (unsigned-char . "unsigned char")
                       (short . "short")
                       (unsigned-short . "unsigned short")
                       (int . "int")
                       (enum . "int")
                       (unsigned . "unsigned")
                       (long . "long")
                       (unsigned-long . "unsigned long")
                       (void . "void")
                       (pointer . "unsigned")
                       (float . "float")
                       (double . "double")
                       ))))
    (if probe
        (cdr probe)
        (begin (warn "Unknown type " type)
               "***invalid***"))))
(define (c-cast-expression type)
  (define (function-cast stars ftype)
    (string-append (c-cast-expression (rett ftype))
                   "(" stars ")("
                   (apply string-append 
                          (insert 
                           ","
                           (map c-cast-expression (arglist ftype))))
                   ")"))

  (cond ((primitive-type? type) 
         (basic-type-name type))
        ((pointer-type? type)
         (let loop ((t (cadr type)) (stars "*"))
           (cond ((eq? 'function (record-tag t))
                  (function-cast stars t))
                 ((eq? 'pointer (record-tag t))
                  (loop (cadr t) (string-append "*" stars)))
                 (else
                  (string-append (c-cast-expression (cadr type)) "*")))))
        ((eq? (record-tag type) 'enum-ref)
         (basic-type-name '(int ())))
        ((memq (record-tag type) '(struct-ref union-ref))
         (let ((t (tag type)))
           (if (user-defined-tag? t)
               (string-append (if (eq? (record-tag type) 'struct-ref) 
                                  "struct " 
                                  "union ")
                              t)
               (let ((names (if (eq? (record-tag type) 'struct-ref)
                                (struct-names type)
                                (union-names type))))
                 (if (= (length names) 1)
                     (car names)
                     (error "c-cast-expression: bad: " type))))))
        (else
         (warn "c-cast-expression: Too complicated: " type)
         "unknown")))

(define (insert x l)
  (define (loop l)
    (if (null? (cdr l))
        l
        (cons (car l) (cons x (loop (cdr l))))))
  (if (or (null? l)
          (null? (cdr l)))
      l
      (loop l)))
(define (string-prefix=? s prefix)
  (let ((limit (string-length prefix)))
    (and (<= limit (string-length s))
         (let loop ((i 0))
           (or (= i limit)
               (and (char=? (string-ref s i) (string-ref prefix i))
                    (loop (+ i 1))))))))
(define (rational-typename type)
  (case (record-tag type)
    ((struct-ref) 
     (if (user-defined-tag? (tag type)) 
         type
         (let ((t (lookup (tag type) structs)))
           (if (not t)
               type
               (list 'struct-ref (tag t))))))
    ((union-ref)
     (if (user-defined-tag? (tag type)) 
         type
         (let ((t (lookup (tag type) unions)))
           (if (not t)
               type
               (list 'union-ref (tag t))))))
    (else type)))
(define (evaluate-number s)
  (let ((k (string->list s)))
    (cond ((null? k) #f)
          ((not (char-numeric? (car k))) #f)
          ((char=? (car k) #\0)
           (cond ((null? (cdr k)) 0)
                 ((or (char=? (cadr k) #\x) (char=? (cadr k) #\X))
                  (string->number (list->string (cddr k)) 16))
                 (else
                  (string->number s 8))))
          (else
           (string->number s)))))