;;; examples/nyacc/lang/c99/ffi-help.scm

;; Copyright (C) 2016-2019 Matthew R. Wette
;;
;; This library is free software; you can redistribute it and/or
;; modify it under the terms of the GNU Lesser General Public
;; License as published by the Free Software Foundation; either
;; version 3 of the License, or (at your option) any later version.
;;
;; This library 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
;; Lesser General Public License for more details.
;;
;; You should have received a copy of the GNU Lesser General Public License
;; along with this library; if not, see <http://www.gnu.org/licenses/>

;;; Notes:

;; @table code
;; @item mdecl->fh-wrapper
;; generates code to apply wrapper to objects returned from foreign call
;; @item mdecl->fh-unwrapper
;; generated code to apply un-wrapper to arguments for foreign call
;; @end table

;; also have in (bytestructures guile ffi)
;; bytestructure->descriptor->ffi-descriptor
;; bs:pointer->proc

;; TODOs
;; 1) add renamer
;; 2) think about cnvt-fctn that generates C code
;; 3) add code for bytestructures' bounding-struct-descriptor
;; 4) cnvt-udecl needs complete rewrite using udecl->mdecl from c99/munge
;; 6) generalize: typedef <anything> *foo_t;
;; 7) generalize: typedef <anything> foo_t[];

;; Issue:
;; So issue is when 'typedef struct ref foo_t' has no 'struct def'
;; we never define a type.  Then later we may see 'typedef foo_t bar_t'
;; We are using define-ffi-type-alias but that then generates a reference
;; to an undefined type.  Maybe for the above we should have a void
;; pseudo-type with
;; name: void
;; (unwrap-void obj) => 'void
;; (wrap 'void) (make-xxx)
;; (pointer-to obj) => <void* obj>
;; (value-at void*-object) =. void

;; For enum typedefs we are not creating types but just using wrappers.

;;; Code:

(define-module (nyacc lang c99 ffi-help)
  #:export (*ffi-help-version*
	    define-ffi-module
	    compile-ffi-file
	    load-include-file
	    fh-cnvt-udecl fh-cnvt-cdecl fh-cnvt-cdecl-str fh-scm-str->scm-exp
	    string-member-proc string-renamer
	    ;;
	    C-fun-decl->scm
	    ;;pkg-config-incs pkg-config-defs pkg-config-libs
	    ;; debugging
	    ;;ffi-symmap
	    )
  #:use-module (nyacc lang c99 cpp)
  #:use-module (nyacc lang c99 parser)
  #:use-module (nyacc lang c99 pprint)
  #:use-module (nyacc lang c99 munge)
  #:use-module (nyacc lang c99 cxeval)
  #:use-module (nyacc lang c99 util)
  #:use-module (nyacc version)
  #:use-module (nyacc lang sx-util)
  #:use-module ((nyacc lang util) #:select (cintstr->scm))
  #:use-module ((nyacc lex) #:select (cnumstr->scm))
  #:use-module ((nyacc util) #:select (ugly-print))
  #:use-module (system foreign)
  #:use-module (sxml fold)
  #:use-module (sxml match)
  #:use-module ((sxml xpath)
		#:renamer (lambda (s) (if (eq? s 'filter) 'sxml:filter s)))
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-11)
  #:use-module (srfi srfi-37)
  #:use-module (system base pmatch)
  #:use-module ((system base compile) #:select (compile-file))
  #:use-module (ice-9 format)
  #:use-module (ice-9 popen)
  #:use-module (ice-9 rdelim)
  #:use-module (ice-9 regex)
  #:use-module (ice-9 pretty-print)
  #:re-export (*nyacc-version*)
  #:version (0 99 2))

(define fh-cpp-defs
  (cond
   ((string-contains %host-type "darwin")
    (remove (lambda (s) (string-contains s "_ENVIRONMENT_MAC_OS_X_VERSION"))
	    (get-gcc-cpp-defs)))
   (else (get-gcc-cpp-defs))))
    
(define fh-inc-dirs
  (append
   `(,(assq-ref %guile-build-info 'includedir) "/usr/include")
   (get-gcc-inc-dirs)))

(define fh-inc-help c99-def-help)

;; DEBUGGING
(set! fh-inc-dirs (cons "." fh-inc-dirs))

;; maybe change to a record-type
(define *options* (make-parameter '()))
(define *debug-parse* (make-parameter #f)) ; parse debug mode
(define *echo-decls* (make-parameter #f)) ; add echo-decls code for debugging

(define *prefix* (make-parameter "")) ; name prefix (e.g., prefix-syms)
(define *renamer* (make-parameter identity)) ; renamer from ffi-module

(define *mport* (make-parameter #t))	   ; output module port
(define *udict* (make-parameter '()))	   ; udecl dict
(define *ddict* (make-parameter '()))	   ; cpp-def dict
(define *tdefs* (make-parameter '()))	   ; typenames
(define *wrapped* (make-parameter '()))	; wrappers for foo_t and foo_t*
(define *defined* (make-parameter '()))	; type defined

(define *errmsgs* (make-parameter '()))	; list of warnings

(define (sfscm fmt . args)
  (apply simple-format (*mport*) fmt args))
(define* (ppscm tree #:key (per-line-prefix ""))
  (pretty-print tree (*mport*) #:per-line-prefix per-line-prefix))
(define* (upscm tree #:key (per-line-prefix ""))
  (ugly-print tree (*mport*) #:per-line-prefix per-line-prefix))
(define (c99scm tree)
  (pretty-print-c99 tree
		    (*mport*)
		    #:per-line-prefix ";; "))
(define (nlscm) (newline (*mport*)))

(define (sfout fmt . args)
  (apply simple-format #t fmt args))
(define (ppout tree)
  (pretty-print tree #:per-line-prefix "    "))
(define (nlout) (newline))
(define (sferr fmt . args)
  (apply simple-format (current-error-port) fmt args))
(define (pperr tree)
  (pretty-print tree (current-error-port) #:per-line-prefix "  "))

(define (fherr fmt . args)
  (apply throw 'ffi-help-error fmt args))

(define (fherr/once fmt . args)
  (let ((errmsgs (*errmsgs*)))
    (cond
     ((member fmt errmsgs)
      (apply throw 'ffi-help-error #f '()))
     (else
      (*errmsgs* (cons fmt errmsgs))
      (apply throw 'ffi-help-error fmt args)))))

;; === utilities

;; strings->symbol
(define (strings->symbol . string-list)
  (string->symbol (apply string-append string-list)))

;; '(abc def) => "abc-def"
(define (path->name path)
  (string-join (map symbol->string path) "-"))

;; '(abc def) => "abc/def"
(define (path->path path)
  (string-join (map symbol->string path) "/"))

(define (link-libs)
  (string->symbol (string-append (*prefix*) "-llibs")))

;; @deffn {Procedure} opts->attrs module-opts script-opts
;; The values in @var{script-opts} override @var{module-opts}.  That is,
;; if the value is a list then append, else replace.
;; @end deffn
(define (opts->attrs module-opts script-opts)
  ;; module-opts: inc-dirs pkg-config ...
  ;; script-opts: inc-dirs
  (fold-right
   (lambda (opt seed)
     (cond
      ((assq-ref seed (car opt)) =>
       (lambda (val)
	 (if (pair? val)
	     (acons (car opt) (append (cdr opt) val) seed)
	     (acons (car opt) val seed))))
      (else (cons opt seed))))
   (filter (lambda (pair) (symbol? (car pair))) module-opts)
   script-opts))

(define (opts->mopts opts) ;; module options to pass
  (filter (lambda (pair) (keyword? (car pair))) opts))

;; Run pkg-config
(define (pkg-config name . args)
  (if name
      (let* ((cmdstr (string-append "pkg-config" " "
				    (string-join args) " " name))
	     (port (open-input-pipe cmdstr))
	     (ostr (read-line port))
	     (status (close-pipe port))
	     (items (if (eof-object? ostr) '() (string-split ostr #\space))))
	(unless (zero? status) (fherr "failed: `~A'" cmdstr))
	items)
      '()))

;; use pkg-config to get a list of include dirs
;; (pkg-config-incs "cairo") => ("/opt/local/include/cairo" ...)
(define (pkg-config-incs name)
  (fold-right
   (lambda (s l)
     (cond 
      ((< (string-length s) 3) l)
      ((string=? "-I" (substring/shared s 0 2))
       (cons (substring/shared s 2) l))
      (else l)))
   '()
   (pkg-config name "--cflags")))

(define (pkg-config-defs name)
  (fold-right
   (lambda (s l)
     (cond 
      ((< (string-length s) 3) l)
      ((string=? "-D" (substring/shared s 0 2))
       (cons (substring/shared s 2) l))
      (else l)))
   '()
   (pkg-config name "--cflags")))

;; TODO:
;; 1) check if --libs provides -L that is not in ld.so dirs.
(define (pkg-config-libs name)
  (fold-right
   (lambda (s l)
     (cond 
      ((< (string-length s) 3) l)
      ((string=? "-lm" s) l) ;; workaround for ubuntu libm issue
      ((string=? "-l" (substring/shared s 0 2))
       (cons (string-append "lib" (substring/shared s 2)) l))
      (else l)))
   '()
   (pkg-config name "--libs")))

