(use-modules (system foreign)
             (rnrs bytevectors))

;; 调用 libc 的 abs 函数
(define lib (dynamic-link))  ; 默认链接 libc

(define c-abs
  (pointer->procedure int
                      (dynamic-func "abs" lib)
                      (list int)))

(c-abs -42)  ; => 42

;; 调用 strlen
(define c-strlen
  (pointer->procedure size_t
                      (dynamic-func "strlen" lib)
                      (list '*)))

(c-strlen (string->pointer "Hello"))  ; => 5

;; 调用 puts
(define c-puts
  (pointer->procedure int
                      (dynamic-func "puts" lib)
                      (list '*)))

(c-puts (string->pointer "Hello from C!"))
;; 输出: Hello from C!

;; 类型使用示例
(define libm (dynamic-link "libm"))

;; double pow(double, double)
(define c-pow
  (pointer->procedure double
                      (dynamic-func "pow" libm)
                      (list double double)))

(c-pow 2.0 10.0)  ; => 1024.0

;; double sqrt(double)
(define c-sqrt
  (pointer->procedure double
                      (dynamic-func "sqrt" libm)
                      (list double)))

(c-sqrt 2.0)  ; => 1.4142135623730951

;; void qsort(void*, size_t, size_t, int(*)(const void*, const void*))
;; 回调函数稍后讨论

;; C 字符串 → Guile 字符串
(define c-str (string->pointer "Hello"))
(pointer->string c-str)  ; => "Hello"

;; 带长度的转换
(pointer->string c-str 3)  ; => "Hel"

;; 动态分配的字符串
(define buf (make-pointer (malloc 256)))
(string->pointer "Hello" buf)  ; 复制到 buf
(pointer->string buf)  ; => "Hello"
(free buf)

;; 结构体中的字符串
(use-modules (system foreign))

(define (read-c-string pointer offset)
  "从指针偏移处读取 C 字符串"
  (let* ((ptr (make-pointer (+ (pointer-address pointer) offset)))
         (str (pointer->string ptr -1 "UTF-8")))
    str))

;; 使用 sizeof 和 pointer-ref 操作结构体

;; C 结构体示例:
;; struct point { int x; int y; };

(define sizeof-point (* 2 (sizeof int)))

(define (make-c-point x y)
  "创建 C 结构体 point"
  (let ((bv (make-bytevector sizeof-point 0)))
    (bytevector-s32-native-set! bv 0 x)
    (bytevector-s32-native-set! bv 4 y)
    (bytevector->pointer bv)))

(define (c-point-x pointer)
  "读取 point.x"
  (bytevector-s32-native-ref
    (pointer->bytevector pointer sizeof-point)
    0))

(define (c-point-y pointer)
  "读取 point.y"
  (bytevector-s32-native-ref
    (pointer->bytevector pointer sizeof-point)
    4))

(define p (make-c-point 10 20))
(c-point-x p)  ; => 10
(c-point-y p)  ; => 20

;; 更高级的结构体定义
(use-modules (system foreign))

(define-syntax define-c-struct
  (syntax-rules ()
    ((_ name (field type offset) ...)
     (begin
       (define (make-name field ...)
         (let ((bv (make-bytevector (max (+ offset (sizeof type)) ...) 0)))
           (bytevector-s32-native-set! bv offset field) ...
           (bytevector->pointer bv)))
       (define (name-field pointer)
         (bytevector-s32-native-ref
           (pointer->bytevector pointer (max (+ offset (sizeof type)) ...))
           offset))
       ...))))

;; 定义回调函数类型
;; typedef int (*comparator)(const void*, const void*);

(define (make-c-comparator scheme-compare)
  "将 Scheme 比较函数转换为 C 回调"
  (pointer->procedure int
    (dynamic-func "qsort_callback" (dynamic-link))
    (list '* '*)))

;; 使用 procedure->pointer 创建回调
(use-modules (system foreign))

(define (int-compare a b)
  (let ((va (pointer-ref-c-signed-int a 0))
        (vb (pointer-ref-c-signed-int b 0)))
    (cond ((< va vb) -1)
          ((= va vb) 0)
          (else 1))))

;; 将 Scheme 函数转为 C 函数指针
(define callback-ptr
  (procedure->pointer int int-compare (list '* '*)))

;; 注：完整的 qsort 调用需要更复杂的指针操作

;; 加载系统库
(define libc (dynamic-link))           ; 默认 libc
(define libm (dynamic-link "libm"))    ; 数学库
(define libz (dynamic-link "libz"))    ; zlib

;; 加载自定义库
(define mylib (dynamic-link "./libmylib.so"))

;; 错误处理
(catch 'misc-error
  (lambda ()
    (dynamic-link "libnonexistent.so"))
  (lambda (key . args)
    (display "库加载失败\n")))

;; 获取函数指针
(define func-ptr (dynamic-func "my_function" mylib))

;; 链接计数管理
(dynamic-unlink libm)  ; 卸载库（谨慎使用）

;; 封装 zlib 压缩库
(use-modules (system foreign)
             (rnrs bytevectors))

(define libz (dynamic-link "libz"))

;; unsigned long compressBound(unsigned long sourceLen)
(define compress-bound
  (pointer->procedure unsigned-long
                      (dynamic-func "compressBound" libz)
                      (list unsigned-long)))

;; int compress(Bytef *dest, uLongf *destLen,
;;              const Bytef *source, uLong sourceLen)
(define c-compress
  (pointer->procedure int
                      (dynamic-func "compress" libz)
                      (list '* '* '* unsigned-long)))

(define (compress-data data)
  "压缩字节向量"
  (let* ((src-len (bytevector-length data))
         (dst-len (compress-bound src-len))
         (src-ptr (bytevector->pointer data))
         (dst-bv (make-bytevector dst-len 0))
         (dst-ptr (bytevector->pointer dst-bv))
         (len-bv (make-bytevector (sizeof unsigned-long) 0)))
    ;; 设置目标长度
    (bytevector-uint-set! len-bv 0 dst-len
                          (native-endianness)
                          (sizeof unsigned-long))
    (let ((result (c-compress dst-ptr
                              (bytevector->pointer len-bv)
                              src-ptr
                              src-len)))
      (if (= result 0)
          (let ((out-len (bytevector-uint-ref len-bv 0
                                              (native-endianness)
                                              (sizeof unsigned-long))))
            (bytevector-copy dst-bv 0 out-len))
          (error "压缩失败" result)))))

;; 测试
(define test-data (string->utf8 "Hello World! " ))
(define compressed (compress-data test-data))
(format #t "原始: ~a 字节, 压缩: ~a 字节~%"
        (bytevector-length test-data)
        (bytevector-length compressed))

/* embed-guile.c — 在 C 程序中嵌入 Guile 解释器 */
#include <libguile.h>

/* 将 C 函数暴露给 Guile */
static SCM my_add(SCM a, SCM b) {
    return scm_sum(a, b);
}

/* 定义 Guile 可调用的模块 */
static void inner_main(void *data, int argc, char **argv) {
    /* 注册 C 函数到 Guile */
    scm_c_define_gsubr("c-add", 2, 0, 0, my_add);

    /* 执行 Guile 代码 */
    scm_c_eval_string("(display (c-add 3 4))");
    scm_c_eval_string("(newline)");

    /* 或加载文件 */
    scm_c_primitive_load("script.scm");
}

int main(int argc, char **argv) {
    scm_boot_guile(argc, argv, inner_main, NULL);
    return 0;
}

# Makefile
CC = gcc
CFLAGS = `pkg-config --cflags guile-3.0`
LDFLAGS = `pkg-config --libs guile-3.0`

embed-guile: embed-guile.c
	$(CC) $(CFLAGS) -o $@ $< $(LDFLAGS)

/* 交换数据类型 */
#include <libguile.h>

/* 字符串 */
SCM str = scm_from_utf8_string("Hello");
char *c_str = scm_to_utf8_string(str);

/* 数字 */
SCM num = scm_from_int(42);
int c_num = scm_to_int(num);

/* 列表 */
SCM list = scm_list_3(scm_from_int(1),
                       scm_from_int(2),
                       scm_from_int(3));

/* 调用 Guile 函数 */
SCM func = scm_variable_ref(
    scm_c_lookup("map"));
SCM result = scm_call_2(func,
    scm_c_eval_string("(lambda (x) (* x x))"),
    list);

;; 使用 Guile 的扩展机制加载 C 代码
(define-module (my-extension)
  #:use-module (system foreign)
  #:export (fast-multiply))

;; 方式一：使用 FFI 直接调用
(define lib (dynamic-link "./libmyextension.so"))

(define c-fast-multiply
  (pointer->procedure '*  ; 返回 Scheme 值
                      (dynamic-func "scm_fast_multiply" lib)
                      (list '* '*)))

(define (fast-multiply a b)
  (c-fast-multiply (scm->pointer a) (scm->pointer b)))

;; 纯 Guile 实现
(define (guile-dot-product v1 v2)
  (let loop ((i 0) (acc 0.0))
    (if (= i (f64vector-length v1))
        acc
        (loop (+ i 1)
              (+ acc (* (f64vector-ref v1 i)
                        (f64vector-ref v2 i)))))))

;; 使用 C 扩展的版本（假设已有 C 实现）
;; (define c-dot-product
;;   (pointer->procedure double
;;                       (dynamic-func "dot_product" lib)
;;                       (list '* '* size_t)))

;; Guile 3.0 的 JIT 编译器可以显著提升纯 Scheme 代码性能
;; 对于大多数场景，建议先用纯 Guile 实现，再按需优化

;; Guile 3.0 的 JIT 编译器会自动优化热点代码
;; 无需手动配置，但可以查看 JIT 状态

;; 在启动时启用 JIT 调试
;; $ GUILE_JIT_LOG=1 guile script.scm

;; 编译模块以获得更好性能
;; (use-modules (system base compile))
;; (compile-file "my-module.scm" #:to 'value)

;; 封装 HTTP 请求（简化示例）
(use-modules (system foreign))

(define libcurl (dynamic-link "libcurl"))

(define curl-easy-init
  (pointer->procedure '*
                      (dynamic-func "curl_easy_init" libcurl)
                      '()))

(define curl-easy-cleanup
  (pointer->procedure void
                      (dynamic-func "curl_easy_cleanup" libcurl)
                      (list '*)))

(define curl-easy-setopt
  (pointer->procedure int
                      (dynamic-func "curl_easy_setopt" libcurl)
                      (list '* int '*)))

(define curl-easy-perform
  (pointer->procedure int
                      (dynamic-func "curl_easy_perform" libcurl)
                      (list '*)))

(define (http-get url)
  "简单的 HTTP GET 请求"
  (let ((curl (curl-easy-init)))
    (when (null-pointer? curl)
      (error "无法初始化 curl"))
    (curl-easy-setopt curl 10002 (string->pointer url))  ; CURLOPT_URL
    (let ((result (curl-easy-perform curl)))
      (curl-easy-cleanup curl)
      (if (= result 0)
          "请求成功"
          (error "请求失败" result)))))

;; 调用 POSIX 系统调用
(use-modules (system foreign))

(define libc (dynamic-link))

;; pid_t getpid(void)
(define getpid
  (pointer->procedure int
                      (dynamic-func "getpid" libc)
                      '()))

;; int mkdir(const char*, mode_t)
(define c-mkdir
  (pointer->procedure int
                      (dynamic-func "mkdir" libc)
                      (list '* unsigned-int)))

;; 使用示例
(format #t "当前进程 PID: ~a~%" (getpid))

(c-mkdir (string->pointer "/tmp/test-dir") #o755)