最近想用 Common Lisp 做桌面端原生应用程序开发，不过发现目前比较新且成熟的原生 GUI 框架如 Qt6 、 GTK4 等 CL 上还没有相应的绑定，其他 GUI 库都不再维护或者停留在旧版本的 GUI 框架 。
Qt 是 C++ 写的，不好自己做 CFFI 绑定，现成的库 CommonQt 用的是比较老的 Qt4，EQL5 只有 ECL 能用，因此就放弃使用 Qt 了。
而 GTK 在 CL 上虽然有手工用 CFFI 编写的 cl-cffi-gtk ， 但 GTK 从 GTK3 开始提供了 GObject Introspection （以下简称 GIR）可以快速为一个语言创建基于 GLib 的库的绑定，我认为完全可以像 Python 的 PyGObject 那样，牺牲一点运行效率（需要运行时通过 GIR 动态获取 FFI 函数），但可以很方便地创建并且维护基于 GLib 的框架语言绑定，比如 GTK 、 GStreamer 等 ，毕竟这些框架大部分性能敏感的代码是藏在底层的，应用层基本只需要进行调用封装好的 API ，处理信号事件等，Python 的性能都可以胜任的 。
因此我基于 cl-gobject-introspection 开发了 gir-wrapper 用于为 GIR 创建 Lisp 风格的 API，可以像调用 Lisp 原生函数那样调用 GIR 的函数，并且创建了 GTK 的最新版本 GTK4 的 CL 绑定。下面是我用不到 100 行 CL 代码用 GTK4 创建的简单 REPL 作为示例：
(defpackage adw.example
(:use #:cl #:gtk4)
(:export #:main))
(in-package #:adw.example)
(defun main-window (app)
(let ((expression nil))
(let ((window (adw:make-application-window :app app)))
(widget-add-css-class window "devel")
(widget-set-size-request window 400 600)
(let ((box (make-box :orientation +orientation-vertical+
:spacing 0)))
(setf (adw:window-content window) box)
(let ((header-bar (adw:make-header-bar)))
(setf (adw:header-bar-title-widget header-bar)
(adw:make-window-title :title (lisp-implementation-type)
:subtitle (lisp-implementation-version)))
(box-append box header-bar))
(let ((carousel (adw:make-carousel)))
(setf (widget-hexpand-p carousel) t
(widget-vexpand-p carousel) t
(adw:carousel-interactive-p carousel) t)
(let ((page (adw:make-status-page)))
(setf (widget-hexpand-p page) t
(widget-vexpand-p page) t
(adw:status-page-icon-name page) "utilities-terminal-symbolic"
(adw:status-page-title page) "Simple Lisp REPL"
(adw:status-page-description page) " ")
(flet ((eval-expression (widget)
(declare (ignore widget))
(when expression
(setf (adw:status-page-description page)
(princ-to-string
(handler-case (eval expression)
(error (err) err)))))))
(let ((box (make-box :orientation +orientation-vertical+
:spacing 0)))
(let ((group (adw:make-preferences-group)))
(setf (widget-margin-all group) 10)
(let ((row (adw:make-action-row)))
(setf (adw:preferences-row-title row) (format nil "~A>" (or (car (package-nicknames *package*))
(package-name *package*))))
(let ((entry (make-entry)))
(setf (widget-valign entry) +align-center+
(widget-hexpand-p entry) t)
(connect entry "changed" (lambda (entry)
(setf expression (ignore-errors (read-from-string (entry-buffer-text (entry-buffer entry)))))
(funcall (if expression #'widget-remove-css-class #'widget-add-css-class) entry "error")))
(connect entry "activate" #'eval-expression)
(adw:action-row-add-suffix row entry))
(adw:preferences-group-add group row))
(box-append box group))
(let ((carousel-box box)
(box (make-box :orientation +orientation-horizontal+
:spacing 0)))
(setf (widget-hexpand-p box) t
(widget-halign box) +align-fill+)
(let ((button (make-button)))
(setf (widget-css-classes button) '("pill")
(widget-margin-all button) 10
(widget-hexpand-p button) t
(button-label button) "Exit")
(connect button "clicked" (lambda (button)
(declare (ignore button))
(window-destroy window)))
(box-append box button))
(let ((button (make-button)))
(setf (widget-css-classes button) '("suggested-action" "pill")
(widget-margin-all button) 10
(widget-hexpand-p button) t
(button-label button) "Eval")
(connect button "clicked" #'eval-expression)
(box-append box button))
(box-append carousel-box box))
(setf (adw:status-page-child page) box)))
(adw:carousel-append carousel page))
(box-append box carousel)))
(window-present window))))
(defun main ()
(let ((app (make-application :application-id "org.bohonghuang.cl-gtk4-libadwaita-example"
:flags gio:+application-flags-flags-none+)))
(connect app "activate" #'main-window)
(gio:application-run app nil)))
运行效果：
目前已测试可以在大部分实现上运行，包括 SBCL 、 CCL 、 ECL 与 ABCL ，项目开源在 Github 上，欢迎贡献代码、提 Issue ：
