Create a Win32 window using CFFI and run a message loop

window.lisp

(eval-when (:compile-toplevel :load-toplevel :execute)
  (unless (find-package '#:cffi)
    (ql:quickload '#:cffi)))

(in-package #:cl-user)

(defpackage #:window-example
  (:use #:cl #:cffi)
  (:export #:empty-window))

(in-package #:window-example)

(eval-when (:compile-toplevel :load-toplevel :execute)
  (define-foreign-library kernel32
    (t "kernel32.dll"))
  (define-foreign-library user32
    (t "user32.dll"))

  (use-foreign-library kernel32)
  (use-foreign-library user32))

(defconstant +cs-vredraw+ #x0001)
(defconstant +cs-hredraw+ #x0002)
(defconstant +cs-dblclks+ #x0008)
(defconstant +idc-arrow+ #x7F00)
(defconstant +idi-application+ #x7F00)
(defconstant +color-window+ 5)
(defconstant +ws-ex-windowedge+ #x00000100)
(defconstant +ws-ex-clientedge+ #x00000200)
(defconstant +ws-ex-overlappedwindow+ (logior +ws-ex-windowedge+
                                              +ws-ex-clientedge+))
(defconstant +ws-overlapped+ #x00000000)
(defconstant +ws-caption+ #x00C00000)
(defconstant +ws-sysmenu+ #x00080000)
(defconstant +ws-thickframe+ #x00040000)
(defconstant +ws-minimizebox+ #x00020000)
(defconstant +ws-maximizebox+ #x00010000)
(defconstant +ws-overlappedwindow+ (logior +ws-overlapped+
                                           +ws-caption+
                                           +ws-sysmenu+
                                           +ws-thickframe+
                                           +ws-minimizebox+
                                           +ws-maximizebox+))
(defconstant +ws-visible+ #x10000000)
(defconstant +cw-usedefault+ (- #x80000000 #x100000000))
(defconstant +sw-show+ 5)
(defconstant +wm-destroy+ #x0002)
(defconstant +wm-quit+ #x0012)
(defconstant +pm-remove+ 1)

(defcstruct wndclassex
  (size :uint)
  (style :uint)
  (wndproc :pointer)
  (cls-extra :int)
  (wnd-extra :int)
  (instance :pointer)
  (icon :pointer)
  (cursor :pointer)
  (background :pointer)
  (menu-name :pointer)
  (class-name :pointer)
  (icon-sm :pointer))

(defcstruct point
  (x :int)
  (y :int))

(defcstruct msg
  (hwnd :pointer)
  (msg :uint)
  (wparam :pointer)
  (lparam :pointer)
  (time :uint32)
  (pt (:struct point))
  (private :uint32))

(defcfun (get-last-error "GetLastError"
                         :convention :stdcall
                         :library kernel32)
    :uint32)

(defcfun (get-module-handle "GetModuleHandleW"
                            :convention :stdcall
                            :library kernel32)
    :pointer
  (name :pointer))

(defcfun (%register-class-ex "RegisterClassExW"
                             :convention :stdcall
                             :library user32)
    :uint16
  (wc (:pointer (:struct wndclassex))))

(defcfun (%unregister-class "UnregisterClassW"
                            :convention :stdcall
                            :library user32)
    :bool
  (name :pointer)
  (instance :pointer))

(defcfun (default-window-proc "DefWindowProcW"
                              :convention :stdcall
                              :library user32)
    :pointer
  (hwnd :pointer)
  (msg :uint)
  (wparam :pointer)
  (lparam :pointer))

(defcfun (post-quit-message "PostQuitMessage"
                            :convention :stdcall
                            :library user32)
    :void
  (exit-code :int))

(defcfun (load-cursor "LoadCursorW"
                      :convention :stdcall
                      :library user32)
    :pointer
  (instance :pointer)
  (name :pointer))

(defcfun (create-window-ex "CreateWindowExW"
                           :convention :stdcall
                           :library user32)
    :pointer
  (ex-style :uint32)
  (class-name (:string :encoding :utf-16/le))
  (window-name (:string :encoding :utf-16/le))
  (style :uint32)
  (x :int)
  (y :int)
  (width :int)
  (height :int)
  (parent :pointer)
  (menu :pointer)
  (instance :pointer)
  (param :pointer))

(defcfun (get-message "GetMessageW"
                      :convention :stdcall
                      :library user32)
    :boolean
  (msg (:pointer (:struct msg)))
  (hwnd :pointer)
  (filter-min :uint)
  (filter-max :uint))

(defcfun (translate-message "TranslateMessage"
                            :convention :stdcall
                            :library user32)
    :boolean
  (msg (:pointer (:struct msg))))

(defcfun (dispatch-message "DispatchMessageW"
                           :convention :stdcall
                           :library user32)
    :pointer
  (msg (:pointer (:struct msg))))

(defcfun (show-window "ShowWindow"
                      :convention :stdcall
                      :library user32)
    :boolean
  (hwnd :pointer)
  (cmd :int))

(defcallback (wndproc :convention :stdcall)
    :pointer ((hwnd :pointer)
              (msg :uint)
              (wparam :pointer)
              (lparam :pointer))
  ;; WM_DESTROY
  (cond ((= msg +wm-destroy+)
         (post-quit-message 0)
         (null-pointer))
        (t (default-window-proc hwnd msg wparam lparam))))

(defun register-class (name)
  (with-foreign-string (pname (string name) :encoding :utf-16/le)
    (with-foreign-object (p '(:struct wndclassex))
      (setf (foreign-slot-value p '(:struct wndclassex) 'size)
            (foreign-type-size '(:struct wndclassex))
            (foreign-slot-value p '(:struct wndclassex) 'style)
            (logior +cs-vredraw+ +cs-hredraw+ +cs-dblclks+)
            (foreign-slot-value p '(:struct wndclassex) 'wndproc)
            (callback wndproc)
            (foreign-slot-value p '(:struct wndclassex) 'cls-extra)
            0
            (foreign-slot-value p '(:struct wndclassex) 'wnd-extra)
            0
            (foreign-slot-value p '(:struct wndclassex) 'instance)
            (get-module-handle (null-pointer))
            (foreign-slot-value p '(:struct wndclassex) 'icon)
            (null-pointer)
            (foreign-slot-value p '(:struct wndclassex) 'cursor)
            (load-cursor (null-pointer) (make-pointer +idc-arrow+))
            (foreign-slot-value p '(:struct wndclassex) 'background)
            (make-pointer (1+ +color-window+))
            (foreign-slot-value p '(:struct wndclassex) 'menu-name)
            (null-pointer)
            (foreign-slot-value p '(:struct wndclassex) 'class-name)
            pname
            (foreign-slot-value p '(:struct wndclassex) 'icon-sm)
            (null-pointer))
      (let ((rv (%register-class-ex p)))
        (when (zerop rv)
          (error "Unable to register WNDCLASSEX: error #x~8,'0x" (get-last-error)))
        rv))))

(defun unregister-class (name)
  (with-foreign-string (p (string name) :encoding :utf-16/le)
    (%unregister-class p (get-module-handle (null-pointer)))))

(defun empty-window ()
  (let ((class-name "My Window Class"))
    (register-class class-name)
    (unwind-protect
         (let ((hwnd (create-window-ex
                      +ws-ex-overlappedwindow+ ; extended style
                      class-name               ; class name
                      "Hello from Lisp"        ; window name
                      (logior +ws-overlappedwindow+
                              +ws-visible+) ; style
                      +cw-usedefault+                    ; x
                      +cw-usedefault+                    ; y
                      +cw-usedefault+                    ; width
                      +cw-usedefault+                    ; height
                      (null-pointer)                     ; parent
                      (null-pointer)                     ; menu
                      (get-module-handle (null-pointer)) ; hInstance
                      (null-pointer))))                  ; param
           (when (null-pointer-p hwnd)
             (error "Unable to create a window. Error #x~8,'0x" (get-last-error)))
           (with-foreign-object (pmsg '(:struct msg))
             (show-window hwnd 5)
             (loop :while (get-message pmsg (null-pointer) 0 0)
                   :do (translate-message pmsg)
                       (dispatch-message pmsg))))
      (unregister-class class-name))))