(module c-struct
 (define-c-struct)
 (import scheme chicken foreign)

(define-syntax define-c-struct
  (syntax-rules ()
    ((define-c-struct name type members ...)
     (gen-c-struct (name type) () members ...))))

(define-syntax gen-c-struct
  (syntax-rules (struct)
    ((_ hdr (lst ...))
     (gen-c-stubs hdr lst ...))
    ((_ hdr (lst ...) (name type) rest ...)
     (gen-c-struct hdr (lst ... name type) rest ...))
    ((_ hdr lst arg rest ...)
     (syntax-error "invalid c-struct member definition" arg))))

(define-syntax gen-c-stubs
  (er-macro-transformer
    (lambda (e r c)
      ;e (gen-c-stubs (struct-name struct-type) member-name member-type ...))
      (let* ((struct (cadr e))
             (struct-name (car struct))
             (struct-type (cadr struct)))
        (or (symbol? struct-name) (syntax-error "c-struct name expect symbol" struct-name))
        (or (string? struct-type) (syntax-error "c-struct type expect string" struct-type))
        (define (struct-type? type)
          (and (list? type) (eq? (car type) 'struct)))
        (define (gen-member-name name suffix)
          (string->symbol (sprintf "~A-~A~A" struct-name name suffix)))
        ; ffi cannot pass struct by value to make workaround
        (define (gen-type type)
          (if (struct-type? type) `(c-pointer ,type) type))
        (define (gen-value-ref name type)
          `(foreign-lambda* ,(gen-type type) ((scheme-pointer ptr))
             ,(if (struct-type? type)
                (sprintf "C_return( &((~A *)ptr) -> ~A);" struct-type name)
                (sprintf "C_return(  ((~A *)ptr) -> ~A);" struct-type name))))
        (define (gen-value-set! name type)
          `(foreign-lambda* void ((scheme-pointer ptr) (,(gen-type type) value))
             ,(if (struct-type? type)
                (sprintf " ((~A *)ptr) -> ~A = *value;" struct-type name)
                (sprintf " ((~A *)ptr) -> ~A =  value;" struct-type name))))
        (define (gen-member-init name)
          `(if ,name (,(gen-member-name name "-set!") cstruct ,name)))
        (define (gen-struct-init names)
          (flatten (list (string->symbol (sprintf "make-~A" struct-name)) '#!key names)))
        (define (gen-constructor names)
          `(define ,(gen-struct-init names)
             (let ((data (make-blob (foreign-value ,(sprintf "sizeof(~A)" struct-type) int))))
               (let ((cstruct (##sys#make-structure ',struct-name data)))
                 ,(cons 'begin (map gen-member-init names))
                 cstruct))))
        (define (gen-constructor-unsafe)
          ; unsafe constructor, make copy of structure from c-pointer
          `(define (,(string->symbol (sprintf "make-~A&" struct-name)) ptr)
             (let ((data (make-blob (foreign-value ,(sprintf "sizeof(~A)" struct-type) int))))
               (let ((cstruct (##sys#make-structure ',struct-name data)))
                 ((foreign-lambda* void ((scheme-pointer dst) (c-pointer src))
                    ,(sprintf "*(~A *)dst = *(~A *)src;" struct-type struct-type)) cstruct ptr)
                 cstruct))))
        ; direct access to struct blob
        (define (gen-struct-pointer)
          `(define (,(string->symbol (sprintf "~A&" struct-name)) c)
             (##sys#check-structure c ',struct-name)
             (##sys#slot c 1)))
        (let loop ((acc '())
                   (names '())
                   (lst (cddr e)))
          (if (eq? '() lst)
            `(begin ,(gen-constructor names)
                    ,(gen-constructor-unsafe)
                    ,(gen-struct-pointer)
                   ,(cons 'begin acc))
            (let ((name (car lst))
                  (type (cadr lst)))
              (or (symbol? name) (syntax-error "c-struct member name expect symbol" name))
              (loop (append
                      (list
                      `(define (,(gen-member-name name "-ref") c)
                         (##sys#check-structure c ',struct-name)
                         (,(gen-value-ref name type) (##sys#slot c 1)))
                      `(define (,(gen-member-name name "-set!") c value)
                         (##sys#check-structure c ',struct-name)
                         (,(gen-value-set! name type) (##sys#slot c 1) value)))
                      acc)
                    (cons name names)
                    (cddr lst)))))))))
)