(define (resolve-attr-val val)
  (let* ((val (if (procedure? val) (val) val)))
    (cond
     ((eq? #f val) '())
     ((list? val) val)
     ((string? val) (list val))
     (else (throw 'ffi-help-error "value does not resolve to list")))))

(define (cintstr->num str)
  (and=> (cintstr->scm str) string->number))

(define (sw/* name) (string-append name "*"))
(define (sw/*-desc name) (string-append name "*-desc"))
(define (sw/& name) (string-append name "&"))
(define (sw/struct* name) (string-append "struct-" name "*"))
(define (sw/union* name) (string-append "struct-" name "*"))

;; I was using (pointer . name) in *defined* but this has issues
;; because expand-typerefs does not recognize it.  Is a change needed?
(define (w/struct name) (cons 'struct name))
(define (w/union name) (cons 'union name))
(define (w/enum name) (cons 'enum name))
;; pointers needed
(define (w/* name) (cons 'pointer name))
(define (w/struct* name) (cons 'pointer (cons 'struct name)))
(define (w/union* name) (cons 'pointer (cons 'union name)))

(define (udict->typenames udict)
  (fold
   (lambda (pair seed)
     (let ((name (car pair)) (decl (cdr pair)))
       (if (eq? 'typedef (and=> (sx-ref* decl 1 1 1) sx-tag))
	   (cons name seed)
	   seed)))
   '() udict))

(define (rename name)
  ((*renamer*) name))

;; === output scheme module header 

(define (ffimod-header path module-opts)
  (let* ((attrs (opts->attrs module-opts '()))
	 (pkg-config (assq-ref attrs 'pkg-config))
	 (libraries (resolve-attr-val (assq-ref attrs 'library)))
	 (libraries (append
		     (if pkg-config (pkg-config-libs pkg-config) '())
		     libraries)))
    (sfscm ";; generated with `guild compile-ffi ~A.ffi'\n" (path->path path))
    (nlscm)
    (sfscm "(define-module ~S\n" path)
    (for-each
     (lambda (pair)
       (cond
	((eq? 'use-ffi-module (car pair))
	 (sfscm "  #:use-module ~S\n" (cdr pair)))))
     module-opts)
    ;;
    (for-each ;; output pass-through options
     (lambda (pair) (sfscm "  ~S " (car pair)) (ppscm (cdr pair)))
     (opts->mopts module-opts))
    ;;
    (sfscm "  #:use-module (system ffi-help-rt)\n")
    (sfscm "  #:use-module ((system foreign) #:prefix ffi:)\n")
    (sfscm "  #:use-module (bytestructures guile)\n")
    (sfscm "  )\n")
    ;;
    (ppscm
     `(define ,(link-libs)
	(list ,@(map (lambda (l) `(dynamic-link ,l)) (reverse libraries)))))
    ;;(sfscm "(define link-lib (car link-libs))\n")
    (if (*echo-decls*) (sfscm "(define echo-decls #t)\n"))))

;; === type conversion ==============

;; argument and return values will be
;; @item int types
;; @item double float
;; @item enum => int
;; @item function (pointer)
;; @item void
;; @item pointer
;; @item struct
;; @item union
;; strings dealt with by user

;; determine if type is an "alias", that is same
;; typedef int foo_t => int
;; but use (define foo_t (bs:pointer int))

(define bs-typemap
  '(("void" . 'void) ("float" . float) ("double" . double)
    ("short" . short) ("short int" . short) ("signed short" . short)
    ("signed short int" . short) ("int" . int) ("signed" . int)
    ("signed int" . int) ("long" . long) ("long int" . long)
    ("signed long" . long) ("signed long int" . long) ("long long" . long)
    ("long long int" . long) ("signed long long" . long)
    ("signed long long int" . long)
    ("unsigned short int" . unsigned-short) ("unsigned short" . unsigned-short)
    ("unsigned int" . unsigned-int) ("unsigned" . unsigned-int)
    ("unsigned long int" . unsigned-long) ("unsigned long" . unsigned-long)
    ("unsigned long long int" . unsigned-long)
    ("unsigned long long" . unsigned-long)
    ("intptr_t" . intptr_t) ("uintptr_t" . uintptr_t) ("size_t" . size_t)
    ("ssize_t" . ssize_t) ("ptrdiff_t" . ptrdiff_t)
    ("int8_t" . int8) ("uint8_t" . uint8) 
    ("int16_t" . int16) ("uint16_t" . uint16) 
    ("int32_t" . int32) ("uint32_t" . uint32)
    ("int64_t" . int64) ("uint64_t" . uint64)
    ("float _Complex" . complex64) ("double _Complex" . complex128)
    ;; hacks:
    ("char" . int8) ("signed char" . int8) ("unsigned char" . uint8)
    ("wchar_t" . int) ("char16_t" . int16) ("char32_t" . int32)
    ("_Bool" . int8)
    ))

(define bs-defined (map car bs-typemap))

(define (const-expr->number expr)
  (catch 'c99-error
    (lambda () (eval-c99-cx expr (*udict*) (*ddict*)))
    (lambda (key fmt . args)
      (apply throw 'ffi-help-error fmt args))))

;; just the type, so parent has to build the name-value pairs for
;; struct members
(define (mtail->bs-desc mdecl-tail)
  (let ((defined (*defined*))) ;; (udict (*udict*)))
    (pmatch mdecl-tail
      ;; expand typeref, use renamer,
      (((typename ,name))
       (let ((name (rename name)))
	 (or (assoc-ref bs-typemap name)
	     (string->symbol (string-append name "-desc")))))

      (((void)) ''void)
      (((fixed-type "char")) 'int)
      (((fixed-type "unsigned char")) 'unsigned-int)
      (((fixed-type ,fx-name)) (assoc-ref bs-typemap fx-name))
      (((float-type ,fl-name)) (assoc-ref bs-typemap fl-name))
      (((enum-def (ident ,ident) ,rest)) 'int)
      (((enum-def ,rest)) 'int)

      (((struct-def (ident ,struct-name) ,field-list))
       (mtail->bs-desc `((struct-def ,field-list))))
      (((struct-def ,field-list))
       `(bs:struct (list ,@(cnvt-field-list field-list))))
      (((struct-ref (ident ,struct-name)))
       (string->symbol (string-append "struct-" struct-name "-desc")))
      
      (((union-def (ident ,union-name) ,field-list))
       (mtail->bs-desc `((union-def ,field-list))))
      (((union-def ,field-list))
       (list 'bs:union `(list ,@(cnvt-field-list field-list))))
      (((union-ref (ident ,union-name)))
       (string->symbol (string-append "union-" union-name "-desc")))

      ;; POINTERS

      ;; typename use renamers, ... ???
      (((pointer-to) (typename ,name))
       (let ((name (rename name)))
	 (cond
	  ((assoc-ref bs-typemap name) =>
	   (lambda (n) `(bs:pointer ,n)))
	  ((member (w/* name) defined)
	   (strings->symbol name "*-desc"))
	  ((member name defined)
	   `(bs:pointer ,(strings->symbol name "-desc")))
	  (else
	   (strings->symbol name "*-desc")))))

      (((pointer-to) (void))
       `(bs:pointer 'void))

      (((pointer-to) (fixed-type "char"))
       `(bs:pointer int8))
      (((pointer-to) (fixed-type ,fx-name))
       `(bs:pointer ,(assoc-ref bs-typemap fx-name)))
      (((pointer-to) (float-type ,fx-name))
       `(bs:pointer ,(assoc-ref bs-typemap fx-name)))

      ;; bs does not support function pointers
      (((function-returning . ,rest) . ,rest)
       `(bs:pointer 'void))
      (((pointer-to) (function-returning . ,rest) . ,rest)
       `(bs:pointer 'void))
      (((pointer-to) (pointer-to) (function-returning . ,rest) . ,rest)
       `(bs:pointer 'void))

      (((pointer-to) (struct-ref . ,rest))
       (let () ;; TODO: check for struct-def ???
	 `(bs:pointer 'void)))

      ;; should use this more
      (((pointer-to) . ,rest)
       `(bs:pointer ,(mtail->bs-desc rest)))

      ;; In C99 array parameters are interpreted as pointers.
      (((array-of ,n) (fixed-type ,name))
       (let ((ns (const-expr->number n)))
	 (cond
	  ((string=? name "char") `(bs:vector ,ns int8))
	  ((string=? name "unsigned char") `(bs:vector ,ns uint8))
	  (else `(bs:vector ,ns ,(mtail->bs-desc `((fixed-type ,name))))))))
      (((array-of ,n) . ,rest)
       `(bs:vector ,(const-expr->number n) ,(mtail->bs-desc rest)))
      (((array-of) . ,rest)
       `(bs:pointer ,(mtail->bs-desc rest)))

      (((bit-field ,size) . ,rest)
       `(bit-field ,(const-expr->number size) ,(mtail->bs-desc rest)))

      (,otherwise
       (sferr "mtail->bs-desc missed mdecl:\n")
       (pperr mdecl-tail)
       (fherr "mtail->bs-desc failed")))))


;; --- output routines ---------------

(define (fhscm-export-def name)
  (let* ((name (rename name))
	 (st-name (if (string? name) name (symbol->string name)))
	 (sy-name (if (string? name) (string->symbol name) name))
	 (pred (string->symbol (string-append st-name "?")))
	 (make (string->symbol (string-append "make-" st-name))))
    ;;(sfscm "(export ~A ~A? make-~A)\n" name name name)
    (upscm `(export ,sy-name ,pred ,make))))

;;(define (fhscm-export-pdef name)
;;  (sfscm "(export ~A* ~A*? make-~A*)\n" name name name))

(define (fhscm-def-alias name orig)
  (let* ((name (rename name))
	 (s-name (if (string? name) (string->symbol name) name))
	 (s-orig (if (string? orig) (string->symbol orig) orig)))
    (ppscm `(define-public ,s-name ,s-orig))))

(define (fhscm-def-desc name desc)
  (let* ((name (rename name))
	 (s-name (if (string? name) (string->symbol name) name))
	 (s-desc (if (string? desc) (string->symbol desc) desc)))
    (ppscm `(define-public ,s-name ,s-desc))))

(define (fhscm-def-*desc name)
  (let ((name (rename name)))
    (sfscm "(define-public ~A* (bs:pointer ~A-desc))\n" name name)))

(define (fhscm-def-*desc/delay name)
  (let ((name (rename name)))
    (sfscm "(define-public ~A* (bs:pointer (delay ~A-desc)))\n" name name)))

(define (fhscm-def-compound name)
  (let* ((name (rename name))
	 (st-name (if (string? name) name (symbol->string name)))
	 (sy-name (if (string? name) (string->symbol name) name))
	 (desc (string->symbol (string-append st-name "-desc")))
	 (pred (string->symbol (string-append st-name "?")))
	 (make (string->symbol (string-append "make-" st-name))))
    (upscm `(define-fh-compound-type ,sy-name ,desc ,pred ,make))
    (fhscm-export-def name)))

(define (fhscm-def-pointer name)
  (let* ((name (rename name))
	 (st-name (if (string? name) name (symbol->string name)))
	 (sy-name (if (string? name) (string->symbol name) name))
	 (desc (string->symbol (string-append st-name "-desc")))
	 (pred (string->symbol (string-append st-name "?")))
	 (make (string->symbol (string-append "make-" st-name))))
    (upscm `(define-fh-pointer-type ,sy-name ,desc ,pred ,make))
    (fhscm-export-def name)))

(define (fhscm-def-pointer/delay name)
  (let ((name (rename name)))
    (sfscm "(define-fh-pointer-type ~A* ~A*-desc\n" name)
    (sfscm "  ~A*? make-~A*)\n" name name)
    (fhscm-export-def name)))

(define (fhscm-ref-deref typename)
  (let* ((typename (rename typename))
	 (type* (strings->symbol typename "*"))
	 (make* (strings->symbol "make-" typename "*"))
	 (type (strings->symbol typename))
	 (make (strings->symbol "make-" typename)))
    (ppscm `(ref<->deref! ,type* ,make* ,type ,make))))

(define (fhscm-def-function* name return params)
  (let* ((st-name (if (string? name) name (symbol->string name)))
	 (sy-name (if (string? name) (string->symbol name) name))
	 (wrap (string->symbol (string-append "fh-wrap-" st-name)))
	 (unwrap (string->symbol (string-append "unwrap-" st-name))))
    (sfscm "(define-public ~A-desc\n" name)
    (ppscm `(bs:pointer (delay (fh:function ,return (list ,@params))))
	   #:per-line-prefix "  ")
    (sfscm "  )\n")
    (ppscm `(define-fh-function*-type ,sy-name
	      ,(string->symbol (string-append name "-desc"))
	      ,(string->symbol (string-append name "?"))
	      ,(string->symbol (string-append "make-" name))
	      ))
    (fhscm-export-def name)))

(define* (fhscm-def-fixed name)
  (sfscm "(define unwrap-~A unwrap~~fixed)\n" name)
  (sfscm "(define wrap-~A identity)\n" name))

(define* (fhscm-def-float name)
  (sfscm "(define unwrap-~A unwrap~~float)\n" name)
  (sfscm "(define wrap-~A identity)\n" name))

;; --- structs and unions

;; scheme-bytestructures will be adding
;;   bounding-struct-descriptor union-desc => struct-desc

;; This routine will munge the fields and then perform typeref expansion.
;; `defined' here means has -desc (what?)
(define (expand-field-list-typerefs field-list)
  (let ((udict (*udict*)) (defined (*defined*)))
    (cons 'field-list
	  (fold-right
	   (lambda (pair seed)
	     (cons (expand-typerefs (cdr pair) udict defined) seed))
	   '() (fold-right unitize-comp-decl '() (cdr field-list))))))

;; field-list is (field-list . ,fields)
(define (cnvt-field-list field-list)

  (define (acons-defn name type seed)
    (cons (eval-string (simple-format #f "(quote `(~A ,~S))" name type)) seed))

  (define (acons-bfld name type seed)	; bit-field
    (let ((size (list-ref type 1)) (type (list-ref type 2)))
      (cons (eval-string
	     (simple-format #f "(quote `(~A ,~S ~A))" name type size)) seed)))

  ;;(sferr "\nfield-list:\n") (pperr field-list)
  (let* ((field-list (clean-field-list field-list)) ; remove lone comments
	 (uflds (fold-right unitize-comp-decl '() (cdr field-list))))
    ;;(sferr "field-list:\n") (pperr field-list)
    (let loop ((decls uflds))
      (if (null? decls) '()
	  (let* ((name (caar decls))
		 (udecl (cdar decls))
		 ;; fix the following, look at cleanup-udecl
		 (udecl (udecl-rem-type-qual udecl)) ;; remove "const" "extern"
		 (spec (udecl->mdecl/comm udecl))
		 (tail (cddr spec))
		 (type (mtail->bs-desc tail)))
	    (cond
	     ((and (pair? type) (eq? 'bit-field (car type)))
	      (acons-bfld name type (loop (cdr decls)))) ; bit-field
	     (else
	      (acons-defn name type (loop (cdr decls))))))))))

;; @deffn {Procedure} cnvt-aggr-def aggr-t typename aggr-name field-list
;; Output an aggregate definition, where
;; @var{attr-t} is a string of @code{"struct"} or @code{"union"},
;; @var{typename} is a string for the typename, or @code{#f},
;; @var{aggr-name} is a string for the struct or union name, or @code{#f},
;; and @var{field-list} is the field-list from the C syntax tree.
;; @end deffn
(define (cnvt-aggr-def aggr-t attr typename aggr-name field-list)
  (let* ((field-list (expand-field-list-typerefs field-list))
	 (sflds (cnvt-field-list field-list))
	 (aggr-s (symbol->string aggr-t))
	 (aggrname (and aggr-name (string-append aggr-s "-" aggr-name)))
	 (bs-aggr-t (string->symbol (string-append "bs:" aggr-s)))
	 (ty-desc (and typename (strings->symbol typename "-desc")))
	 (ty*-desc (and typename (strings->symbol typename "*-desc")))
	 (ag-desc (and aggrname (strings->symbol aggrname "-desc")))
	 (ag*-desc (and aggrname (strings->symbol aggrname "*-desc")))
	 (cattr (assoc-ref attr 'attributes)) ;; __attributes__
	 (packed? (and=> cattr
			 (lambda (l) (string-contains (car l) "__packed__" 0))))
	 (aligned? (and=> cattr
			 (lambda (l) (string-contains (car l) "__alignof__" 0))))
	 (bs-spec (if packed?
		      (list bs-aggr-t #t `(list ,@sflds))
		      (list bs-aggr-t `(list ,@sflds)))))
    (if aligned? (sferr "ffi-help: not processing __aligned__ in ~S\n"
			(or aggr-t typename)))
    (cond
     ((and typename aggr-name)
      ;;(sfscm ";; == ~A =>\n" typename)
      (ppscm `(define-public ,ty-desc ,bs-spec))
      (fhscm-def-compound typename)
      (ppscm `(define-public ,ty*-desc (bs:pointer ,ty-desc)))
      (fhscm-def-pointer (sw/* typename))
      (fhscm-ref-deref typename)
      ;;(sfscm ";; == ~A =>\n" aggrname)
      (ppscm `(define-public ,ag-desc ,ty-desc))
      (fhscm-def-compound aggrname)
      (ppscm `(define-public ,ag*-desc ,ty*-desc))
      (fhscm-def-pointer (sw/* aggrname))
      (fhscm-ref-deref aggrname))
     (typename
      (ppscm `(define-public ,ty-desc ,bs-spec))
      (fhscm-def-compound typename)
      (ppscm `(define-public ,ty*-desc (bs:pointer ,ty-desc)))
      (fhscm-def-pointer (sw/* typename))
      (fhscm-ref-deref typename))
     (aggr-name
      (ppscm `(define-public ,ag-desc ,bs-spec))
      (fhscm-def-compound aggrname)
      (ppscm `(define-public ,ag*-desc (bs:pointer ,ag-desc)))
      (fhscm-def-pointer (sw/* aggrname))
      (fhscm-ref-deref aggrname)))))

(define (cnvt-struct-def attr typename struct-name field-list)
  (cnvt-aggr-def 'struct attr typename struct-name field-list))

(define (cnvt-union-def attr typename union-name field-list)
  (cnvt-aggr-def 'union attr typename union-name field-list))

;; --- enums

(define (fhscm-def-enum name name-val-list)
  (sfscm "(define ~A-enum-nvl\n" name)
  (ppscm `(quote ,name-val-list) #:per-line-prefix "  ")
  (sfscm "  )\n")
  (sfscm "(define ~A-enum-vnl\n" name)
  (sfscm "  (map (lambda (pair) (cons (cdr pair) (car pair)))\n")
  (sfscm "       ~A-enum-nvl))\n" name)
  (sfscm "(define-public (unwrap-~A n)\n" name)
  (sfscm "  (cond\n")
  (sfscm "   ((symbol? n)\n")
  (sfscm "    (or (assq-ref ~A-enum-nvl n) (error \"bad arg\")))\n" name)
  (sfscm "   ((integer? n) n)\n")
  (sfscm "   (else (error \"bad arg\"))))\n")
  (sfscm "(define-public (wrap-~A v)\n" name)
  (sfscm "  (assq-ref ~A-enum-vnl v))\n" name))

(define (cnvt-enum-def typename enum-name enum-def-list)
  (let* ((name-val-l
	  (map
	   (lambda (def)
	     (let* ((n (sx-ref (sx-ref def 1) 1))
		    (x (sx-ref def 2))
		    (v (eval-c99-cx x '())))
	       (unless v
		 (throw 'ffi-help-error "unable to generate constant for ~S" n))
	       (cons (string->symbol n) v)))
	   (cdr (canize-enum-def-list enum-def-list)))))
    (cond
     ((and typename enum-name)
      (fhscm-def-enum typename name-val-l)
      (sfscm "(define-public unwrap-enum-~A unwrap-~A)\n" enum-name typename)
      (sfscm "(define-public wrap-enum-~A wrap-~A)\n" enum-name typename)
      )
     (typename
      (fhscm-def-enum typename name-val-l))
     (enum-name
      (fhscm-def-enum (string-append "enum-" enum-name) name-val-l)))))

;; === function declarations : signatures for pointer->procedure

(define ffi-typemap
  ;; see system/foreign.scm
  '(("void" . ffi:void) ("float" . ffi:float) ("double" . ffi:double)
    ;;
    ("short" . ffi:short) ("short int" . ffi:short) ("signed short" . ffi:short)
    ("signed short int" . ffi:short) ("int" . ffi:int) ("signed" . ffi:int)
    ("signed int" . ffi:int) ("long" . ffi:long) ("long int" . ffi:long)
    ("signed long" . ffi:long) ("signed long int" . ffi:long)
    ("unsigned short int" . ffi:unsigned-short)
    ("unsigned short" . ffi:unsigned-short) ("unsigned int" . ffi:unsigned-int)
    ("unsigned" . ffi:unsigned-int) ("unsigned long int" . ffi:unsigned-long)
    ("unsigned long" . ffi:unsigned-long)
    ;;
    ("size_t" . ffi:size_t)
    ;;
    ("ssize_t" . ffi:ssize_t) ("ptrdiff_t" . ffi:ptrdiff_t)
    ("int8_t" . ffi:int8) ("uint8_t" . ffi:uint8) 
    ("int16_t" . ffi:int16) ("uint16_t" . ffi:uint16) 
    ("int32_t" . ffi:int32) ("uint32_t" . ffi:uint32) 
    ("int64_t" . ffi:int64) ("uint64_t" . ffi:uint64)
    ;; hacks
    ("intptr_t" . ffi:long) ("uintptr_t" . ffi:unsigned-long)
    ("char" . ffi:int8) ("signed char" . ffi:int8) ("unsigned char" . ffi:uint8)
    ("wchar_t" . int) ("char16_t" . int16) ("char32_t" . int32)
    ("long long" . ffi:long) ("long long int" . ffi:long)
    ("signed long long" . ffi:long) ("signed long long int" . ffi:long)
    ("unsigned long long" . ffi:unsigned-long)
    ("unsigned long long int" . ffi:unsigned-long)
    ("_Bool" . ffi:int8)))

(define ffi-defined (map car ffi-typemap))

(define ffi-symmap
  `((ffi:void . ,void) (ffi:float . ,float) (ffi:double . ,double)
    (ffi:short . ,short) (ffi:int . ,int) (ffi:long . ,long)
    (ffi:unsigned-short . ,unsigned-short) (ffi:unsigned-int . ,unsigned-int)
    (ffi:unsigned-long . ,unsigned-long) (ffi:size_t . ,size_t)
    (ffi:ssize_t . ,ssize_t) (ffi:ptrdiff_t . ,ptrdiff_t) (ffi:int8 . ,int8)
    (ffi:uint8 . ,uint8) (ffi:int16 . ,int16) (ffi:uint16 . ,uint16)
    (ffi:int32 . ,int32) (ffi:uint32 . ,uint32) (ffi:int64 . ,int64)
    (ffi:uint64 . ,uint64) (ffi-void* . *)))

(define (mtail->ffi-desc mdecl-tail)
  ;;(sferr "mdecl=~S\n" mdecl)
  (if (and (pair? mdecl-tail) (string? (car mdecl-tail))) (error "xxx"))
  (pmatch mdecl-tail
    (((pointer-to) . ,rest) 'ffi-void*)
    (((array-of) . ,rest) 'ffi-void*)
    (((array-of ,size) . ,rest) 'ffi-void*)
    (((fixed-type ,name))
     (or (assoc-ref ffi-typemap name)
	 (fherr/once "no FFI type for ~A" name)))
    (((float-type ,name))
     (or (assoc-ref ffi-typemap name)
	 (fherr/once "no FFI type for ~S" name)))
    (((typename ,name) . ,rest)
     (or (assoc-ref ffi-typemap name)
	 (fherr "no FFI type for ~S" name)))
    (((void)) 'ffi:void)
    (((enum-def . ,rest2) . ,rest1) 'ffi:int)
    (((enum-ref . ,rest2) . ,rest1) 'ffi:int)

    (((struct-def (field-list . ,fields)))
     `(list ,@(map (lambda (fld)
		     (let* ((udict (unitize-comp-decl fld))
			    (name (caar udict))
			    (udecl (cdar udict))
			    (udecl (udecl-rem-type-qual udecl))
			    (mdecl (udecl->mdecl udecl)))
		       (mtail->ffi-desc (cdr mdecl))))
		   fields)))
    (((struct-def (ident ,name) ,field-list))
     (mtail->ffi-desc `((struct-def ,field-list))))
    
    (((union-def (field-list . ,fields)))
     ;; TODO check libffi on how unions are passed and returned.
     ;; I assume here never passed as a floating point.
     ;; This should use bounding-struct-descriptor from bytestructures
     (let loop ((type #f) (size 0) (flds fields))
       (if (null? flds)
	   (case type ((double) 'ffi:uint64) ((float) 'ffi:uint32) (else type))
	   (let* ((udict (unitize-comp-decl (car flds)))
		  (udecl (cdar udict))
		  (udecl (udecl-rem-type-qual udecl))
		  (mdecl (udecl->mdecl udecl))
		  (ftype (mtail->ffi-desc (cdr mdecl)))
		  (ftval (assq-ref ffi-symmap ftype))
		  (fsize (sizeof ftval)))
	     (if (> fsize size)
		 (loop ftype fsize (cdr flds))
		 (loop type size (cdr flds)))))))
    (((union-def (ident ,name) ,field-list))
     (mtail->ffi-desc `((union-def ,field-list))))
    
    (,otherwise
     (sferr "mtail->ffi-desc missed:\n") (pperr mdecl-tail) ;;(quit)
     (error "") (fherr "mtail->ffi-desc missed: ~S" mdecl-tail))))

;; Return a mdecl for the return type.  The variable is called @code{NAME}.
(define (gen-decl-return udecl)
  (let* ((udecl1 (expand-typerefs udecl (*udict*) ffi-defined))
	 (udecl (udecl-rem-type-qual udecl1))
	 (mdecl (udecl->mdecl udecl1)))
    (mtail->ffi-desc (cdr mdecl))))

(define (gen-bs-decl-return udecl)
  (let* ((udecl1 (expand-typerefs udecl (*udict*) ffi-defined))
	 (udecl (udecl-rem-type-qual udecl1))
	 (mdecl (udecl->mdecl udecl1)))
    (mtail->bs-desc (cdr mdecl))))

(define (int->name ix)
  (simple-format #f "arg-~A" ix))

(define (gen-decl-params params)
  ;; Note that expand-typerefs will not eliminate enums or struct-refs :
  ;; mtail->ffi-desc needs to convert enum to int or void*
  (let loop ((ix 0) (params (fix-params params)))
    (cond
     ((null? params) '())
     ;;((equal? (car params) '(ellipsis)) (fherr/once "no varargs (yet)") '...)
     ((equal? (car params) '(ellipsis)) '())
     (else
      ;;(sferr "\nP: ~S\n" (car params))
      (let* ((udecl1 (expand-typerefs (car params) (*udict*) ffi-defined))
	     (udecl1 (udecl-rem-type-qual udecl1))
	     (mdecl (udecl->mdecl udecl1 #:add-name (int->name ix))))
	;;(sferr "  ~S\n" udecl1)
	(cons (mtail->ffi-desc (cdr mdecl))
	      (loop (1+ ix) (cdr params))))))))

(define (gen-bs-decl-params params)
  ;; Note that expand-typerefs will not eliminate enums or struct-refs :
  ;; mtail->ffi-desc needs to convert enum to int or void*
  (let loop ((ix 0) (params (fix-params params)))
    (cond
     ((null? params) '())
     ((equal? (car params) '(ellipsis)) '())
     (else
      (let* ((udecl1 (expand-typerefs (car params) (*udict*) ffi-defined))
	     (udecl1 (udecl-rem-type-qual udecl1))
	     (mdecl (udecl->mdecl udecl1 #:add-name (int->name ix))))
	(cons (mtail->bs-desc (cdr mdecl))
	      (loop (1+ ix) (cdr params))))))))

;; === function calls : unwrap args, call, wrap return

;; given mdecl for an exec argument give the unwrapper
(define (mdecl->fh-unwrapper mdecl)
  ;;(sferr "mdecl:\n") (pperr mdecl)
  (let ((wrapped (*wrapped*)) (defined (*defined*)))
    ;; git_reference_foreach_name_cb not preserved
    (pmatch (cdr mdecl)
      (((fixed-type ,name)) 'unwrap~fixed)
      (((float-type ,name)) 'unwrap~float)
      (((void)) #f)
      (((typename ,name))
       (cond ;; bit of a hack
	((member name '("float" "double")) 'unwrap~float)
	((member name '("float _Complex" "double _Complex")) 'unwrap~complex)
	((member name bs-defined) 'unwrap~fixed)
	((member name defined) `(fht-unwrap ,(string->symbol name)))
	((member name wrapped) (string->symbol (string-append "unwrap-" name)))
	(else #f)))
      
      (((enum-def (ident ,name) ,rest))
       (cond
	((member (w/enum name) wrapped)
	 (string->symbol (string-append "unwrap-enum-" name)))
	(else 'unwrap-enum)))
      (((enum-ref (ident ,name)))
       (cond
	((member (w/enum name) wrapped)
	 (string->symbol (string-append "unwrap-enum-" name)))
	(else 'unwrap-enum)))

      (((pointer-to) (typename ,typename))
       (cond
	;;((member typename ffi-defined) 'unwrap~pointer)
	((member (w/* typename) defined)
	 `(fht-unwrap ,(string->symbol (sw/* typename))))
	((member (w/* typename) wrapped)
	 (strings->symbol "unwrap-" typename "*"))
	((member typename defined)
	 `(fht-unwrap ,(string->symbol (sw/* typename))))
	((member (w/* typename) wrapped)
	 (strings->symbol "unwrap-" typename "*"))
	(else #f)))

      (((pointer-to) (struct-ref (ident ,struct-name) . ,rest))
       (cond
	((member (w/struct* struct-name) defined)
	 `(fht-unwrap ,(strings->symbol "struct-" struct-name "*")))
	((member (w/struct struct-name) defined)
	 `(fht-unwrap ,(strings->symbol "struct-" struct-name "*")))
	(else 'unwrap~pointer)))

      (((pointer-to) (function-returning (param-list . ,params)) . ,rest)
       (let* ((udecl (mdecl->udecl (cons "~ret" rest)))
	      (udecl (expand-typerefs udecl (*udict*) ffi-defined))
	      (mdecl (udecl->mdecl udecl))
	      (decl-return (mtail->ffi-desc (cdr mdecl)))
	      (decl-params (gen-decl-params params)))
	 ;;(sferr "FIX RET => ~S\n" mdecl)
	 (if (and (pair? decl-params) (equal? (last decl-params) '...))
	     (fherr/once "no varargs (yet)"))
	 `(make-fctn-param-unwrapper ,decl-return (list ,@decl-params))))
      
      (((pointer-to) . ,otherwise) 'unwrap~pointer)

      ;; TODO: int b[]
      ;; make ffi-help-rt unwrap bytevector  
      (((array-of ,size) . ,rest) 'unwrap~array)
      (((array-of) . ,rest) 'unwrap~array)

      (,otherwise
       (sferr "mdecl->fh-unwrapper missed:\n") (pperr mdecl) (quit)
       (fherr "mdecl->fh-unwrapper missed: ~S" mdecl)))))

(define (mdecl->fh-wrapper mdecl)
  (let ((wrapped (*wrapped*)) (defined (*defined*)))
    (pmatch (cdr mdecl)
      (((fixed-type ,name)) (if (assoc-ref ffi-typemap name) #f
				(fherr "todo: ffi-wrap fixed")))
      (((float-type ,name)) (if (assoc-ref ffi-typemap name) #f
				(fherr "todo: ffi-wrap float")))
      (((void)) #f)
      (((typename ,name))
       (cond
	((member name bs-defined) #f)
	((member name defined) `(fht-wrap ,(string->symbol name)))
	((member name wrapped) (string->symbol (string-append "wrap-" name)))
	(else #f)))

      (((enum-def (ident ,name) ,rest))
       (cond
	((member (w/enum name) wrapped)
	 (string->symbol (string-append "wrap-enum-" name)))
	(else 'wrap-enum)))
      (((enum-ref (ident ,name)))
       (cond
	((member (w/enum name) wrapped)
	 (string->symbol (string-append "wrap-enum-" name)))
	(else 'wrap-enum)))

      (((pointer-to) (typename ,typename))
       (cond
	;;??((member typename ffi-defined) 'wrap~pointer)
	((member typename defined)
	 `(fht-wrap ,(strings->symbol typename "*")))
	((member typename wrapped)
	 (strings->symbol "wrap-" typename "*"))
	(else #f)))
      
      (((pointer-to) (struct-ref (ident ,struct-name) . ,rest))
       (cond
	((member (w/struct struct-name) wrapped)
	 `(fht-wrap ,(string->symbol (sw/struct* struct-name))))
	(else #f)))

      (((pointer-to) (union-ref (ident ,union-name) . ,rest))
       (cond
	((member (w/union union-name) wrapped)
	 `(fht-wrap ,(string->symbol (sw/union* union-name))))
	(else #f)))

      ;;(((pointer-to) . ,otherwise) 'ffi:make-pointer)
      (((pointer-to) . ,otherwise) #f)

      (,otherwise (fherr "mdecl->fh-wrapper missed: ~S" mdecl)))))

;; given list of udecl params generate list of name-unwrap pairs
(define (gen-exec-params params)
  (fold-right
   (lambda (param-decl seed)
     (cond
      ;;((equal? (car params) '(ellipsis)) (fherr/once "no varargs (yet)") '...)
      ((equal? param-decl '(ellipsis)) seed)
      (else
       ;; Changed to (*wrapped*) to include enum types.  If we need (*defined*)
       ;; then we will need to create enum types in cnvt-udecl typedefs.
       (let* ((param-decl (expand-typerefs param-decl (*udict*) (*wrapped*)))
	      (param-decl (udecl-rem-type-qual param-decl)) ;; ???
	      (mdecl (udecl->mdecl param-decl)))
	 (acons (car mdecl) (mdecl->fh-unwrapper mdecl) seed)))))
   '() params))

;; given list of name-unwrap pairs generate function arg names
(define (gen-exec-arg-names params)
  (map (lambda (s) (string->symbol (car s))) params))

(define (gen-exec-unwrappers params)
  (fold-right
   (lambda (name-unwrap seed)
     (let ((name (car name-unwrap))
	   (unwrap (cdr name-unwrap)))
       (if unwrap
	   (cons `(,(string->symbol (string-append "~" name))
		   (,unwrap ,(string->symbol name)))
		 seed)
	   seed)))
   '()
   params))

;; This generates the list of arguments to the actual call.
(define (gen-exec-call-args params)
  (fold-right
   (lambda (name-unwrap seed)
     (let ((name (car name-unwrap))
	   (unwrap (cdr name-unwrap)))
       (cons (string->symbol (if unwrap (string-append "~" name) name)) seed)))
   '()
   params))

(define (gen-exec-return-wrapper udecl)
  (let* ((udecl (expand-typerefs udecl (*udict*) (*wrapped*)))
	 (udecl (udecl-rem-type-qual udecl))
	 (mdecl (udecl->mdecl udecl)))
    (mdecl->fh-wrapper mdecl)))

(define (fix-params param-decls)

  (define (remove-void-param params)
    (if (and (pair? params) (null? (cdr params))
	     (equal? (car params)
		     '(param-decl (decl-spec-list (type-spec (void))))))
	'() params))
  
  (define (fix-param param-decl ix)
    ;; should this fix param names? -- above code should deal with it
    (sxml-match param-decl
      ((param-decl (decl-spec-list . ,specl))
       `(param-decl (decl-spec-list . ,specl)
		    (init-declr (ident ,(simple-format #f "arg-~A" ix)))))
      (,otherwise param-decl)))

  (let loop ((ix 0) (decls (remove-void-param param-decls)))
    (if (null? decls) '()
	(cons (fix-param (car decls) ix) (loop (1+ ix) (cdr decls))))))

;; @deffn {Procedure} cnvt-fctn name specl params
;; name is string
;; specl is decl-spec-list tree
;; params is list of param-decl trees (i.e., cdr of param-list tree)
;; @end deffn
(define (cnvt-fctn name rdecl params)
  (let* ((params (fix-params params))
	 (varargs? (and (pair? params) (equal? (last params) '(ellipsis))))
	 (decl-return (gen-decl-return rdecl))
	 (decl-params (gen-decl-params params))
	 (exec-return (gen-exec-return-wrapper rdecl))
	 (exec-params (gen-exec-params params))
	 (sname (string->symbol name))
	 (~name (string->symbol (string-append "~" name)))
	 ;;(call `(,~name ,@(gen-exec-call-args exec-params)))
	 (va-call `(apply ,~name ,@(gen-exec-call-args exec-params)
			  (map cdr ~rest)))
	 (call `((force ,~name) ,@(gen-exec-call-args exec-params)))
	 )
    (cond
     (varargs?
      (sfscm ";; to be used with fh-cast\n")
      (ppscm
       `(define (,sname ,@(gen-exec-arg-names exec-params) . ~rest)
	  (let ((,~name (fh-link-proc
			 ,decl-return ,name
			 (append (list ,@decl-params) (map car ~rest))
			 ,(link-libs)))
		,@(gen-exec-unwrappers exec-params))
	    ,(if exec-return (list exec-return va-call) va-call)))))
     (#f ;; separate ~name and name defines
      (ppscm `(define ,~name
		(delay (fh-link-proc ,decl-return ,name (list ,@decl-params)
				     ,(link-libs)))))
      (ppscm
       `(define (,sname ,@(gen-exec-arg-names exec-params))
	  (let ,(gen-exec-unwrappers exec-params)
	    ,(if exec-return (list exec-return call) call)))))
     (else ;; combined ~name and name defines
      (ppscm
       `(define ,sname
	  (let ((,~name
		 (delay (fh-link-proc ,decl-return ,name (list ,@decl-params)
				      ,(link-libs)))))
	    (lambda ,(gen-exec-arg-names exec-params)
	      (let ,(gen-exec-unwrappers exec-params)
		,(if exec-return (list exec-return call) call))))))
      ))
    (sfscm "(export ~A)\n" name)))

;; === externs ========================

(define (cnvt-extern name ms-tail)
  (let ((desc (mtail->bs-desc ms-tail)))
    (sfscm ";; (~A) => bytestructure\n" name)
    (ppscm
     `(define-public ,(string->symbol name)
	(let ((x-promise (delay (fh-link-extern ,name ,desc ,(link-libs)))))
	  (lambda () (force x-promise)))))))

;; ------------------------------------

;; intended to provide decl's for pointer-to or vector-of args
(define (get-needed-defns params keep-list)
  (sferr "get-needed-defns [NOT DONE]\n") (pperr params)
  '())

;; extract (struct-def ...) from (udecl ...)
(define find-struct-def
  (let ((find-proc (sxpath '(// struct-def))))
    (lambda (udecl)
      (and=> (find-proc udecl) car))))

;; extract (union-def ...) from (udecl ...)
(define find-union-def
  (let ((find-proc (sxpath '(// union-def))))
    (lambda (udecl)
      (and=> (find-proc udecl) car))))


;; assume unit-declarator
;; TODO (ptr-declr (pointer (type-qual-list (type-qual "const"))))
;; See also stripdown-specl and stripdown-declr in @file{munge.scm}.
(define (cleanup-udecl specl declr)
  (let* ((fctn? (pair? ((sxpath '(// ftn-declr)) declr)))
	 (specl (remove (lambda (node)
			  (or (equal? node '(stor-spec (auto)))
			      (equal? node '(stor-spec (register)))
			      (equal? node '(stor-spec (static)))
			      (and (pair? node)
				   (equal? (car node) 'type-qual))))
			specl))
	 (specl (if fctn?
		    (remove (lambda (node)
			      (equal? node '(stor-spec (extern)))) specl)
		    specl)))
    (values specl declr)))

;; @deffn {Procecure} back-ref-extend! decl typename
;; @deffnx {Procecure} back-ref-getall decl typename
;; The first procecure adds a backward reference for a struct from typedef
;; forward reference.  The second procedure returns the list of references.
;; This is sort of a hack but don't want to carry a list of forward
;; references just yet.
;; @end deffn
(define (back-ref-extend! decl typename)
  (let ((aval (sx-attr-ref decl 'typedef)))
    (sx-attr-set! decl 'typedef
		  (if aval (string-append aval "," typename) typename))))
(define (back-ref-getall decl)
  (let ((aval (sx-attr-ref decl 'typedef)))
    (if aval (string-split aval #\,) '())))

;;(display "TODO: struct xyz { }; followed by typedef struct xyz *xyz_t\n")
;;^-- instead have user run (ref<->deref! ...

;; @deffn {Procedure} cnvt-udecl udecl udict wrapped defined)
;; Given udecl produce a ffi-spec.
;; Return updated (string based) keep-list, which will be modified if the
;; declaration is a typedef.  The typelist is the set of keepers used for
;; @code{udecl->mdecl}.
;; Returns values wrapped, defined.
;; @end deffn
;; NOT SURE WHAT defined MEANS NOW
;; was bytestructure in fh-type, but for
;; for any type we also declare a poitner type
;; TODO: decls need to be broken out into one of the forms:
;; function typedef struct-ref/def union-ref/def enum variable
(define (cnvt-udecl udecl udict wrapped defined)
  ;; This is a bit sloppy in that we have to know if the converters are
  ;; creating wrappers and/or (type) defines.
  
  (define (ptr-decl specl)
    `(udecl ,specl (init-declr (ptr-declr (pointer) (ident "_")))))
  (define (non-ptr-decl specl)
    `(udecl ,specl (init-declr (ident "_"))))
  
  ;; use fluids OR pass around
  (*wrapped* wrapped)
  (*defined* defined)

  (let*-values (((tag attr specl declr) (split-udecl udecl))
		((specl declr) (cleanup-udecl specl declr))
		((clean-udecl) (values (sx-list tag #f specl declr))))

    (sxml-match clean-udecl

      ;; typedef void **ptr_t;
      ((udecl
	(decl-spec-list
	 (stor-spec (typedef)) (type-spec (void)))
	(init-declr (ptr-declr (pointer (pointer)) (ident ,typename))))
       ;; FIX
       (sfscm "(define-public ~A-desc (bs:pointer (bs:pointer 'void)))\n"
	      typename)
       (fhscm-def-pointer typename)
       (values (cons typename wrapped) (cons typename defined)))
      
      ;; typedef void *ptr_t;
      ((udecl
	(decl-spec-list
	 (stor-spec (typedef)) (type-spec (void)))
	(init-declr (ptr-declr (pointer) (ident ,typename))))
       ;; FIX
       (sfscm "(define-public ~A-desc (bs:pointer 'void))\n" typename)
       (fhscm-def-pointer typename)
       (values (cons typename wrapped) (cons typename defined)))
      
      ;; typedef void proxy_t;
      ((udecl
	(decl-spec-list
	 (stor-spec (typedef))
	 (type-spec (void)))
	(init-declr (ident ,typename)))
       ;; FIX
       (sfscm "(define-public ~A-desc 'void)\n" typename)
       (sfscm "(define-public ~A*-desc (bs:pointer ~A-desc))\n"
	      typename typename)
       (fhscm-def-pointer (sw/* typename))
       (values (cons* typename (w/* typename) wrapped)
	       (cons* typename (w/* typename) defined)))
      
      ;; typedef int foo_t;
      ((udecl
	(decl-spec-list
	 (stor-spec (typedef))
	 (type-spec (fixed-type ,name)))
	(init-declr (ident ,typename)))
       ;; FIX
       (sfscm "(define-public ~A-desc ~A)\n"
	      typename (assoc-ref bs-typemap name))
       (values wrapped defined))

      ;; typedef double foo_t;
      ;; If fh-object? then should be bytestructure.
      ;; Should wrap be to number or bytestructure?
      ((udecl
	(decl-spec-list
	 (stor-spec (typedef))
	 (type-spec (float-type ,name)))
	(init-declr (ident ,typename)))
       (sfscm "(define-public ~A-desc ~A)\n"
	      typename (assoc-ref bs-typemap name))
       (values wrapped defined))

      ;; typedef foo_t *foo_ptr_t;
      ((udecl
	(decl-spec-list (stor-spec (typedef)) (type-spec (typename ,name)))
	(init-declr (ptr-declr (pointer) (ident ,typename))))
       (cond
	((member name defined)
	 ;; FIX
	 (sfscm "(define-public ~A-desc (bs:pointer ~A-desc))\n" typename name)
	 (fhscm-def-pointer typename))
	(else
	 ;; FIX
	 (sfscm "(define-public ~A-desc (bs:pointer 'void))\n" typename)
	 (fhscm-def-pointer typename)))
       (values (cons typename wrapped) (cons typename defined)))

      ;; typedef foo_t **foo_ptr_t;
      ((udecl
	(decl-spec-list (stor-spec (typedef)) (type-spec (typename ,name)))
	(init-declr (ptr-declr (pointer (pointer)) (ident ,typename))))
       (sfscm "(define-public ~A-desc (bs:pointer (bs:pointer ~A-desc)))\n"
	      typename name)
       (fhscm-def-pointer typename)
       (values (cons typename wrapped) (cons typename defined)))

      ;; typedef enum foo { ... } foo_t;
      ((udecl
	(decl-spec-list
	 (stor-spec (typedef))
	 (type-spec (enum-def (ident ,enum-name) ,enum-def-list . ,rest)))
	(init-declr (ident ,typename)))
       (cnvt-enum-def typename enum-name enum-def-list)
       (values (cons* typename (w/enum enum-name) wrapped) defined))

      ;; typedef enum { ... } foo_t;
      ((udecl
	(decl-spec-list
	 (stor-spec (typedef))
	 (type-spec (enum-def ,enum-def-list . ,rest)))
	(init-declr (ident ,typename)))
       (cnvt-enum-def typename #f enum-def-list)
       (values (cons typename wrapped) defined))

      ;; typedef enum foo foo_t;
      ((udecl
	(decl-spec-list
	 (stor-spec (typedef))
	 (type-spec (enum-ref (ident ,enum-name))))
	(init-declr (ident ,typename)))
       (sfscm "(define-public wrap-~A wrap-enum-~A)\n" typename enum-name)
       (sfscm "(define-public unwrap-~A unwrap-enum-~A)\n" typename enum-name)
       (values (cons typename wrapped) defined))

      ;; need better way ???
      ;; typedef struct foo { ... } foo_t;
      ;; missing typedef struct foo { ... } *foo_t;
      ;; typedef struct { ... } foo_t;
      ;; missing typedef struct { ... } *foo_t;
      ;; typedef struct foo foo_t;
      ;; typedef struct foo *foo_t;
      ;; =>
      ;; (decl-spec-list
      ;;  (stor-spec typedef) (type-spec (struct-def . ,rest)))
      ;; (init-declr . ,rest)
      ;; 

      ;; typedef struct foo { ... } foo_t;
      ((udecl
	(decl-spec-list
	 (stor-spec (typedef))
	 (type-spec (struct-def (@ . ,attr1) (ident ,struct-name) ,field-list)))
	(init-declr (ident ,typename)))
       (cnvt-struct-def attr1 typename struct-name field-list)
       (values
	;; Hoping don't need to add (w/struct* struct-name)
	(cons* typename (w/* typename) (w/struct struct-name) wrapped)
	(cons* typename (w/* typename) (w/struct struct-name) defined)))

      ;; typedef struct foo { ... } *foo_t;
      ((udecl
	(decl-spec-list
	 (stor-spec (typedef))
	 (type-spec (struct-def (@ . ,attr1) (ident ,struct-name) ,field-list)))
	(init-declr (ptr-declr (pointer) (ident ,typename))))
       (cnvt-struct-def attr1 #f struct-name field-list)
       (sfscm "(define-public ~A-desc struct-~A*-desc)\n" typename struct-name)
       (fhscm-def-pointer typename)
       (values
	(cons* typename (w/* typename)
	       (w/struct struct-name) (w/struct* struct-name)
	       wrapped)
	(cons* typename (w/* typename)
	       (w/struct struct-name) (w/struct* struct-name)
	       defined)))

      ;; typedef struct { ... } foo_t;
      ((udecl
	(decl-spec-list
	 (stor-spec (typedef))
	 (type-spec (struct-def (@ . ,attr1) ,field-list)))
	(init-declr (ident ,typename)))
       (cnvt-struct-def attr1 typename #f field-list)
       (values (cons* typename (w/* typename) wrapped)
	       (cons* typename (w/* typename) defined)))

      ;; typedef struct { ... } *foo_t;
      ((udecl
	(decl-spec-list
	 (stor-spec (typedef))
	 (type-spec (struct-def (@ . ,attr1) ,field-list)))
	(init-declr (ptr-declr (pointer) (ident ,typename))))
       (cnvt-struct-def attr1 (sw/* typename) #f field-list)
       (values (cons* (w/* typename) wrapped)
	       (cons* (w/* typename) defined)))

      ;; typedef struct foo foo_t;
      ((udecl
	(decl-spec-list
	 (stor-spec (typedef))
	 (type-spec (struct-ref (ident ,struct-name))))
	(init-declr (ident ,typename)))
       (cond
	;; This case represents three possible uses:
	((member (w/struct struct-name) defined)
	 ;; 1) struct defined previously
	 (sfscm "(define-public ~A-desc struct-~A-desc)\n" typename struct-name)
	 (sfscm "(define-public ~A*-desc struct-~A*-desc)\n"
		typename struct-name)
	 (fhscm-def-compound typename))
	((udict-struct-ref udict struct-name) =>
	 ;; 2) struct defined later
	 (lambda (struct-decl)
	   (back-ref-extend! struct-decl typename)
	   (sfscm "(define-public ~A-desc 'void)\n" typename)
	   (sfscm "(define-public ~A fh-void)\n" typename)
	   (sfscm "(define-public ~A? fh-void?)\n" typename)
	   (sfscm "(define-public make-~A make-fh-void)\n" typename)
	   (sfscm "(define-public ~A*-desc (bs:pointer (delay ~A-desc)))\n"
		  typename typename)
	   ))
	(else
	 ;; 3) struct never defined; only used as pointer
	 (sfscm "(define-public ~A-desc 'void)\n" typename)
	 (sfscm "(define-fh-type-alias ~A fh-void)\n" typename)
	 (sfscm "(define-public ~A? fh-void?)\n" typename)
	 (sfscm "(define-public make-~A make-fh-void)\n" typename)
	 (sfscm "(define-public ~A*-desc (bs:pointer ~A-desc))\n"
		typename typename)))
       (fhscm-def-pointer (sw/* typename))
       (values (cons* typename (w/* typename) wrapped)
	       (cons* typename (w/* typename) defined)))

      ;; typedef struct foo *foo_t;
      ((udecl
	(decl-spec-list
	 (stor-spec (typedef))
	 (type-spec (struct-ref (ident ,struct-name))))
	(init-declr (ptr-declr (pointer) (ident ,typename))))
       (cond
	;; This case represents three possible uses:
	((member struct-name defined)
	 ;; 1) struct defined previously
	 (sfscm "(define-public ~A-desc struct-~A*-desc)\n"
		typename struct-name))
	((udict-struct-ref udict struct-name) =>
	 ;; 2) struct defined later
	 (lambda (struct-decl)
	   (back-ref-extend! struct-decl (sw/& typename))
	   (sfscm "(define-public ~A&-desc 'void)\n" typename)
	   (sfscm "(define-public ~A-desc (bs:pointer (delay ~A&-desc)))\n"
		  typename typename)))
	(else
	 ;; 3) struct never defined; only used as pointer
	 (sfscm "(define-public ~A-desc (bs:pointer 'void))\n" typename)))
       (fhscm-def-pointer typename)
       (values (cons typename wrapped) (cons typename defined)))

      ;; typedef union foo { ... } foo_t;
      ((udecl
	(decl-spec-list
	 (stor-spec (typedef))
	 (type-spec (union-def (ident ,union-name) ,field-list)))
	(init-declr (ident ,typename)))
       (cnvt-union-def #f typename union-name field-list)
       (values
	(cons* typename (w/* typename) (w/union union-name) wrapped)
	(cons* typename (w/* typename) (w/union union-name) defined)))

      ;; typedef union { ... } foo_t;
      ((udecl
	(decl-spec-list
	 (stor-spec (typedef))
	 (type-spec (union-def ,field-list)))
	(init-declr (ident ,typename)))
       (cnvt-union-def #f typename #f field-list)
       (values (cons* typename (w/* typename) wrapped)
	       (cons* typename (w/* typename) defined)))

      ;; typedef union foo foo_t;
      ((udecl
	(decl-spec-list
	 (stor-spec (typedef))
	 (type-spec (union-ref (ident ,union-name))))
	(init-declr (ident ,typename)))
       (cond
	;; This case represents three possible uses:
	((member (w/union union-name) defined)
	 ;; 1) union defined previously
	 (sfscm "(define-public ~A-desc union-~A-desc)\n" typename union-name)
	 (sfscm "(define-public ~A*-desc union-~A*-desc)\n"
		typename union-name)
	 (fhscm-def-compound typename))
	((udict-union-ref udict union-name) =>
	 ;; 2) union defined later
	 (lambda (union-decl)
	   (back-ref-extend! union-decl typename)
	   (sfscm "(define-public ~A-desc 'void)\n" typename)
	   (sfscm "(define-public ~A fh-void)\n" typename)
	   (sfscm "(define-public ~A? fh-void?)\n" typename)
	   (sfscm "(define-public make-~A make-fh-void)\n" typename)
	   (sfscm "(define-public ~A*-desc (bs:pointer (delay ~A-desc)))\n"
		  typename typename)))
	(else
	 ;; 3) union never defined; only used as pointer
	 (sfscm "(define-public ~A-desc 'void)\n" typename)
	 (sfscm "(define-public ~A*-desc (bs:pointer ~A-desc))\n"
		typename typename)))
       (fhscm-def-pointer (sw/* typename))
       (values (cons* typename (w/* typename) wrapped)
	       (cons* typename (w/* typename) defined)))

      ;; typedef union foo *foo_t;
      ;; TODO: check for forward reference
      ((udecl
	(decl-spec-list
	 (stor-spec (typedef))
	 (type-spec (union-ref (ident ,union-name))))
	(init-declr (ptr-declr (pointer) (ident ,typename))))
       (cond
	;; This case represents three possible uses:
	((member union-name defined)
	 ;; 1) union defined previously
	 (sfscm "(define-public ~A-desc union-~A*-desc)\n"
		typename union-name))
	((udict-union-ref udict union-name) =>
	 ;; 2) union defined later
	 (lambda (union-decl)
	   (back-ref-extend! union-decl (sw/& typename))
	   (sfscm "(define-public ~A&-desc 'void)\n" typename)
	   (sfscm "(define-public ~A-desc (bs:pointer (delay ~A&-desc)))\n"
		  typename typename)))
	(else
	 ;; 3) union never defined; only used as pointer
	 (sfscm "(define-public ~A-desc (bs:pointer 'void))\n" typename)))
       (fhscm-def-pointer typename)
       (values (cons typename wrapped) (cons typename defined)))

      ;; typedef int (*foo_t)(int x, ...);
      ;; extern int git_reference_foreach(git_repository *repo, 
      ;;     git_reference_foreach_cb callback, void *payload);
      ((udecl
	(decl-spec-list (stor-spec (typedef)) . ,rst)
	(init-declr
	 (ftn-declr
	  (scope (ptr-declr (pointer) (ident ,typename)))
	  (param-list . ,params))))
       (let* ((ret-decl `(udecl (decl-spec-list . ,rst)
				(init-declr (ident "_"))))
	      (decl-return (gen-bs-decl-return ret-decl))
	      (decl-params (gen-bs-decl-params params))
	      )
	 (fhscm-def-function* typename decl-return decl-params))
       (values (cons typename wrapped) (cons typename defined)))

      ;; typedef void* (*foo_t)(int x, ...);
      ((udecl
	(decl-spec-list (stor-spec (typedef)) . ,rst)
	(init-declr
	 (ptr-declr
	  (pointer)
	  (ftn-declr
	   (scope (ptr-declr (pointer) (ident ,typename)))
	   (param-list . ,params)))))
       (let* ((ret-decl `(udecl (decl-spec-list . ,rst)
				(init-declr (ptr-declr (pointer) (ident "_")))))
	      ;;(decl-return (gen-decl-return ret-decl))
	      ;;(decl-params (gen-decl-params params))
	      (decl-return (gen-decl-return ret-decl))
	      (decl-params (gen-decl-params params))
	      )
	 (fhscm-def-function* typename decl-return decl-params))
       (values (cons typename wrapped) (cons typename defined)))

      ;; TODO: typedef void (foo_t)(int x)  [instead of *foo_t]
      ;; TODO: typedef void* (foo_t)(int x)

      ;; typedef foo_t bar_t
      ;; We retry with expansion of foo_t here.  Using fh-define-type-alias
      ;; was not working when we had "typedef struct foo foo_t;" But then
      ;; crashing on function types, so imported original type aliasing.
      ((udecl
	(decl-spec-list
	 (stor-spec (typedef))
	 (type-spec (typename ,name)))
	(init-declr (ident ,typename)))
       (cond
	((member name bs-defined)
	 (values wrapped defined))
	((member name defined)
	 (sfscm "(define-public ~A-desc ~A-desc)\n" typename name)
	 (sfscm "(define-fh-type-alias ~A ~A)\n" typename name)
	 (sfscm "(export ~A)\n" typename)
	 (sfscm "(define-public ~A? ~A?)\n" typename name)
	 (sfscm "(define-public make-~A make-~A)\n" typename name)
	 (when (member (w/* name) defined)
	   (sfscm "(define-public ~A*-desc ~A*-desc)\n" typename name)
	   (sfscm "(define-fh-type-alias ~A* ~A*)\n" typename name)
	   (sfscm "(export ~A*)\n" typename)
	   (sfscm "(define-public ~A*? ~A*?)\n" typename name)
	   (sfscm "(define-public make-~A* make-~A*)\n" typename name))
	 (values (cons typename wrapped) (cons typename defined)))
	(else
	 (let ((xdecl (expand-typerefs udecl (*udict*) defined)))
	   (cnvt-udecl xdecl udict wrapped defined)))))

      ;; === structs and unions ==========

      ;; struct foo { ... }.
      ((udecl
	(decl-spec-list
	 (type-spec (struct-def (@ . ,attr1) (ident ,struct-name) ,field-list))))
       (cond
	((back-ref-getall udecl) =>
	 (lambda (name-list)
	   (cnvt-struct-def attr1 #f struct-name field-list)
	   (for-each
	    (lambda (typename)
	      (sfscm "(set! ~A-desc struct-~A-desc)\n" typename struct-name)
	      (fhscm-def-compound typename)
	      (fhscm-def-pointer (sw/* typename))
	      (fhscm-ref-deref typename))
	    name-list)
	   (values (cons (w/struct struct-name) wrapped)
		   (cons (w/struct struct-name) defined))))
	((not (member (w/struct struct-name) defined))
	 (cnvt-struct-def attr1 #f struct-name field-list)
	 ;; Hoping don't need w/struct*
	 (values (cons (w/struct struct-name) wrapped)
		 (cons (w/struct struct-name) defined)))
	(else
	 (values wrapped defined))))

      ;; struct { ... } ...
      ((udecl
	(decl-spec-list
	 (type-spec (struct-def ,field-list))))
       (sferr "bug in munge? unnamed struct-def\n")
       (pperr udecl)
       (values wrapped defined))

      ;; union foo { ... }.
      ((udecl
	(decl-spec-list
	 (type-spec (union-def (@ . ,attr1) (ident ,union-name) ,field-list))))
       (cond
	((back-ref-getall udecl) =>
	 (lambda (name-list)
	   ;;(sferr "  back-ref\n")
	   (cnvt-union-def #f #f union-name field-list)
	   (for-each
	    (lambda (typename)
	      (sfscm "(set! ~A-desc union-~A-desc)\n" typename union-name)
	      (fhscm-def-compound typename)
	      (fhscm-def-pointer (sw/* typename))
	      (fhscm-ref-deref typename))
	    name-list)
	   (values (cons (w/union union-name) wrapped)
		   (cons (w/union union-name) defined))))
	((not (member (w/union union-name) defined))
	 (cnvt-union-def attr1 #f union-name field-list)
	 (values (cons (w/union union-name) wrapped)
		 (cons (w/union union-name) defined)))
	(else
	 (values wrapped defined))))

      ;; union { ... } ...
      ((udecl
	(decl-spec-list
	 (type-spec (union-def ,field-list))))
       (sferr "bug in munge? unnamed union-def\n")
       (pperr udecl)
       (values wrapped defined))

      ;; === enums =======================

      ;; enum foo { ... };
      ((udecl
	(decl-spec-list
	 (type-spec (enum-def (ident ,enum-name) ,enum-def-list . ,rest))))
       (cnvt-enum-def #f enum-name enum-def-list)
       ;; probably never use this as arg to function
       (values (cons (w/enum enum-name) wrapped) defined))
      
      ;; enum { ... };
      ((udecl
	(decl-spec-list
	 (type-spec (enum-def ,enum-def-list . ,rest))))
       ;; This is now filtered in the caller so the C-decl is not printed.
       (values wrapped defined))

      ;; === function declarations =======
      
      ;; function returning pointer value
      ((udecl ,specl
	      (init-declr
	       (ptr-declr
		(pointer . ,rest)
		(ftn-declr (ident ,name) (param-list . ,params)))))
       (cnvt-fctn name (ptr-decl specl) params)
       (values wrapped defined))

      ;; function returning non-pointer value
      ;; TODO: parse ident part and process separately
      ((udecl ,specl
	      (init-declr
	       (ftn-declr (ident ,name) (param-list . ,params))))
       (cnvt-fctn name (non-ptr-decl specl) params)
       (values wrapped defined))
      ((udecl ,specl
	      (init-declr
	       (ftn-declr (scope (ident ,name)) (param-list . ,params))))
       (cnvt-fctn name (non-ptr-decl specl) params)
       (values wrapped defined))
      ((udecl ,specl
	      (init-declr
	       (ftn-declr (scope (ptr-declr (pointer . ,rest)
					    (ident ,name)))
			  (param-list . ,params))))
       (cnvt-fctn name (ptr-decl specl) params)
       (values wrapped defined))

      ;; === external variables =========

      ;; pointer
      ((udecl (decl-spec-list (stor-spec (extern)) ,type-spec)
	      (init-declr (ptr-declr (pointer) (ident ,name))))
       ;; This needs to have a delay and handler
       (let* ((udecl (expand-typerefs udecl (*udict*) (*defined*)))
	      (udecl (udecl-rem-type-qual udecl))
	      (mdecl (udecl->mdecl udecl)))
	 (cnvt-extern (car mdecl) (cdr mdecl)))
       (values wrapped defined))

      ;; non-pointer
      ((udecl (decl-spec-list (stor-spec (extern)) ,type-spec)
	      ,init-declr . ,rest)
       (let* ((udecl (expand-typerefs udecl (*udict*) (*defined*)))
	      (udecl (udecl-rem-type-qual udecl))
	      (mdecl (udecl->mdecl udecl)))
	 (cnvt-extern (car mdecl) (cdr mdecl))
	 (values wrapped defined)))

      ;; === special cases I need to fix =

      ;; from glib-2.0/gio.h
      ((udecl
	(decl-spec-list (stor-spec (typedef)) (type-spec (typename ,name)))
	(init-declr
	 (ptr-declr (pointer (pointer))
		    (scope (ftn-declr (scope (ptr-declr) (ident ,typename))
				      ,param-list)))))
       (sfscm "(define-public ~A-desc (bs:pointer 'void))\n" typename)
       (fhscm-def-pointer typename)
       (values (cons typename wrapped) (cons typename defined)))
      ((udecl
	(decl-spec-list (stor-spec (typedef)) (type-spec (typename ,name)))
	(init-declr
	 (ptr-declr (pointer (pointer))
		    (ftn-declr (scope (ptr-declr (pointer) (ident ,typename)))
			       ,param-list))))
       (sfscm "(define-public ~A-desc (bs:pointer 'void))\n" typename)
       (fhscm-def-pointer typename)
       (values (cons typename wrapped) (cons typename defined)))

      ;; from zzip/zzip.h
      ((udecl
	(decl-spec-list
	 (stor-spec (typedef))
	 (type-spec (fixed-type ,typename))) ;; char
	(init-declr
	 (ptr-declr
	  (pointer (type-qual-list . ,rest))
	  (ident ,name))))
       (sfscm "(define-public ~A-desc (bs:pointer 'void))\n" typename)
       (fhscm-def-pointer typename)
       (values (cons typename wrapped) (cons typename defined)))

      ;; from hdf5.h
      ((udecl
	(decl-spec-list
	 (stor-spec (typedef))
	 (type-spec (fixed-type "unsigned char")))
	(init-declr
	 (array-of
	  (ident "hdset_reg_ref_t")
	  (add (sizeof-type
		(type-name
		 (decl-spec-list (type-spec (typename "haddr_t")))))
	       (p-expr (fixed "4"))))))
       (let* ((typename "haddr_t")
	      (size (+ (sizeof '*) 4))
	      )
	 (sfscm "(define-public ~A-desc (bs:vector ~A '*))\n" typename size)
	 ;;(sfscm "(define-fh-compound-type/p ~A ~A-desc)\n" typename typename)
	 (fhscm-def-compound typename)
	 (values (cons typename wrapped) (cons typename defined))))

      ;; from gtk+-3.0/gtk/gtk.h
      ((udecl (decl-spec-list
	       (stor-spec (typedef))
	       (type-spec (fixed-type "char")))
	      (init-declr
	       (ptr-declr (pointer) (ident "GtkStock"))))
       (sferr "missed gtk3 decl not expanded\n")
       (values wrapped defined))

      ;; from uuid.h
      ((udecl (decl-spec-list
	       (stor-spec (typedef))
	       (type-spec (fixed-type "unsigned char")))
	      (init-declr
	       (array-of (ident ,typename) (p-expr (fixed ,len)))))
       (sfscm "(define-public ~A-desc (bs:vector ~A uint8))\n" typename len)
       (fhscm-def-compound typename)
       (values (cons typename wrapped) (cons typename defined)))

      ;; === missed =====================

      (,otherwise
       (sferr "see below:\n")
       (pperr udecl)
       ;;(sferr "-\n")
       ;;(pperr `(udecl ,specl ,declr))
       (error "cnvt-udecl")
       (fherr "cnvt-udecl missed --^")
       (values wrapped defined)))))


;; === enums and #defined => lookup

;; given keeper-defs (k-defs) and cpp defs (c-defs) expand the keeper
;; replacemnts down to constants (strings, integers, etc)
(define (gen-lookup-proc keep-defs cpp-defs ext-mods)

  (define err-port (open-output-file "/dev/null"))
  
  (define* (try-parse-repl repl)
    (with-error-to-port err-port
      (lambda ()
	(catch 'c99-error
	  (lambda () (parse-c99x repl (*tdefs*) #:cpp-defs cpp-defs))
	  (lambda args #f)))))

  ;; @var{keep-defs} is list of CPP defs and enum key/val pairs. It is
  ;; possible for an enum symbol to be used as a macro function so we
  ;; need to first check for integer before trying expand-cpp-macro-ref.
  (sfscm "\n;; access to enum symbols and #define'd constants:\n")
  (let ((st-name (string->symbol (string-append (*prefix*) "-symbol-tab")))
	(sv-name (string->symbol (string-append (*prefix*) "-symbol-val")))
	(defs
	  (fold
	   (lambda (def seed)
	     (let* ((name (car def)) (val (cdr def))
		    (symb (string->symbol name))
		    (repl (cond
			   ((pair? val) #f)
			   ((string->number (cdr def)) (cdr def))
			   (else
			    ;; or maybe should export/use cpp-expand-text
			    (with-input-from-string ""
			      (lambda ()
				(expand-cpp-macro-ref name cpp-defs)))))))
	       ;; TODO: try to reduce all this to the parse-c99x one
	       (cond
		((not repl) seed)
		((not (string? repl)) (sferr "not string: ~S\n" repl))
		((zero? (string-length repl)) seed)
		;;
		((cintstr->num repl) => (lambda (val) (acons symb val seed)))
		((try-parse-repl repl)
		 => (lambda (val)
		      (let ((cv (eval-c99-cx val (*udict*) (*ddict*))))
			(unless cv
			  (sfscm ";; unable to generate constant for ~S\n" name))
			(if cv (acons symb cv seed) seed))))
		;;
		(else
		 ;;(sferr "gen-lookup-proc misssed ~A ~S\n" name repl)
		 seed))))
	   '()
	   keep-defs))
	(ext-ftns			; lookup in use-ffi-modules
	 (map
	  (lambda (mod)
	    (list (string->symbol
		   (string-append (path->name mod) "-symbol-val")) 'k))
	  ext-mods)))
    (ppscm `(define ,st-name '(,@defs)))
    (ppscm `(define ,sv-name (lambda (k) (or (assq-ref ,st-name k) ,@ext-ftns))))
    (sfscm "(export ~A)\n" sv-name)
    ;;
    (nlscm)
    (ppscm
     `(define (unwrap-enum obj)
	(cond
	 ((number? obj) obj)
	 ((symbol? obj) (,sv-name obj))
	 ((fh-object? obj) (struct-ref obj 0)) ;; ???
	 (else (error "type mismatch")))))
    
    (close err-port)))


;; === Parsing the C header(s)

;; @deffn parse-code code [attrs]
;; Parse @var{code}, a Scheme string, using cpp-defs and inc-dirs from
;; @var{attrs}.
;; This procedure is used by @code{parse-includes}.
;; @end deffn
(define* (parse-code code #:optional (attrs '()))
  (let* ((cpp-defs (resolve-attr-val (assq-ref attrs 'cpp-defs)))
	 (inc-dirs (resolve-attr-val (assq-ref attrs 'inc-dirs)))
	 (inc-help (resolve-attr-val (assq-ref attrs 'inc-help)))
	 ;;
	 (pkg-config (assq-ref attrs 'pkg-config))
	 (cpp-defs (append (pkg-config-defs pkg-config) cpp-defs))
	 (inc-dirs (append (pkg-config-incs pkg-config) inc-dirs))
	 ;;
	 (cpp-defs (append cpp-defs fh-cpp-defs))
	 (inc-dirs (append inc-dirs fh-inc-dirs))
	 (inc-help (append inc-help fh-inc-help)))
    (or (with-input-from-string code
	  (lambda ()
	    (parse-c99 #:cpp-defs cpp-defs
		       #:inc-dirs inc-dirs
		       #:inc-help inc-help
		       #:mode 'decl
		       #:show-incs #f
		       #:debug (*debug-parse*))))
	(fherr "parse failed"))))

;; @deffn parse-includes attrs
;; This routine generates a top-level source string-file with all the includes,
;; parses it, and then merges one level down of includes into the top level,
;; as if the bodies of the incudes had been combined into one file.
;; @end deffn
(define parse-includes
  (let* ((p (node-join
	     (select-kids (node-typeof? 'cpp-stmt))
	     (select-kids (node-typeof? 'include))
	     (select-kids (node-typeof? 'trans-unit))))
	 (merge-inc-bodies
	  (lambda (t) (cons 'trans-unit (apply append (map cdr (p t)))))))
    (lambda (attrs)
      (let* ((inc-files (resolve-attr-val (assq-ref attrs 'include)))
	     (prog (string-join
		    (map
		     (lambda (inc-file)
		       (string-append "#include \"" inc-file "\"\n"))
		     inc-files) "")))
	(and=> (parse-code prog attrs) merge-inc-bodies)))))

;; === main converter ==================

(define (derive-dirpath sfile mbase)
  (if (not sfile) "./"
      (let* ((sbase (string-drop-right sfile 4))
	     (sfxln (string-suffix-length sbase mbase))
	     (sblen (string-length sbase)))
	(if (not (= sfxln (string-length mbase))) ; need more robust
	    (error "filename-path inconsistent"))
	(substring sbase 0 (- sblen sfxln)))))

;; Return #t when ffi-file has an mtime greater than that of scm-file
(define (more-recent? ffi-file scm-file)
  ;; copied from ice-9/boot-9.scm
  (let ((stat1 (stat ffi-file)) (stat2 (stat scm-file)))
    (or (> (stat:mtime stat1) (stat:mtime stat2))
	(and (= (stat:mtime stat1) (stat:mtime stat2))
	     (>= (stat:mtimensec stat1)
		 (stat:mtimensec stat2))))))

;; given modules spec, determine if any ffi-module dependencies are
;; outdated
(define (check-deps module-options)
  (let ((ext-modz ;; use filter?
	 (fold-right
	  (lambda (opt seed)
	    (if (eq? (car opt) 'use-ffi-module) (cons (cdr opt) seed) seed))
	  '() module-options))
	(ext-mods (map cdr (filter
			    (lambda (opt) (eq? (car opt) 'use-ffi-module))
			    module-options))))
    (for-each
     (lambda (fmod)
       (let* ((base (string-join (map symbol->string fmod) "/"))
	      (xffi (string-append base ".ffi"))
	      (xscm (string-append base ".scm")))
	 (when (not (access? xscm R_OK))
	   (fherr "compiled dependent ~S not found" fmod))
	 (when (more-recent? xffi xscm)
	   (fherr "dependent ~S needs recompile" xffi)
	   (sleep 2))))
     ext-mods)))

;; => (values wrapped defined)
(define* (process-decls decls udict
			#:optional (wrapped '()) (defined '())
			#:key (declf (lambda (k) #t))
			)
  (let* () ;;(declf (if declf declf (lambda (key) #t))))
    (fold-values			  ; from (sxml fold)
     (lambda (name wrapped defined) ; name: "foo_t" or (enum . "foo")
       (catch 'ffi-help-error
	 (lambda ()
	   (cond
	    ((and ;; Process the declaration if all conditions met:
	      (declf name)		  ; 1) user wants it
	      (not (member name defined)) ; 2) not already defined
	      (not (and (pair? name)	  ; 3) not anonymous
			(string=? "*anon*" (cdr name)))))
	     (let ((udecl (udict-ref udict name)))
	       (nlscm) (c99scm udecl)
	       (if (*echo-decls*)
		   (sfscm "(if echo-decls (display \"~A\\n\"))\n" name))
	       (cnvt-udecl udecl udict wrapped defined)))
	    (else (values wrapped defined))))
	 ;; exception handler:
	 (lambda (key fmt . args)
	   (if fmt (apply simple-format (current-error-port)
			  (string-append "ffi-help: " fmt "\n") args))
	   (sfscm ";; ... failed.\n")
	   (values wrapped defined))))
     decls wrapped defined)))

;; process define-ffi-module expression
;; was intro-ffi
(define (expand-ffi-module-spec path module-options)
  (check-deps module-options)
  (let* ((script-options (*options*))
	 (dbugl (or (and=> (assq-ref script-options 'debug)
			   (lambda (v) (map string->symbol
					    (string-split v #\,))))
		    '()))
	 (mbase (path->path path))
	 (dirpath (derive-dirpath (assq-ref script-options 'file) mbase))
	 (mfile (string-append dirpath mbase ".scm"))
	 (mport (open-output-file mfile))
	 ;;
	 (attrs (opts->attrs module-options script-options))
	 (incf (or (assq-ref attrs 'inc-filter) #f))
	 (declf (or (assq-ref attrs 'decl-filter) identity))
	 (renamer (or (assq-ref attrs 'renamer) identity))
	 ;;
	 (tree (begin
		 (if (memq 'parse dbugl) (*debug-parse* #t))
		 (cond
		  ((assq-ref attrs 'include) (parse-includes attrs))
		  ((assq-ref attrs 'api-code) =>
		   (lambda (code) (parse-code code attrs)))
		  (else (fherr "expecing #:include or #:api-code")))))
	 (udecls (c99-trans-unit->udict tree #:inc-filter incf))
	 (udict (c99-trans-unit->udict/deep tree))
	 (ffi-decls (map car udecls))	; just the names, get decls from udict

	 ;; OK, I think this is fixed now.  Was ...
	 ;; 1. If udict, then exported symbols looks good, but ref's don't work
	 ;; 2. If udecls, refs work but bloated symval struct.
	 ;; The conflict is in
	 ;; const-expr->number VS call to gen-lookup-proc 1st arg ffi-defs
	 (ffi-enu-defs (udict-enums->ddict udecls))
	 (ffi-defs (c99-trans-unit->ddict tree ffi-enu-defs #:inc-filter incf))
	 (cpp-defs (c99-trans-unit->ddict tree #:inc-filter #t))
	 (all-enu-defs (udict-enums->ddict udict))
	 (all-defs (c99-trans-unit->ddict
		    tree all-enu-defs #:inc-filter #t #:skip-fdefs #t))
	 (ddict all-defs)
	 ;; the list of typedefs we will generate (later):
	 (ffimod-defined #f)
	 ;; ext modules [from #:use-modules (ffi cairo)]
	 (ext-mods
	  (fold-right
	   (lambda (opt seed)
	     (if (eq? (car opt) 'use-ffi-module) (cons (cdr opt) seed) seed))
	   '() module-options))
	 ;; list of exernal defined
	 (ext-defd			
	  (fold
	   (lambda (upath seed)
	     (unless (resolve-module upath)
	       (error "module not defined:" upath))
	     (let* ((modul (resolve-module upath #:ensure #f))
		    (pname (path->name upath))
		    (vname (string->symbol (string-append pname "-types")))
		    (var (module-ref modul vname)))
	       (append var seed)))
	   '() ext-mods))
	 )
    ;; set globals
    (*prefix* (path->name path))
    (*udict* udict)
    (*mport* mport)
    (*ddict* ddict)
    (*renamer* renamer)
    (*tdefs* (udict->typenames udict))
    (if (memq 'echo-decls dbugl) (*echo-decls* #t))

    ;; file and module header
    (ffimod-header path module-options)

    ;; Convert and output foreign declarations.
    (call-with-values
	(lambda ()
	  ;; We need to have externs in wrapped because function param
	  ;; type have wrapped types preserved (e.g., enums).
	  ;; swap of udecls with udict failed on glib g???
	  (process-decls ffi-decls udecls ;; udict <= swap failed 01 Dec 2018
			 ;; wrapped and defined:
			 ext-defd (append bs-defined ext-defd)
			 ;; declaration filter
			 #:declf declf))
      (lambda (wrapped defined)
	;; Set ffimod-defined for including, but removed built-in types.
	(let* ((bity (car bs-defined))	; first built-in type
	       (defd (let loop ((res '()) (defs defined))
		       (if (eq? (car defs) bity) res
			   (loop (cons (car defs) res) (cdr defs))))))
	  (set! ffimod-defined defd))))
    
    ;; output global constants (from enum and #define)
    (gen-lookup-proc ffi-defs cpp-defs ext-mods)

    ;; output list of defined types
    (sfscm "\n(define ~A-types\n  '" (path->name path))
    (ugly-print ffimod-defined mport #:per-line-prefix "   " #:trim-ends #t)
    (sfscm ")\n(export ~A-types)\n" (path->name path))

    ;; Return the output port so the compiler can output remaining code.
    mport))


;; === test compiler ================

;; @deffn {Procedure} C-fun-decl->scm code
;; Generate a symbolic expression that evals to a Guile procedure.
;; @example
;; (define fmod-exp (C-fun-decl->proc "double dmod(double, double);"))
;; (define fmod (eval fmod-exp (current-module)))
;; (fmod 2.3 0.5)
;; @end example
;; @end deffn
(define (C-fun-decl->scm code)
  (let ((tree (with-input-from-string code parse-c99)))
    (if tree
	(let* ((udict (unitize-decl (sx-ref tree 1)))
	       (name (caar udict)) (udecl (cdar udict))
	       (gen1 (fh-cnvt-udecl udecl '()))
	       (gen2 (with-input-from-string gen1 read))
	       (gen3 (caddr gen2)))
	  gen3))))

(define* (fh-cnvt-udecl udecl udict #:key (prefix "fh"))
  (parameterize ((*options* '()) (*wrapped* '()) (*defined* '())
		 (*renamer* identity) (*errmsgs* '()) (*prefix* prefix)
		 (*mport* (open-output-string)) (*udict* udict))
    (cnvt-udecl udecl udict '() '())
    (let ((res (get-output-string (*mport*))))
      (close (*mport*))
      res)))

;; convert string-body of Scheme code to a Scheme expression
;; @example
;; (fh-scm-str->scm-exp "(define a 1)") => '(begin (define a 1))
;; @end example
(define (fh-scm-str->scm-exp str)
  (call-with-input-string str
    (lambda (iport)
      (cons 'begin
	    (let loop ((exp (read iport)))
	      (if (eof-object? exp) '()
		  (cons exp (loop (read iport)))))))))

;; Convert declaration with @var{name} in string-body of C @var{code}
;; to string-body of Scheme code.
;; @example
;; (fh-cnvt-cdecl "sqrt" "double sqrt(double x);") =>
;;   "(define ~sqrt ...)\n (define (sqrt x) ...)"
;; @end example
(define* (fh-cnvt-cdecl->str name code #:key (prefix "fh"))
  (let* ((tree (with-input-from-string code parse-c99))
	 (udict (c99-trans-unit->udict tree))
	 (udecl (assoc-ref udict name)))
    (fh-cnvt-udecl udecl udict)))

;; like above but then convert to Scheme expression
(define* (fh-cnvt-cdecl name code #:key (prefix "fh"))
  (and=> (fh-cnvt-cdecl->str name code #:prefix prefix) fh-scm-str->scm-exp))
			     
;; === repl compiler ================

;; @deffn {Procedure} load-include-file filename [pkg-config]
;; This is the functionality that Ludo was asking for: to be at guile
;; prompt and be able to issue
;; @example
;; (use-modules (nyacc lang c99 ffi-help))
;; (load-include-file "cairo.h" #:pkg-config "cairo")
;; @end example
;; @end deffn
;; + Right now the only way would be to generate a file and eval it, because
;;   our code generates strings and not lists.
;; + and=> with-output-to-string  eval
;; + first need to cut up intro-ffi

;; options:
;;   api-code cpp-defs decl-filter
;;   inc-dirs inc-filter inc-help include
;;   library pkg-config renamer
(define* (load-include-file filename
			    #:key pkg-config)
  (parameterize ((*options* '()) (*wrapped* '()) (*defined* '())
		 (*renamer* identity) (*errmsgs* '())
		 (*prefix* "") (*mport* #t) (*udict* '()))
    (let* ((attrs (acons 'include (list filename) '()))
	   (attrs (if pkg-config (acons 'pkg-config pkg-config attrs) attrs))
	   (tree (parse-includes attrs))
	   (udict (c99-trans-unit->udict/deep tree))
	   (udecls (c99-trans-unit->udict tree))
	   (decls (map car udecls))
	   (scmport (mkstemp! (string-copy ",_FH_XXXXXX")))
	   ;;(scmport (tmpfile)) ;; does not work ?
	   (scmfile (port-filename scmport))
	   (compile-file (@@ (system base compile) compile-file))
	   )
      (*prefix* (symbol->string (gensym "fh-")))
      (*mport* scmport)
      (*udict* udict)
      (sfscm "(use-modules (system ffi-help-rt))\n")
      (sfscm "(use-modules ((system foreign) #:prefix ffi:))\n")
      (sfscm "(use-modules (bytestructures guile))\n")
      (ppscm `(define ,(link-libs)
		(list ,@(map
			 (lambda (l) `(dynamic-link ,l))
			 (pkg-config-libs pkg-config)))))
      (process-decls decls udict '() bs-defined)
      (close (*mport*))
      (simple-format #t "wrote ~S; compile and load: ...\n" scmfile)
      (load-compiled (compile-file scmfile #:opts '()))
      (if #f #f))))


;; === file compiler ================

(use-modules (system base language))
(use-modules (ice-9 pretty-print))

;; This macro converts #:key val to '(key val) for ffi-help options
;; and preserves other #:key-val pairs for passthrough to the module
;; Note that keywords are converted to symbols before they get here
;; NOT USED.
(define-syntax parse-ffimod-option
  (lambda (x)
    (define (sym->key stx)
      (datum->syntax stx (symbol->keyword (syntax->datum stx))))
    (syntax-case x (api-code
		    cpp-defs decl-filter inc-dirs inc-filter inc-help include
		    library pkg-config renamer)
      ((_ api-code code) #'(cons 'api-code code))
      ((_ cpp-defs proc) #'(cons 'cpp-defs proc))
      ((_ decl-filter proc) #'(cons 'decl-filter proc))
      ((_ inc-dirs proc) #'(cons 'inc-dirs proc))
      ((_ inc-filter proc) #'(cons 'inc-filter proc))
      ((_ inc-help expr) #'(cons 'inc-help expr))
      ((_ include expr) #'(cons 'include expr))
      ((_ library expr) #'(cons 'library expr)) ;; eval to list of libs
      ((_ pkg-config string) #'(cons 'pkg-config string))
      ((_ renamer proc) #'(cons'renamer (quote proc)))
      ;;((_ use-ffi-module path) #'(cons 'use-ffi-module (quote path)))
      ;; remaining options get passed to the module decl as-is:
      ;;((_ key val) #`(cons #,(sym->key #'key) (quote val)))
      ;;((_ key val) #`(cons #,(symbol->keyword #'key) (quote val)))
      )))

(define-syntax parse-module-options
  (lambda (x)
    (define (key->sym stx)
      (datum->syntax stx (keyword->symbol (syntax->datum stx))))
    (define (ffimod-option? key)
      (and (keyword? key)
	   (member key '(#:api-code
			 #:cpp-defs #:decl-filter #:inc-dirs #:inc-filter
			 #:inc-help #:include #:library #:pkg-config #:renamer
			 #:use-ffi-module))))
    (define (module-option? key) (keyword? key))

    (syntax-case x ()
      ((_ key val option ...)
       (eq? (syntax->datum #'key) #:use-ffi-module)
       #`(cons
	  (cons (quote #,(key->sym #'key)) (quote val))
	  (parse-module-options option ...)))

      ((_ key val option ...)
       (ffimod-option? (syntax->datum #'key))
       #`(cons
	  (cons (quote #,(key->sym #'key)) val)
	  (parse-module-options option ...)))

      ((_ key val option ...)
       (module-option? (syntax->datum #'key))
       #`(cons
	  (cons key (quote val))
	  (parse-module-options option ...)))
      
      ((_ key val option ...)
       #'(syntax-error "compile-ffi: expecting keyword"))
      
      ((_) #''()))))

(define-syntax-rule (define-ffi-module path-list attr ...)
  (expand-ffi-module-spec (quote path-list) (parse-module-options attr ...)))

(define (string-member-proc . args)
  (lambda (s) (member s args)))

;; to convert symbol-based #:renamer to string-based
(define (string-renamer proc)
  (lambda (s) (string->symbol (proc (symbol->string s)))))

(define scm-reader (language-reader (lookup-language 'scheme)))

;; @deffn {Procedure} compile-ffi-file file [options]
;; This procedure will 
;; @end deffn
(define* (compile-ffi-file file #:optional (options '()))
  (parameterize ((*options* options) (*wrapped* '()) (*defined* '())
		 (*renamer* identity) (*errmsgs* '()) (*prefix* "")
		 (*mport* #t) (*udict* '()) (*ddict* '()))
    ;; if not interactive ...
    (debug-disable 'backtrace)
    (if (not (access? file R_OK))
	(throw 'ffi-help-error "ERROR: not found: ~S" file))
    (call-with-input-file file
      (lambda (iport)
	(let ((env (make-fresh-user-module)))
	  (eval '(use-modules (nyacc lang c99 ffi-help)) env)
	  (let loop ((oport #f) (exp (read iport)))
	    (cond
	     ((eof-object? exp)
	      (when oport
		(display "\n;; --- last line ---\n" oport)
		(close-port oport)))
	     ((and (pair? exp) (eqv? 'define-ffi-module (car exp)))
	      (loop (eval exp env) (read iport)))
	     (else
	      (when oport
		(newline oport)
		(pretty-print exp oport))
	      (loop oport (read iport))))))))))

;; --- last line ---
