TurtleWare

McCLIM and 7GUIs - Part 1: The Counter

Daniel Kochmański — 2026-01-26

Version 1: Using Gadgets and Layouts
Version 2: Using the CLIM Command Loop
Conclusion

For the last two months I've been polishing the upcoming release of McCLIM. The most notable change is the rewriting of the input editing and accepting-values abstractions. As it happens, I got tired of it, so as a breather I've decided to tackle something I had in mind for some time to improve the McCLIM manual – namely the 7GUIs: A GUI Programming Benchmark.

This challenge presents seven distinct tasks commonly found in graphical interface requirements. In this post I'll address the first challenge - The Counter. It is a fairly easy task, a warm-up of sorts. The description states:

Challenge: Understanding the basic ideas of a language/toolkit.

The task is to build a frame containing a label or read-only textfield T and a button B. Initially, the value in T is “0” and each click of B increases the value in T by one.

Counter serves as a gentle introduction to the basics of the language, paradigm and toolkit for one of the simplest GUI applications imaginable. Thus, Counter reveals the required scaffolding and how the very basic features work together to build a GUI application. A good solution will have almost no scaffolding.

In this first post, to make things more interesting, I'll solve it in two ways:

using contemporary abstractions like layouts and gadgets
using CLIM-specific abstractions like presentations and translators

In CLIM it is possible to mix both paradigms for defining graphical interfaces. Layouts and gadgets are predefined components that are easy to use, while using application streams enables a high degree of flexibility and composability.

First, we define a package shared by both versions:

(eval-when (:compile-toplevel :load-toplevel :execute)
  (unless (member :mcclim *features*)
    (ql:quickload "mcclim")))

(defpackage "EU.TURTLEWARE.7GUIS/TASK1"
  (:use  "CLIM-LISP" "CLIM" "CLIM-EXTENSIONS")
  (:export "COUNTER-V1" "COUNTER-V2"))
(in-package "EU.TURTLEWARE.7GUIS/TASK1")

Note that "CLIM-EXTENSIONS" package is McCLIM-specific.

Version 1: Using Gadgets and Layouts

Assuming that we are interested only in the functionality and we are willing to ignore the visual aspect of the program, the definition will look like this:

(define-application-frame counter-v1 ()
  ((value :initform 0 :accessor value))
  (:panes
   ;;      v type v initarg
   (tfield :label :label (princ-to-string (value *application-frame*))
                  :background +white+)
   (button :push-button :label "Count"
                        :activate-callback (lambda (gadget)
                                             (declare (ignore gadget))
                                             (with-application-frame (frame)
                                               (incf (value frame))
                                               (setf (label-pane-label (find-pane-named frame 'tfield))
                                                     (princ-to-string (value frame)))))))
  (:layouts (default (vertically () tfield button))))

;;; Start the application (if not already running).
;; (find-application-frame 'counter-v1)

The macro define-application-frame is like defclass with additional clauses. In our program we store the current value as a slot with an accessor.

The clause :panes is responsible for defining named panes (sub-windows). The first element is the pane name, then we specify its type, and finally we specify initargs for it. Panes are created in a dynamic context where the application frame is already bound to *application-frame*, so we can use it there.

The clause :layouts allows us to arrange panes on the screen. There may be multiple layouts that can be changed at runtime, but we define only one. The macro vertically creates another (anonymous) pane that arranges one gadget below another.

Gadgets in CLIM operate directly on top of the event loop. When the pointer button is pressed, it is handled by activating the callback, that updates the frame's value and the label. Effects are visible immediately.

Now if we want the demo to look nicer, all we need to do is to fiddle a bit with spacing and bordering in the :layouts section:

(define-application-frame counter-v1 ()
  ((value :initform 0 :accessor value))
  (:panes
   (tfield :label :label (princ-to-string (value *application-frame*))
                  :background +white+)
   (button :push-button :label "Count"
                        :activate-callback (lambda (gadget)
                                             (declare (ignore gadget))
                                             (with-application-frame (frame)
                                               (incf (value frame))
                                               (setf (label-pane-label (find-pane-named frame 'tfield))
                                                     (princ-to-string (value frame)))))))
  (:layouts (default
             (spacing (:thickness 10)
              (horizontally ()
                (100
                 (bordering (:thickness 1 :background +black+)
                   (spacing (:thickness 4 :background +white+) tfield)))
                15
                (100 button))))))

;;; Start the application (if not already running).
;; (find-application-frame 'counter-v1)

This gives us a layout that is roughly similar to the example presented on the 7GUIs page.

Version 2: Using the CLIM Command Loop

Unlike gadgets, stream panes in CLIM operate on top of the command loop. A single command may span multiple events after which we redisplay the stream to reflect the new state of the model. This is closer to the interaction type found in the command line interfaces:

  (define-application-frame counter-v2 ()
    ((value :initform 0 :accessor value))
    (:pane :application
     :display-function (lambda (frame stream)
                         (format stream "~d" (value frame)))))

  (define-counter-v2-command (com-incf-value :name "Count" :menu t)
      ()
    (with-application-frame (frame)
      (incf (value frame))))

;; (find-application-frame 'counter-v2)

Here we've used :pane option this is a syntactic sugar for when we have only one named pane. Skipping :layouts clause means that named panes will be stacked vertically one below another.

Defining the application frame defines a command-defining macro. When we define a command with define-counter-v2-command, then this command will be inserted into a command table associated with the frame. Passing the option :menu t causes the command to be available in the frame menu as a top-level entry.

After the command is executed (in this case it modifies the counter value), the application pane is redisplayed; that is a display function is called, and its output is captured. In more demanding scenarios it is possible to refine both the time of redisplay and the scope of changes.

Now we want the demo to look nicer and to have a button counterpart placed beside the counter value, to resemble the example more:

(define-presentation-type counter-button ())

(define-application-frame counter-v2 ()
  ((value :initform 0 :accessor value))
  (:menu-bar nil)
  (:pane :application
   :width 250 :height 32
   :borders nil :scroll-bars nil
   :end-of-line-action :allow
   :display-function (lambda (frame stream)
                       (formatting-item-list (stream :n-columns 2)
                         (formatting-cell (stream :min-width 100 :min-height 32)
                           (format stream "~d" (value frame)))
                         (formatting-cell (stream :min-width 100 :min-height 32)
                           (with-output-as-presentation (stream nil 'counter-button :single-box t)
                             (surrounding-output-with-border (stream :padding-x 20 :padding-y 0
                                                                     :filled t :ink +light-grey+)
                               (format stream "Count"))))))))

(define-counter-v2-command (com-incf-value :name "Count" :menu t)
    ()
  (with-application-frame (frame)
    (incf (value frame))))

(define-presentation-to-command-translator act-incf-value
    (counter-button com-incf-value counter-v2)
    (object)
  `())

;; (find-application-frame 'counter-v2)

The main addition is the definition of a new presentation type counter-button. This faux button is printed inside a cell and surrounded with a background. Later we define a translator that converts clicks on the counter button to the com-incf-value command. The translator body returns arguments for the command.

Presenting an object on the stream associates a semantic meaning with the output. We can now extend the application with new gestures (names :scroll-up and :scroll-down are McCLIM-specific):

(define-counter-v2-command (com-scroll-value :name "Increment")
    ((count 'integer))
  (with-application-frame (frame)
    (if (plusp count)
        (incf (value frame) count)
        (decf (value frame) (- count)))))

(define-presentation-to-command-translator act-scroll-up-value
    (counter-button com-scroll-value counter-v2 :gesture :scroll-up)
    (object)
  `(10))

(define-presentation-to-command-translator act-scroll-dn-value
    (counter-button com-scroll-value counter-v2 :gesture :scroll-down)
    (object)
  `(-10))

(define-presentation-action act-popup-value
    (counter-button nil counter-v2 :gesture :describe)
    (object frame)
  (notify-user frame (format nil "Current value: ~a" (value frame))))

A difference between presentation to command translators and presentation actions is that the latter does not automatically progress the command loop. Actions are often used for side effects, help, inspection etc.

Conclusion

In this short post we've solved the first task from the 7GUIs challenge. We've used two techniques available in CLIM – using layouts and gadgets, and using display and command tables. Both techniques can be combined, but differences are visible at a glance:

gadgets provide easy and reusable components for rudimentary interactions
streams provide extensible and reusable abstractions for semantic interactions

This post only scratched the capabilities of the latter, but the second version demonstrates why the command loop and presentations scale better than gadget-only solutions.

Following tasks have gradually increasing level of difficulty that will help us to emphasize how useful are presentations and commands when we want to write maintainable applications with reusable user-defined graphical metaphors.

Common Lisp and WebAssembly

Daniel Kochmański — 2025-11-28

Building ECL
Building WECL
Building user programs
Extending ASDF
Funding

Using Common Lisp in WASM enabled runtimes is a new frontier for the Common Lisp ecosystem. In the previous post Using Common Lisp from inside the Browser I've discussed how to embed Common Lisp scripts directly on the website, discussed the foreign function interface to JavaScript and SLIME port called LIME allowing the user to connect with a local Emacs instance.

This post will serve as a tutorial that describes how to build WECL and how to cross-compile programs to WASM runtime. Without further ado, let's dig in.

Building ECL

To compile ECL targeting WASM we first build the host version and then we use it to cross-compile it for the target architecture.

git clone https://gitlab.com/embeddable-common-lisp/ecl.git
cd ecl
export ECL_SRC=`pwd`
export ECL_HOST=${ECL_SRC}/ecl-host
./configure --prefix=${ECL_HOST} && make -j32 && make install

Currently ECL uses Emscripten SDK that implements required target primitives like libc. In the meantime, I'm also porting ECL to WASI, but it is not ready yet. In any case we need to install and activate emsdk:

git clone https://github.com/emscripten-core/emsdk.git
pushd emsdk
./emsdk install latest
./emsdk activate latest
source ./emsdk_env.sh
popd

Finally it is time to build the target version of ECL. A flag --disable-shared is optional, but keep in mind that cross-compilation of user programs is a new feature and it is still taking shape. Most notably some nuances with compiling systems from .asd files may differ depending on the flag used here.

make distclean # removes build/ directory
export ECL_WASM=${ECL_SRC}/ecl-wasm
export ECL_TO_RUN=${ECL_HOST}/bin/ecl
emconfigure ./configure --host=wasm32-unknown-emscripten --build=x86_64-pc-linux-gnu \
            --with-cross-config=${ECL_SRC}/src/util/wasm32-unknown-emscripten.cross_config \
            --prefix=${ECL_WASM} --disable-shared --with-tcp=no --with-cmp=no

emmake make -j32 && emmake make install

# some files need to be copied manually
cp build/bin/ecl.js build/bin/ecl.wasm ${ECL_WASM}

Running from a browser requires us to host the file. To spin Common Lisp web server on the spot, we can use one of our scripts (that assume that quicklisp is installed to download hunchentoot).

export WEBSERVER=${ECL_SRC}/src/util/webserver.lisp
${ECL_TO_RUN} --load $WEBSERVER
# After the server is loaded run:
# firefox localhost:8888/ecl-wasm/ecl.html

Running from node is more straightforward from the console perspective, but there is one caveat: read operations are not blocking, so if we try to run a default REPL we'll have many nested I/O errors because stdin returns EOF. Running in batch mode works fine though:

node ecl-wasm/ecl.js --eval '(format t "Hello world!~%")' --eval '(quit)'
warning: unsupported syscall: __syscall_prlimit64
Hello world!
program exited (with status: 0), but keepRuntimeAlive() is set (counter=0) due to an async operation, so halting execution but not exiting the runtime or preventing further async execution (you can use emscripten_force_exit, if you want to force a true shutdown)

The produced wasm is not suitable for running in other runtimes, because Emscripten requires additional functions to emulate setjmp. For example:

wasmedge ecl-wasm/ecl.wasm
[2025-11-21 13:34:54.943] [error] instantiation failed: unknown import, Code: 0x62
[2025-11-21 13:34:54.943] [error]     When linking module: "env" , function name: "invoke_iii"
[2025-11-21 13:34:54.943] [error]     At AST node: import description
[2025-11-21 13:34:54.943] [error]     This may be the import of host environment like JavaScript or Golang. Please check that you've registered the necessary host modules from the host programming language.
[2025-11-21 13:34:54.943] [error]     At AST node: import section
[2025-11-21 13:34:54.943] [error]     At AST node: module

Building WECL

The previous step allowed us to run vanilla ECL. Now we are going to use artifacts created during the compilation to create an application that skips boilerplate provided by vanilla Emscripten and includes Common Lisp code for easier development - FFI to JavaScript, windowing abstraction, support for

I've chosen to use unmodified names of JS operators in bindings to make looking them up easier. One can use an utility lispify-name to have lispy bindings:

(macrolet ((lispify-operator (name)
             `(defalias ,(lispify-name name) ,name))
           (lispify-accessor (name)
             (let ((lisp-name (lispify-name name)))
               `(progn
                  (defalias ,lisp-name ,name)
                  (defalias (setf ,lisp-name) (setf ,name))))))
  (lispify-operator |createElement|)    ;create-element
  (lispify-operator |appendChild|)      ;append-child
  (lispify-operator |removeChild|)      ;remove-child
  (lispify-operator |replaceChildren|)  ;replace-children
  (lispify-operator |addEventListener|) ;add-event-listener
  (lispify-accessor |innerText|)        ;inner-text
  (lispify-accessor |textContent|)      ;text-content
  (lispify-operator |setAttribute|)     ;set-attribute
  (lispify-operator |getAttribute|))    ;get-attribute

Note that scripts may be modified without recompiling WECL. On the other hand files that are loaded at startup (along with swank source code) are embedded in the wasm file. For now they are loaded at startup, but they may be compiled in the future if there is such need.

When using WECL in the browser, functions like compile-file and compile are available and they defer compilation to the bytecodes compiler. The bytecodes compiler in ECL is very fast, but produces unoptimized bytecode because it is a one-pass compiler. When performance matters, it is necessary to use compile on the host to an object file or to a static library and link it against WECL in file make.sh – recompilation of wecl.wasm is necessary.

Building user programs

Recently Marius Gerbershagen improved cross-compilation support for user programs from the host implementation using the same toolchain that builds ECL. Compiling files simple: use target-info.lisp file installed along with the cross-compiled ECL as an argument to with-compilation-unit:

;;; test-file-1.lisp
(in-package "CL-USER")
(defmacro twice (&body body) `(progn ,@body ,@body))

;;; test-file-1.lisp
(in-package "CL-USER")
(defun bam (x) (twice (format t "Hello world ~a~%" (incf x))))

(defvar *target*
  (c:read-target-info "/path/to/ecl-wasm/target-info.lsp"))

(with-compilation-unit (:target *target*)
  (compile-file "test-file-1.lisp" :system-p t :load t)
  (compile-file "test-file-2.lisp" :system-p t)
  (c:build-static-library "test-library"
                          :lisp-files '("test-file-1.o" "test-file-2.o")
                          :init-name "init_test"))

This will produce a file libtest-library.a. To use the library in WECL we should include it in the emcc invocation in make.sh and call the function init_test in Code/wecl.c before script-loader.lisp is loaded:

/* Initialize your libraries here, so they can be used in user scripts. */
extern void init_test(cl_object);
ecl_init_module(NULL, init_test);

Note that we've passed the argument :load to compile-file – it ensures that after the file is compiled, we load it (in our case - its source code) using the target runtime *features* value. During cross-compilation ECL includes also a feature :cross. Loading the first file is necessary to define a macro that is used in the second file. Now if we open REPL in the browser:

> #'lispify-name
#
> #'cl-user::bam
#
> (cl-user::bam 3)
Hello world 4
Hello world 5

Extending ASDF

The approach for cross-compiling in the previous section is the API provided by ECL. It may be a bit crude for everyday work, especially when we work with a complex dependency tree. In this section we'll write an extension to ASDF that allows us to compile entire system with its dependencies into a static library.

First let's define a package and add configure variables:

(defpackage "ASDF-ECL/CC"
  (:use "CL" "ASDF")
  (:export "CROSS-COMPILE" "CROSS-COMPILE-PLAN" "CLEAR-CC-CACHE"))
(in-package "ASDF-ECL/CC")

(defvar *host-target*
  (c::get-target-info))

#+(or)
(defvar *wasm-target*
  (c:read-target-info "/path/to/ecl-wasm/target-info.lsp"))

(defparameter *cc-target* *host-target*)
(defparameter *cc-cache-dir* #P"/tmp/ecl-cc-cache/")

ASDF operates in two passes – first it computes the operation plan and then it performs it. To help with specifying dependencies ASDF provides five mixins:

DOWNWARD-OPERATION: before operating on the component, perform an operation on children - i.e loading the system requires loading all its components.
UPWARD-OPERATION: before operating on the component, perform an operation on parent - i.e invalidating the cache requires invalidating cache of parent.
SIDEWAY-OPERATION: before operating on the component, perform the operation on all component dependencies - i.e load components that we depend on
SELFWARD-OPERATION: before operating on the component, perform operations on itself - i.e compile the component before loading it
NON-PROPAGATING-OPERATION: a standalone operation with no dependencies

Cross-compilation requires us to produce object file from each source file of the target system and its dependencies. We will achieve that by defining two operations: cross-object-op for producing object files from lisp source code and cross-compile-op for producing static libraries from objects:

(defclass cross-object-op (downward-operation) ())

(defmethod downward-operation ((self cross-object-op))
  'cross-object-op)

;;; Ignore all files that are not CL-SOURCE-FILE.
(defmethod perform ((o cross-object-op) (c t)))

(defmethod perform ((o cross-object-op) (c cl-source-file))
  (let ((input-file (component-pathname c))
        (output-file (output-file o c)))
    (multiple-value-bind (output warnings-p failure-p)
        (compile-file input-file :system-p t :output-file output-file)
      (uiop:check-lisp-compile-results output warnings-p failure-p
                                       "~/asdf-action::format-action/"
                                       (list (cons o c))))))

(defclass cross-compile-op (sideway-operation downward-operation)
  ())

(defmethod perform ((self cross-compile-op) (c system))
  (let* ((system-name (primary-system-name c))
         (inputs (input-files self c))
         (output (output-file self c))
         (init-name (format nil "init_lib_~a"
                            (substitute #\_ nil system-name
                                        :test (lambda (x y)
                                                (declare (ignore x))
                                                (not (alpha-char-p y)))))))
    (c:build-static-library output :lisp-files inputs
                                   :init-name init-name)))

(defmethod sideway-operation ((self cross-compile-op))
  'cross-compile-op)

(defmethod downward-operation ((self cross-compile-op))
  'cross-object-op)

We can confirm that the plan is computed correctly by running it on a system with many transient dependencies:

(defun debug-plan (system)
  (format *debug-io* "-- Plan for ~s -----------------~%" system)
  (map nil (lambda (a)
             (format *debug-io* "~24a: ~a~%" (car a) (cdr a)))
       (asdf::plan-actions
        (make-plan 'sequential-plan 'cross-compile-op system))))

(debug-plan "mcclim")

In Common Lisp the compilation of subsequent files often depends on previous definitions. That means that we need to load files. Loading files compiled for another architecture is not an option. Moreover:

some systems will have different dependencies based on features
code may behave differently depending on the evaluation environment
compilation may require either host or target semantics for cross-compilation

There is no general solution except from full target emulation or the client code being fully aware that it is being cross compiled. That said, surprisingly many Common Lisp programs can be cross-compiled without many issues.

In any case we need to be able to load source code while it is being compiled. Depending on the actual code we may want to specify the host or the target features, load the source code directly or first compile it, etc. To allow user choosing the load strategy we define an operation cross-load-op:

(defparameter *cc-load-type* :minimal)
(defvar *cc-last-load* :minimal)

(defclass cross-load-op (non-propagating-operation) ())

(defmethod operation-done-p ((o cross-load-op) (c system))
  (and (component-loaded-p c)
       (eql *cc-last-load* *cc-load-type*)))

;;; :FORCE :ALL is excessive. We should store the compilation strategy flag as a
;;; compilation artifact and compare it with *CC-LOAD-TYPE*.
(defmethod perform ((o cross-load-op) (c system))
  (setf *cc-last-load* *cc-load-type*)
  (ecase *cc-load-type*
    (:emulate
     (error "Do you still believe in Santa Claus?"))
    (:default
     (operate 'load-op c))
    (:minimal
     (ext:install-bytecodes-compiler)
     (operate 'load-op c)
     (ext:install-c-compiler))
    (:ccmp-host
     (with-compilation-unit (:target *host-target*)
       (operate 'load-op c :force :all)))
    (:bcmp-host
     (with-compilation-unit (:target *host-target*)
       (ext:install-bytecodes-compiler)
       (operate 'load-op c :force :all)
       (ext:install-c-compiler)))
    (:bcmp-target
     (with-compilation-unit (:target *cc-target*)
       (ext:install-bytecodes-compiler)
       (operate 'load-op c :force :all)
       (ext:install-c-compiler)))
    (:load-host
     (with-compilation-unit (:target *host-target*)
       (operate 'load-source-op c :force :all)))
    (:load-target
     (with-compilation-unit (:target *cc-target*)
       (operate 'load-source-op c :force :all)))))

To estabilish a cross-compilation dynamic context suitable for ASDF operations we'll define a new macro WITH-ASDF-COMPILATION-UNIT. It modifies the cache directory, injects features that are commonly expected by various systems, and configures the ECL compiler. That macro is used while the

;;; KLUDGE some system definitions test that *FEATURES* contains this or that
;;; variant of :ASDF* and bark otherwise.
;;;
;;; KLUDGE systems may have DEFSYSTEM-DEPENDS-ON that causes LOAD-ASD to try to
;;; load the system -- we need to modify *LOAD-SYSTEM-OPERATION* for that. Not
;;; to be conflated with CROSS-LOAD-UP.
;;; 
;;; KLUDGE We directly bind ASDF::*OUTPUT-TRANSLATIONS* because ASDF advertised
;;; API does not work.
(defmacro with-asdf-compilation-unit (() &body body)
  `(with-compilation-unit (:target *cc-target*)
     (flet ((cc-path ()
              (merge-pathnames "**/*.*"
                               (uiop:ensure-directory-pathname *cc-cache-dir*))))
       (let ((asdf::*output-translations* `(((t ,(cc-path)))))
             (*load-system-operation* 'load-source-op)
             (*features* (remove-duplicates
                          (list* :asdf :asdf2 :asdf3 :asdf3.1 *features*))))
         ,@body))))

Note that loading the system should happen in a different environment than compiling it. Most notably we can't reuse the cache. That's why cross-load-op must not be a dependency of cross-compile-op. Output translations and features affect the planning phase, so we need estabilish the environment over operate and not only perform. We will also define functions for the user to invoke cross-compilation, to show cross-compilation plan and to wipe the cache:

(defun cross-compile (system &rest args
                      &key cache-dir target load-type &allow-other-keys)
  (let ((*cc-cache-dir* (or cache-dir *cc-cache-dir*))
        (*cc-target* (or target *cc-target*))
        (*cc-load-type* (or load-type *cc-load-type*))
        (cc-operation (make-operation 'cross-compile-op)))
    (apply 'operate cc-operation system args)
    (with-asdf-compilation-unit () ;; ensure cache
      (output-file cc-operation system))))

(defun cross-compile-plan (system target)
  (format *debug-io* "-- Plan for ~s -----------------~%" system)
  (let ((*cc-target* target))
    (with-asdf-compilation-unit ()
      (map nil (lambda (a)
                 (format *debug-io* "~24a: ~a~%" (car a) (cdr a)))
           (asdf::plan-actions
            (make-plan 'sequential-plan 'cross-compile-op system))))))

(defun cross-compile-plan (system target)
  (format *debug-io* "-- Plan for ~s -----------------~%" system)
  (let ((*cc-target* target))
    (with-asdf-compilation-unit ()
      (map nil (lambda (a)
                 (format *debug-io* "~24a: ~a~%" (car a) (cdr a)))
           (asdf::plan-actions
            (make-plan 'sequential-plan 'cross-compile-op system))))))

(defun clear-cc-cache (&key (dir *cc-cache-dir*) (force nil))
  (uiop:delete-directory-tree
   dir
   :validate (or force (yes-or-no-p "Do you want to delete recursively ~S?" dir))
   :if-does-not-exist :ignore))

;;; CROSS-LOAD-OP happens inside the default environment, while the plan for
;;; cross-compilation should have already set the target features.

(defmethod operate ((self cross-compile-op) (c system) &rest args)
  (declare (ignore args))
  (unless (operation-done-p 'cross-load-op c)
    (operate 'cross-load-op c))
  (with-asdf-compilation-unit ()
    (call-next-method)))

Last but not least we need to specify input and output files for operations. This will tie into the plan, so that compiled objects will be reused. Computing input files for cross-compile-op is admittedly hairy, because we need to visit all dependency systems and collect their outputs too. Dependencies may take various forms, so we need to normalize them.

(defmethod input-files ((o cross-object-op) (c cl-source-file))
  (list (component-pathname c)))

(defmethod output-files ((o cross-object-op) (c cl-source-file))
  (let ((input-file (component-pathname c)))
    (list (compile-file-pathname input-file :type :object))))

(defmethod input-files ((self cross-compile-op) (c system))
  (let ((visited (make-hash-table :test #'equal))
        (systems nil))
    (labels ((normalize-asdf-system (dep)
               (etypecase dep
                 ((or string symbol)
                  (setf dep (find-system dep)))
                 (system)
                 (cons
                  (ecase (car dep)
                    ;; *features* are bound here to the target.
                    (:feature
                     (destructuring-bind (feature depspec) (cdr dep)
                       (if (member feature *features*)
                           (setf dep (normalize-asdf-system depspec))
                           (setf dep nil))))
                    ;; INV if versions were incompatible, then CROSS-LOAD-OP would bark.
                    (:version
                     (destructuring-bind (depname version) (cdr dep)
                       (declare (ignore version))
                       (setf dep (normalize-asdf-system depname))))
                    ;; Ignore "require", these are used during system loading.
                    (:require))))
               dep)
             (rec (sys)
               (setf sys (normalize-asdf-system sys))
               (when (null sys)
                 (return-from rec))
               (unless (gethash sys visited)
                 (setf (gethash sys visited) t)
                 (push sys systems)
                 (map nil #'rec (component-sideway-dependencies sys)))))
      (rec c)
      (loop for sys in systems
            append (loop for sub in (asdf::sub-components sys :type 'cl-source-file)
                         collect (output-file 'cross-object-op sub))))))

(defmethod output-files ((self cross-compile-op) (c system))
  (let* ((path (component-pathname c))
         (file (make-pathname :name (primary-system-name c) :defaults path)))
    (list (compile-file-pathname file :type :static-library))))

At last we can cross compile ASDF systems. Let's give it a try:

ASDF-ECL/CC> (cross-compile-plan "flexi-streams" *wasm-target*)
-- Plan for "flexi-streams" -----------------
#     : #
#     : #
#    : #
#     : #
#     : #
#     : #
#     : #
#     : #
#     : #
#     : #
#     : #
#     : #
#     : #
#     : #
#     : #
#     : #
#     : #
#     : #
#     : #
#     : #
#     : #
#     : #
#     : #
#     : #
#    : #
NIL
ASDF-ECL/CC> (cross-compile "flexi-streams" :target *wasm-target*)
;;; ...
#P"/tmp/ecl-cc-cache/libs/flexi-streams-20241012-git/libflexi-streams.a"

Note that libflexi-streams.a contains all objects from both libraries flexi-streams and trivial-gray-streams. All artifacts are cached, so if you remove an object or modify a file, then only necessary parts will be recompiled.

All that is left is to include libflexi-streams.a in make.sh and put the initialization form in wecl.c:

extern void init_lib_flexi_streams(cl_object);
ecl_init_module(NULL, init_lib_flexi_streams);.

This should suffice for the first iteration for cross-compiling systems. Next steps of improvement would be:

compiling to static libraries (without dependencies)
compiling to shared libraries (with and without dependencies)
compiling to an executable (final wasm file)
target system emulation (for faithful correspondence between load and compile)

The code from this section may be found in wecl repository

Funding

This project is funded through NGI0 Commons Fund, a fund established by NLnet with financial support from the European Commission's Next Generation Internet program. Learn more at the NLnet project page.

Using Common Lisp from inside the Browser

Daniel Kochmański — 2025-08-21

Scripting a website with Common Lisp
JS-FFI – low level interface
LIME/SLUG – interacting from Emacs
Injecting CL runtime in arbitrary websites
Current Caveats
Funding

Web Embeddable Common Lisp is a project that brings Common Lisp and the Web Browser environments together. In this post I'll outline the current progress of the project and provide some technical details, including current caveats and future plans.

It is important to note that this is not a release and none of the described APIs and functionalities is considered to be stable. Things are still changing and I'm not accepting bug reports for the time being.

The source code of the project is available: https://fossil.turtleware.eu/wecl/.

Scripting a website with Common Lisp

The easiest way to use Common Lisp on a website is to include WECL and insert script tags with a type "text/common-lisp". When the attribute src is present, then first the runtime loads the script from that url, and then it executes the node body. For example create and run this HTML document from localhost:



  
    Web Embeddable Common Lisp

We may use Common Lisp that can call to JavaScript, and register callbacks to be called on specified events. The source code of the script can be found here:

Because the runtime is included as a script, the browser will usually cache the ~10MB WebAssembly module.

JS-FFI – low level interface

The initial foreign function interface has numerous macros defining wrappers that may be used from Common Lisp or passed to JavaScript.

Summary of currently available operators:

define-js-variable: an inlined expression, like document
define-js-object: an object referenced from the object store
define-js-function: a function
define-js-method: a method of the argument, like document.foobar()
define-js-getter: a slot reader of the argument
define-js-setter: a slot writer of the first argument
define-js-accessor: combines define-js-getter and define-js-setter
define-js-script: template for JavaScript expressions
define-js-callback: Common Lisp function reference callable from JavaScript
lambda-js-callback: anonymous Common Lisp function reference (for closures)

Summary of argument types:

type name	lisp side	js side
:object	Common Lisp object	Common Lisp object reference
:js-ref	JavaScript object reference	JavaScript object
:fixnum	fixnum (coercible)	fixnum (coercible)
:symbol	symbol	symbol (name inlined)
:string	string (coercible)	string (coercible)
:null	nil	null

All operators, except for LAMBDA-JS-CALLBACK have a similar lambda list:

(DEFINE-JS NAME-AND-OPTIONS [ARGUMENTS [,@BODY]])

The first argument is a list (name &key js-expr type) that is common to all defining operators:

name: Common Lisp symbol denoting the object
js-expr: a string denoting the JavaScript expression, i.e "innerText"
type: a type of the object returned by executing the expression

For example:

(define-js-variable ([document] :js-expr "document" :type :symbol))
;; document
(define-js-object ([body] :js-expr "document.body" :type :js-ref))
;; wecl_ensure_object(document.body) /* -> id   */
;; wecl_search_object(id)            /* -> node */

The difference between a variable and an object in JS-FFI is that variable expression is executed each time when the object is used (the expression is inlined), while the object expression is executed only once and the result is stored in the object store.

The second argument is a list of pairs (name type). Names will be used in the lambda list of the operator callable from Common Lisp, while types will be used to coerce arguments to the type expected by JavaScript.

(define-js-function (parse-float :js-expr "parseFloat" :type :js-ref)
    ((value :string)))
;; parseFloat(value)

(define-js-method (add-event-listener :js-expr "addEventListener" :type :null)
    ((self :js-ref)
     (name :string)
     (fun :js-ref)))
;; self.addEventListener(name, fun)

(define-js-getter (get-inner-text :js-expr "innerText" :type :string)
    ((self :js-ref)))
;; self.innerText

(define-js-setter (set-inner-text :js-expr "innerText" :type :string)
    ((self :js-ref)
     (new :string)))
;; self.innerText = new

(define-js-accessor (inner-text :js-expr "innerText" :type :string)
    ((self :js-ref)
     (new :string)))
;; self.innerText
;; self.innerText = new

(define-js-script (document :js-expr "~a.forEach(~a)" :type :js-ref)
    ((nodes :js-ref)
     (callb :object)))
;; nodes.forEach(callb)

The third argument is specific to callbacks, where we define Common Lisp body of the callback. Argument types are used to coerce values from JavaScript to Common Lisp.

(define-js-callback (print-node :type :object)
    ((elt :js-ref)
     (nth :fixnum)
     (seq :js-ref))
  (format t "Node ~2d: ~a~%" nth elt))

(let ((start 0))
  (add-event-listener *my-elt* "click"
                      (lambda-js-callback :null ((event :js-ref)) ;closure!
                        (incf start)
                        (setf (inner-text *my-elt*)
                              (format nil "Hello World! ~a" start)))

Note that callbacks are a bit different, because define-js-callback does not accept js-expr option and lambda-js-callback has unique lambda list. It is important for callbacks to have an exact arity as they are called with, because JS-FFI does not implement variable number of arguments yet.

Callbacks can be referred by name with an operator (js-callback name).

LIME/SLUG – interacting from Emacs

While working on FFI I've decided to write an adapter for SLIME/SWANK that will allow interacting with WECL from Emacs. The principle is simple: we connect with a websocket to Emacs that is listening on the specified port (i.e on localhost). This adapter uses the library emacs-websocket written by Andrew Hyatt.

It allows for compiling individual forms with C-c C-c, but file compilation does not work (because files reside on a different "host"). REPL interaction works as expected, as well as SLDB. The connection may occasionally be unstable, and until Common Lisp call returns, the whole page is blocked. Notably waiting for new requests is not a blocking operation from the JavaScript perspective, because it is an asynchronous operation.

You may find my changes to SLIME here: https://github.com/dkochmanski/slime/, and it is proposed upstream here: https://github.com/slime/slime/pull/879. Before these changes are merged, we'll patch SLIME:

;;; Patches for SLIME 2.31 (to be removed after the patch is merged).
;;; It is assumed that SLIME is already loaded into Emacs.
(defun slime-net-send (sexp proc)
  "Send a SEXP to Lisp over the socket PROC.
This is the lowest level of communication. The sexp will be READ and
EVAL'd by Lisp."
  (let* ((payload (encode-coding-string
                   (concat (slime-prin1-to-string sexp) "\n")
                   'utf-8-unix))
         (string (concat (slime-net-encode-length (length payload))
                         payload))
         (websocket (process-get proc :websocket)))
    (slime-log-event sexp)
    (if websocket
        (websocket-send-text websocket string)
      (process-send-string proc string))))

(defun slime-use-sigint-for-interrupt (&optional connection)
  (let ((c (or connection (slime-connection))))
    (cl-ecase (slime-communication-style c)
      ((:fd-handler nil) t)
      ((:spawn :sigio :async) nil))))

Now we can load the LIME adapter opens a websocket server. The source code may be downloaded from https://turtleware.eu/static/misc/wecl-20250821/lime.el:

;;; lime.el --- Lisp Interaction Mode for Emacs -*-lexical-binding:t-*-
;;; 
;;; This program extends SLIME with an ability to listen for lisp connections.
;;; The flow is reversed - normally SLIME is a client and SWANK is a server.

(require 'websocket)

(defvar *lime-server* nil
  "The LIME server.")

(cl-defun lime-zipit (obj &optional (start 0) (end 72))
  (let* ((msg (if (stringp obj)
                  obj
                (slime-prin1-to-string obj)))
         (len (length msg)))
    (substring msg (min start len) (min end len))))

(cl-defun lime-message (&rest args)
  (with-current-buffer (process-buffer *lime-server*)
    (goto-char (point-max))
    (dolist (arg args)
      (insert (lime-zipit arg)))
    (insert "\n")
    (goto-char (point-max))))

(cl-defun lime-client-process (client)
  (websocket-conn client))

(cl-defun lime-process-client (process)
  (process-get process :websocket))

;;; c.f slime-net-connect
(cl-defun lime-add-client (client)
  (lime-message "LIME connecting a new client")
  (let* ((process (websocket-conn client))
         (buffer (generate-new-buffer "*lime-connection*")))
    (set-process-buffer process buffer)
    (push process slime-net-processes)
    (slime-setup-connection process)
    client))

;;; When SLIME kills the process, then it invokes LIME-DISCONNECT hook.
;;; When SWANK kills the process, then it invokes LIME-DEL-CLIENT hook.
(cl-defun lime-del-client (client)
  (when-let ((process (lime-client-process client)))
    (lime-message "LIME client disconnected")
    (slime-net-sentinel process "closed by peer")))

(cl-defun lime-disconnect (process)
  (when-let ((client (lime-process-client process)))
    (lime-message "LIME disconnecting client")
    (websocket-close client)))

(cl-defun lime-on-error (client fun error)
  (ignore client fun)
  (lime-message "LIME error: " (slime-prin1-to-string error)))

;;; Client sends the result over a websocket. Handling responses is implemented
;;; by SLIME-NET-FILTER. As we can see, the flow is reversed in our case.
(cl-defun lime-handle-message (client frame)
  (let ((process (lime-client-process client))
        (data (websocket-frame-text frame)))
    (lime-message "LIME-RECV: " data)
    (slime-net-filter process data)))

(cl-defun lime-net-listen (host port &rest parameters)
  (when *lime-server*
    (error "LIME server has already started"))
  (setq *lime-server*
        (apply 'websocket-server port
               :host host
               :on-open    (function lime-add-client)
               :on-close   (function lime-del-client)
               :on-error   (function lime-on-error)
               :on-message (function lime-handle-message)
               parameters))
  (unless (memq 'lime-disconnect slime-net-process-close-hooks)
    (push 'lime-disconnect slime-net-process-close-hooks))
  (let ((buf (get-buffer-create "*lime-server*")))
    (set-process-buffer *lime-server* buf)
    (lime-message "Welcome " *lime-server* "!")
    t))

(cl-defun lime-stop ()
  (when *lime-server*
   (websocket-server-close *lime-server*)
   (setq *lime-server* nil)))

After loading this file into Emacs invoke (lime-net-listen "localhost" 8889). Now our Emacs listens for new connections from SLUG (the lisp-side part adapting SWANK, already bundled with WECL). There are two SLUG backends in a repository:

WANK: for web browser environment
FRIG: for Common Lisp runtime (uses websocket-driver-client)

Now you can open a page listed here and connect to SLIME:



  
    Web Embeddable Common Lisp

https://turtleware.eu/static/misc/wecl-20250821/slug.html.

This example shows an important limitation – Emscripten does not allow for multiple asynchronous contexts in the same thread. That means that if Lisp call doesn't return (i.e because it waits for input in a loop), then we can't execute other Common Lisp statements from elsewhere because the application will crash.

Injecting CL runtime in arbitrary websites

Here's another example. It is more a cool gimmick than anything else, but let's try it. Open a console on this very website (on firefox C-S-i) and execute:

function inject_js(url) {
    var head = document.getElementsByTagName('head')[0];
    var script = document.createElement('script');
    head.appendChild(script);
    script.type = 'text/javascript';
    return new Promise((resolve) => {
        script.onload = resolve;
        script.src = url;
    });
}

function inject_cl() {
    wecl_eval('(wecl/impl::js-load-slug "https://turtleware.eu/static/misc/wecl-20250821")');
}

inject_js('https://turtleware.eu/static/misc/wecl-20250821/boot.js')
    .then(() => {
        wecl_init_hooks.push(inject_cl);
        inject_js('https://turtleware.eu/static/misc/wecl-20250821/wecl.js');
    });

With this, assuming that you've kept your LIME server open, you'll have a REPL onto uncooperative website. Now we can fool around with queries and changes:

(define-js-accessor (title :js-expr "title" :type :string)
  ((self :js-ref)
   (title :string)))

(define-js-accessor (background :js-expr "body.style.backgroundColor" :type :string)
  ((self :js-ref)
   (background :string)))

(setf (title [document]) "Write in Lisp!")
(setf (background [document]) "#aaffaa")

Current Caveats

The first thing to address is the lack of threading primitives. Native threads can be implemented with web workers, but then our GC wouldn't know how to stop the world to clean up. Another option is to use cooperative threads, but that also won't work, because Emscripten doesn't support independent asynchronous contexts, nor ECL is ready for that yet.

I plan to address both issues simultaneously in the second stage of the project when I port the runtime to WASI. We'll be able to use browser's GC, so running in multiple web workers should not be a problem anymore. Unwinding and rewinding the stack will require tinkering with ASYNCIFY and I have somewhat working green threads implementation in place, so I will finish it and upstream in ECL.

Currently I'm focusing mostly on having things working, so JS and CL interop is brittle and often relies on evaluating expressions, trampolining and coercing. That impacts the performance in a significant way. Moreover all loaded scripts are compiled with a one-pass compiler, so the result bytecode is not optimized.

There is no support for loading cross-compiled files onto the runtime, not to mention that it is not possible to precompile systems with ASDF definitions.

JS-FFI requires more work to allow for defining functions with variable number of arguments and with optional arguments. There is no dynamic coercion of JavaScript exceptions to Common Lisp conditions, but it is planned.

Funding

Dynamic Vars - Return of the Jedi

Daniel Kochmański — 2024-11-04

The protocol
Control operators
Synchronized hash tables with weakness
First-class dynamic variables
1. STANDARD-DYNAMIC-VARIABLE
2. SURROGATE-DYNAMIC-VARIABLE
Thread-local variables
1. The protocol
2. The implementation
Thread-local slots
What can we use it for?

In the previous two posts I've presented an implementation of first-class dynamic variables using PROGV and a surrogate implementation for SBCL.

Now we will double down on this idea and make the protocol extensible. Finally we'll implement a specialized version of dynamic variables where even the top level value of the variable is thread-local.

The protocol

Previously we've defined operators as either macros or functions. Different implementations were protected by the feature flag and symbols collided. Now we will introduce the protocol composed of a common superclass and functions that are specialized by particular implementations.

Most notably we will introduce a new operator CALL-WITH-DYNAMIC-VARIABLE that is responsible for establishing a single binding. Thanks to that it will be possible to mix dynamic variables of different types within a single DLET statement.

(defclass dynamic-variable () ())

(defgeneric dynamic-variable-bindings (dvar))
(defgeneric dynamic-variable-value (dvar))
(defgeneric (setf dynamic-variable-value) (value dvar))
(defgeneric dynamic-variable-bound-p (dvar))
(defgeneric dynamic-variable-makunbound (dvar))
(defgeneric call-with-dynamic-variable (cont dvar &optional value))

Moreover we'll define a constructor that is specializable by a key. This design will allow us to refer to the dynamic variable class by using a shorter name. We will also define the standard class to be used and an matching constructor.

(defparameter *default-dynamic-variable-class*
  #-fake-progv-kludge 'standard-dynamic-variable
  #+fake-progv-kludge 'surrogate-dynamic-variable)

(defgeneric make-dynamic-variable-using-key (key &rest initargs)
  (:method (class &rest initargs)
    (apply #'make-instance class initargs))
  (:method ((class (eql t)) &rest initargs)
    (apply #'make-instance *default-dynamic-variable-class* initargs))
  (:method ((class null) &rest initargs)
    (declare (ignore class initargs))
    (error "Making a dynamic variable that is not, huh?")))

(defun make-dynamic-variable (&rest initargs)
  (apply #'make-dynamic-variable-using-key t initargs))

Control operators

Control operators are the same as previously, that is a set of four macros that consume the protocol specified above. Note that DYNAMIC-VARIABLE-PROGV expands to a recursive call where each binding is processed separately.

(defmacro dlet (bindings &body body)
  (flet ((pred (binding)
           (and (listp binding) (= 2 (length binding)))))
    (unless (every #'pred bindings)
      (error "DLET: bindings must be lists of two values.~%~
              Invalid bindings:~%~{ ~s~%~}" (remove-if #'pred bindings))))
  (loop for (var val) in bindings
        collect var into vars
        collect val into vals
        finally (return `(dynamic-variable-progv (list ,@vars) (list ,@vals)
                           ,@body))))

(defmacro dset (&rest pairs)
  `(setf ,@(loop for (var val) on pairs by #'cddr
                 collect `(dref ,var)
                 collect val)))

(defmacro dref (variable)
  `(dynamic-variable-value ,variable))

(defun call-with-dynamic-variable-progv (cont vars vals)
  (flet ((thunk ()
           (if vals
               (call-with-dynamic-variable cont (car vars) (car vals))
               (call-with-dynamic-variable cont (car vars)))))
    (if vars
        (call-with-dynamic-variable-progv #'thunk (cdr vars) (cdr vals))
        (funcall cont))))

(defmacro dynamic-variable-progv (vars vals &body body)
  (let ((cont (gensym)))
    `(flet ((,cont () ,@body))
       (call-with-dynamic-variable-progv (function ,cont) ,vars ,vals))))

Synchronized hash tables with weakness

Previously we've used SBCL-specific options to define a synchronized hash table with weak keys. This won't do anymore, because we will need a similar object to implement the thread-local storage for top level values.

trivial-garbage is a portability layer that allows to define hash tables with a specified weakness, but it does not provide an argument that would abstract away synchronization. We will ensure thread-safety with locks instead.

(defclass tls-table ()
  ((table :initform (trivial-garbage:make-weak-hash-table
                     :test #'eq :weakness :key))
   (lock :initform (bt:make-lock))))

(defun make-tls-table ()
  (make-instance 'tls-table))

(defmacro with-tls-table ((var self) &body body)
  (let ((obj (gensym)))
    `(let* ((,obj ,self)
            (,var (slot-value ,obj 'table)))
       (bt:with-lock-held ((slot-value ,obj 'lock)) ,@body))))

First-class dynamic variables

`STANDARD-DYNAMIC-VARIABLE`

Previously in the default implementation we've represented dynamic variables with a symbol. The new implementation is similar except that the symbol is read from a STANDARD-OBJECT that represents the variable. This also enables us to specialize the function CALL-WITH-DYNAMIC-VARIABLE:

(defclass standard-dynamic-variable (dynamic-variable)
  ((symbol :initform (gensym) :accessor dynamic-variable-bindings)))

(defmethod dynamic-variable-value ((dvar standard-dynamic-variable))
  (symbol-value (dynamic-variable-bindings dvar)))

(defmethod (setf dynamic-variable-value) (value (dvar standard-dynamic-variable))
  (setf (symbol-value (dynamic-variable-bindings dvar)) value))

(defmethod dynamic-variable-bound-p ((dvar standard-dynamic-variable))
  (boundp (dynamic-variable-bindings dvar)))

(defmethod dynamic-variable-makunbound ((dvar standard-dynamic-variable))
  (makunbound (dynamic-variable-bindings dvar)))

(defmethod call-with-dynamic-variable (cont (dvar standard-dynamic-variable)
                                       &optional (val nil val-p))
  (progv (list (dynamic-variable-bindings dvar)) (if val-p (list val) ())
    (funcall cont)))

`SURROGATE-DYNAMIC-VARIABLE`

The implementation of the SURROGATE-DYNAMIC-VARIABLE is almost the same as previously. The only difference is that we use the previously defined indirection to safely work with hash tables. Also note, that we are not add the feature condition - both classes is always created.

(defvar +fake-unbound+ 'unbound)
(defvar +cell-unbound+ '(no-binding))

(defclass surrogate-dynamic-variable (dynamic-variable)
  ((tls-table
    :initform (make-tls-table)
    :reader dynamic-variable-tls-table)
   (top-value
    :initform +fake-unbound+
    :accessor dynamic-variable-top-value)))

(defmethod dynamic-variable-bindings ((dvar surrogate-dynamic-variable))
  (let ((process (bt:current-thread)))
    (with-tls-table (tls-table (dynamic-variable-tls-table dvar))
      (gethash process tls-table +cell-unbound+))))

(defmethod (setf dynamic-variable-bindings) (value (dvar surrogate-dynamic-variable))
  (let ((process (bt:current-thread)))
    (with-tls-table (tls-table (dynamic-variable-tls-table dvar))
      (setf (gethash process tls-table) value))))

(defun %dynamic-variable-value (dvar)
  (let ((tls-binds (dynamic-variable-bindings dvar)))
    (if (eq tls-binds +cell-unbound+)
        (dynamic-variable-top-value dvar)
        (car tls-binds))))

(defmethod dynamic-variable-value ((dvar surrogate-dynamic-variable))
  (let ((tls-value (%dynamic-variable-value dvar)))
    (when (eq tls-value +fake-unbound+)
      (error 'unbound-variable :name "(unnamed)"))
    tls-value))

(defmethod (setf dynamic-variable-value) (value (dvar surrogate-dynamic-variable))
  (let ((tls-binds (dynamic-variable-bindings dvar)))
    (if (eq tls-binds +cell-unbound+)
        (setf (dynamic-variable-top-value dvar) value)
        (setf (car tls-binds) value))))

(defmethod dynamic-variable-bound-p ((dvar surrogate-dynamic-variable))
  (not (eq +fake-unbound+ (%dynamic-variable-value dvar))))

(defmethod dynamic-variable-makunbound ((dvar surrogate-dynamic-variable))
  (setf (dynamic-variable-value dvar) +fake-unbound+))


;;; Apparently CCL likes to drop^Helide some writes and that corrupts bindings
;;; table. Let's ensure that the value is volatile.
#+ccl (defvar *ccl-ensure-volatile* nil)
(defmethod call-with-dynamic-variable (cont (dvar surrogate-dynamic-variable)
                                       &optional (val +fake-unbound+))
  (push val (dynamic-variable-bindings dvar))
  (let (#+ccl (*ccl-ensure-volatile* (dynamic-variable-bindings dvar)))
    (unwind-protect (funcall cont)
      (pop (dynamic-variable-bindings dvar)))))

Thread-local variables

We've refactored the previous code to be extensible. Now we can use metaobjects from the previous post without change. We can also test both implementations in the same process interchangeably by customizing the default class parameter.

It is the time now to have some fun and extend dynamic variables into variables with top value not shared between different threads. This will enable ultimate thread safety. With our new protocol the implementation is trivial!

The protocol

First we will define the protocol class. THREAD-LOCAL-VARIABLE is a variant of a DYNAMIC-VARIABLE with thread-local top values.

We specify initialization arguments :INITVAL and :INITFUN that will be used to assign the top value of a binding. The difference is that INITVAL specifies a single value, while INITFUN can produce an unique object on each invocation. INITARG takes a precedence over INTIFUN, and if neither is supplied, then a variable is unbound.

We include the constructor that builds on MAKE-DYNAMIC-VARIABLE-USING-KEY, and macros corresponding to DEFVAR and DEFPARAMETER. Note that they expand to :INITFUN - this assures that the initialization form is re-evaluated for each new thread where the variable is used.

(defclass thread-local-variable (dynamic-variable) ())

(defmethod initialize-instance :after
    ((self thread-local-variable) &key initfun initval)
  (declare (ignore self initfun initval)))

(defparameter *default-thread-local-variable-class*
  #-fake-progv-kludge 'standard-thread-local-variable
  #+fake-progv-kludge 'surrogate-thread-local-variable)

(defun make-thread-local-variable (&rest initargs)
  (apply #'make-dynamic-variable-using-key
         *default-thread-local-variable-class* initargs))

(defmacro create-tls-variable (&optional (form nil fp) &rest initargs)
  `(make-thread-local-variable 
    ,@(when fp `(:initfun (lambda () ,form)))
    ,@initargs))

(defmacro define-tls-variable (name &rest initform-and-initargs)
  `(defvar ,name (create-tls-variable ,@initform-and-initargs)))

(defmacro define-tls-parameter (name &rest initform-and-initargs)
  `(defparameter ,name (create-tls-variable ,@initform-and-initargs)))

Perhaps it is a good time to introduce a new convention for tls variable names. I think that surrounding names with the minus sign is a nice idea, because it signifies, that it is something less than a global value. For example:

DYNAMIC-VARS> (define-tls-variable -context- 
                  (progn
                    (print "Initializing context!")
                    (list :context)))
-CONTEXT-
DYNAMIC-VARS> -context-
#
DYNAMIC-VARS> (dref -context-)

"Initializing context!" 
(:CONTEXT)
DYNAMIC-VARS> (dref -context-)
(:CONTEXT)
DYNAMIC-VARS> (dset -context- :the-new-value)

:THE-NEW-VALUE
DYNAMIC-VARS> (dref -context-)
:THE-NEW-VALUE
DYNAMIC-VARS> (bt:make-thread
               (lambda ()
                 (print "Let's read it!")
                 (print (dref -context-))))
#

"Let's read it!" 
"Initializing context!" 
(:CONTEXT) 
DYNAMIC-VARS> (dref -context-)
:THE-NEW-VALUE

The implementation

You might have noticed the inconspicuous operator DYNAMIC-VARIABLE-BINDINGS that is part of the protocol. It returns an opaque object that represents values of the dynamic variable in the current context:

for STANDARD-DYNAMIC-VARIABLE it is a symbol
for SURROGATE-DYNAMIC-VARIABLE it is a thread-local list of bindings

In any case all other operators first take this object and then use it to read, write or bind the value. The gist of the tls variables implementation is to always return an object that is local to the thread. To store these objects we will use the tls-table we've defined earlier.

(defclass thread-local-variable-mixin (dynamic-variable)
  ((tls-table
    :initform (make-tls-table)
    :reader dynamic-variable-tls-table)
   (tls-initfun
    :initarg :initfun
    :initform nil
    :accessor thread-local-variable-initfun)
   (tls-initval
    :initarg :initval
    :initform +fake-unbound+
    :accessor thread-local-variable-initval)))

For the class STANDARD-THREAD-LOCAL-VARIABLE we will simply return a different symbol depending on the thread:

(defclass standard-thread-local-variable (thread-local-variable-mixin
                                         thread-local-variable
                                         standard-dynamic-variable)
  ())

(defmethod dynamic-variable-bindings ((tvar standard-thread-local-variable))
  (flet ((make-new-tls-bindings ()
           (let ((symbol (gensym))
                 (initval (thread-local-variable-initval tvar))
                 (initfun (thread-local-variable-initfun tvar)))
             (cond
               ((not (eq +fake-unbound+ initval))
                (setf (symbol-value symbol) initval))
               ((not (null initfun))
                (setf (symbol-value symbol) (funcall initfun))))
             symbol)))
    (let ((key (bt:current-thread)))
      (with-tls-table (tls-table (dynamic-variable-tls-table tvar))
        (or (gethash key tls-table)
            (setf (gethash key tls-table)
                  (make-new-tls-bindings)))))))

And for the class SURROGATE-THREAD-LOCAL-VARIABLE the only difference from the SURROGATE-DYNAMIC-VARIABLE implementation is to cons a new list as the initial value (even when it is unbound) to ensure it is not EQ to +CELL-UNBOUND+.

(defclass surrogate-thread-local-variable (thread-local-variable-mixin
                                          thread-local-variable
                                          surrogate-dynamic-variable)
  ())

(defmethod dynamic-variable-bindings ((tvar surrogate-thread-local-variable))
  (flet ((make-new-tls-bindings ()
           (let ((initval (thread-local-variable-initval tvar))
                 (initfun (thread-local-variable-initfun tvar)))
             (cond
               ((not (eq +fake-unbound+ initval))
                (list initval))
               ((not (null initfun))
                (list (funcall initfun)))
               (t
                (list +fake-unbound+))))))
    (let ((key (bt:current-thread)))
      (with-tls-table (tls-table (dynamic-variable-tls-table tvar))
        (or (gethash key tls-table)
            (setf (gethash key tls-table)
                  (make-new-tls-bindings)))))))

That's all, now we have two implementations of thread-local variables. Ramifications are similar as with "ordinary" dynamic variables - the standard implementation is not advised for SBCL, because it will crash in LDB.

Thread-local slots

First we are going to allow to defined dynamic variable types with an abbreviated names. This will enable us to specify in the slot definition that type, for example (MY-SLOT :DYNAMIC :TLS :INITFORM 34)

;;; Examples how to add shorthand type names for the dynamic slots:

(defmethod make-dynamic-variable-using-key ((key (eql :tls)) &rest initargs)
  (apply #'make-dynamic-variable-using-key
         *default-thread-local-variable-class* initargs))

(defmethod make-dynamic-variable-using-key ((key (eql :normal-tls)) &rest initargs)
  (apply #'make-dynamic-variable-using-key
         'standard-thread-local-variable initargs))

(defmethod make-dynamic-variable-using-key ((key (eql :kludge-tls)) &rest initargs)
  (apply #'make-dynamic-variable-using-key
         'surrogate-thread-local-variable initargs))

;;; For *DEFAULT-DYNAMIC-VARIABLE* specify :DYNAMIC T.

(defmethod make-dynamic-variable-using-key ((key (eql :normal-dyn)) &rest initargs)
  (apply #'make-dynamic-variable-using-key
         'standard-dynamic-variable initargs))

(defmethod make-dynamic-variable-using-key ((key (eql :kludge-dyn)) &rest initargs)
  (apply #'make-dynamic-variable-using-key
         'surrogate-dynamic-variable initargs))

In order to do that, we need to remember he value of the argument :DYNAMIC. We will read it with DYNAMIC-VARIABLE-TYPE and that value will be available in both direct and the effective slot:

;;; Slot definitions
;;; There is a considerable boilerplate involving customizing slots.
;;;
;;; - direct slot definition: local to a single defclass form
;;;
;;; - effective slot definition: combination of all direct slots with the same
;;;   name in the class and its superclasses
;;;
(defclass dynamic-direct-slot (mop:standard-direct-slot-definition)
  ((dynamic :initform nil :initarg :dynamic :reader dynamic-variable-type)))

;;; The metaobject protocol did not specify an elegant way to communicate
;;; between the direct slot definition and the effective slot definition.
;;; Luckily we have dynamic bindings! :-)
(defvar *kludge/mop-deficiency/dynamic-variable-type* nil)

;;; DYNAMIC-EFFECTIVE-SLOT is implemented to return as slot-value values of the
;;; dynamic variable that is stored with the instance.
;;;
;;; It would be nice if we could specify :ALLOCATION :DYNAMIC for the slot, but
;;; then STANDARD-INSTANCE-ACCESS would go belly up. We could make a clever
;;; workaround, but who cares?
(defclass dynamic-effective-slot (mop:standard-effective-slot-definition)
  ((dynamic :initform *kludge/mop-deficiency/dynamic-variable-type*
            :reader dynamic-variable-type)))

Moreover we specialize the function MAKE-DYNAMIC-VARIABLE-USING-KEY to the effective slot class. The initargs in this method are meant for the instance. When the dynamic variable is created, we check whether it is a thread-local variable and initialize its INITVAL and INITFUN to values derived from INITARGS, MOP:SLOT-DEFINITION-INITARGS and MOP:SLOT-DEFINITION-INITFUN:

(defmethod make-dynamic-variable-using-key
    ((key dynamic-effective-slot) &rest initargs)
  (let* ((dvar-type (dynamic-variable-type key))
         (dvar (make-dynamic-variable-using-key dvar-type)))
    (when (typep dvar 'thread-local-variable)
      (loop with slot-initargs = (mop:slot-definition-initargs key)
            for (key val) on initargs by #'cddr
            when (member key slot-initargs) do
              (setf (thread-local-variable-initval dvar) val))
      (setf (thread-local-variable-initfun dvar)
            (mop:slot-definition-initfunction key)))
    dvar))

The rest of the implementation of DYNAMIC-EFFECTIVE-SLOT is unchanged:

(defmethod mop:slot-value-using-class
    ((class standard-class)
     object
     (slotd dynamic-effective-slot))
  (dref (slot-dvar object slotd)))

(defmethod (setf mop:slot-value-using-class)
    (new-value
     (class standard-class)
     object
     (slotd dynamic-effective-slot))
  (dset (slot-dvar object slotd) new-value))

(defmethod mop:slot-boundp-using-class
  ((class standard-class)
   object
   (slotd dynamic-effective-slot))
  (dynamic-variable-bound-p (slot-dvar object slotd)))

(defmethod mop:slot-makunbound-using-class
  ((class standard-class)
   object
   (slotd dynamic-effective-slot))
  (dynamic-variable-makunbound (slot-dvar object slotd)))

The implementation of CLASS-WITH-DYNAMIC-SLOTS is also very similar. The first difference in that ALLOCATE-INSTANCE calls MAKE-DYNAMIC-VARIABLE-USING-KEY instead of MAKE-DYNAMIC-VARIABLE and supplies the effective slot definition as the key, and the instance initargs as the remaining arguments. Note that at this point initargs are already validated by MAKE-INSTANCE. The second difference is that MOP:COMPUTE-EFFECTIVE-SLOT-DEFINITION binds the flag *KLUDGE/MOP-DEFICIENCY/DYNAMIC-VARIABLE-TYPE* to DYNAMIC-VARIABLE-TYPE.

;;; This is a metaclass that allows defining dynamic slots that are bound with
;;; the operator SLOT-DLET, and, depending on the type, may have thread-local
;;; top value.
;;;
;;; The metaclass CLASS-WITH-DYNAMIC-SLOTS specifies alternative effective slot
;;; definitions for slots with an initarg :dynamic.
(defclass class-with-dynamic-slots (standard-class) ())

;;; Class with dynamic slots may be subclasses of the standard class.
(defmethod mop:validate-superclass ((class class-with-dynamic-slots)
                                    (super standard-class))
  t)

;;; When allocating the instance we initialize all slots to a fresh symbol that
;;; represents the dynamic variable.
(defmethod allocate-instance ((class class-with-dynamic-slots) &rest initargs)
  (let ((object (call-next-method)))
    (loop for slotd in (mop:class-slots class)
          when (typep slotd 'dynamic-effective-slot) do
            (setf (mop:standard-instance-access
                   object
                   (mop:slot-definition-location slotd))
                  (apply #'make-dynamic-variable-using-key slotd initargs)))
    object))

;;; To improve potential composability of CLASS-WITH-DYNAMIC-SLOTS with other
;;; metaclasses we treat specially only slots that has :DYNAMIC in initargs,
;;; otherwise we call the next method.
(defmethod mop:direct-slot-definition-class
    ((class class-with-dynamic-slots) &rest initargs)
  (loop for (key) on initargs by #'cddr
        when (eq key :dynamic)
          do (return-from mop:direct-slot-definition-class
               (find-class 'dynamic-direct-slot)))
  (call-next-method))

(defmethod mop:compute-effective-slot-definition
    ((class class-with-dynamic-slots)
     name
     direct-slotds)
  (declare (ignore name))
  (let ((latest-slotd (first direct-slotds)))
    (if (typep latest-slotd 'dynamic-direct-slot)
        (let ((*kludge/mop-deficiency/dynamic-variable-type*
                (dynamic-variable-type latest-slotd)))
          (call-next-method))
        (call-next-method))))

(defmethod mop:effective-slot-definition-class
    ((class class-with-dynamic-slots) &rest initargs)
  (declare (ignore initargs))
  (if *kludge/mop-deficiency/dynamic-variable-type*
      (find-class 'dynamic-effective-slot)
      (call-next-method)))

Finally the implementation of SLOT-DLET does not change:

;;; Accessing and binding symbols behind the slot. We don't use SLOT-VALUE,
;;; because it will return the _value_ of the dynamic variable, and not the
;;; variable itself.
(defun slot-dvar (object slotd)
  (check-type slotd dynamic-effective-slot)
  (mop:standard-instance-access
   object (mop:slot-definition-location slotd)))

(defun slot-dvar* (object slot-name)
  (let* ((class (class-of object))
         (slotd (find slot-name (mop:class-slots class)
                      :key #'mop:slot-definition-name)))
    (slot-dvar object slotd)))

(defmacro slot-dlet (bindings &body body)
  `(dlet ,(loop for ((object slot-name) val) in bindings
                collect `((slot-dvar* ,object ,slot-name) ,val))
     ,@body))

Finally we can define a class with slots that do not share the top value:

DYNAMIC-VARS> (defclass c1 ()
                  ((slot1 :initarg :slot1 :dynamic nil :accessor slot1)
                   (slot2 :initarg :slot2 :dynamic t   :accessor slot2)
                   (slot3 :initarg :slot3 :dynamic :tls :accessor slot3))
                  (:metaclass class-with-dynamic-slots))
#
DYNAMIC-VARS> (with-slots (slot1 slot2 slot3) *object*
                (setf slot1 :x slot2 :y slot3 :z)
                (list slot1 slot2 slot3))
(:X :Y :Z)
DYNAMIC-VARS> (bt:make-thread
               (lambda ()
                 (with-slots (slot1 slot2 slot3) *object*
                   (setf slot1 :i slot2 :j slot3 :k)
                   (print (list slot1 slot2 slot3)))))

#

(:I :J :K) 
DYNAMIC-VARS> (with-slots (slot1 slot2 slot3) *object*
                (list slot1 slot2 slot3))
(:I :J :Z)

What can we use it for?

Now that we know how to define thread-local variables, we are left with a question what can we use it for. Consider having a line-buffering stream. One possible implementation could be sketched as:

(defclass line-buffering-stream (fancy-stream)
  ((current-line :initform (make-adjustable-string)
                 :accessor current-line)
   (current-ink :initform +black+
                :accessor current-ink)))

(defmethod stream-write-char ((stream line-buffering-stream) char)
  (if (char= char #\newline)
      (terpri stream)
      (vector-push-extend char (current-line stream))))

(defmethod stream-terpri ((stream line-buffering-stream))
  (%put-line-on-screen (current-line stream) (current-ink stream))
  (setf (fill-pointer (current-line stream)) 0))

If this stream is shared between multiple threads, then even if individual operations and %PUT-LINE-ON-SCREEN are thread-safe , we have a problem. For example FORMAT writes are not usually atomic and individual lines are easily corrupted. If we use custom colors, these are also a subject of race conditions. The solution is as easy as making both slots thread-local. In that case the buffered line is private to each thread and it is put on the screen atomically:

(defclass line-buffering-stream (fancy-stream)
  ((current-line
    :initform (make-adjustable-string)
    :accessor current-line
    :dynamic :tls)
   (current-ink
    :initform +black+
    :accessor current-ink
    :dynamic :tls))
  (:metaclass class-with-dynamic-slots))

Technique is not limited to streams. It may benefit thread-safe drawing, request processing, resource management and more. By subclassing DYNAMIC-VARIABLE we could create also variables that are local to different objects than processes.

I hope that you've enjoyed reading this post as much as I had writing it. If you are interested in a full standalone implementation, with tests and system definitions, you may get it here. Cheers!

Dynamic Vars - The Empire Strikes Back

Daniel Kochmański — 2024-10-28

Thread Local storage exhausted
The layer of indirection
I can fix her
Let's write some tests!
Summary

Thread Local storage exhausted

In the last post I've described a technique to use dynamic variables by value instead of the name by utilizing the operator PROGV. Apparently it works fine on all Common Lisp implementations I've tried except from SBCL, where the number of thread local variables is by default limited to something below 4000. To add salt to the injury, these variables are not garbage collected.

Try the following code to crash into LDB:

(defun foo ()
  (loop for i from 0 below 4096 do
    (when (zerop (mod i 100))
      (print i))
    (progv (list (gensym)) (list 42)
      (values))))
(foo)

This renders our new technique not very practical given SBCL popularity. We need to either abandon the idea or come up with a workaround.

The layer of indirection

Luckily for us we've already introduced a layer of indirection. Operators to access dynamic variables are called DLET, DSET and DREF. This means, that it is enough to provide a kludge implementation for SBCL with minimal changes to the remaining code.

The old code works the same as previously except that instead of SYMBOL-VALUE we use the accessor DYNAMIC-VARIABLE-VALUE, and the old call to PROGV is now DYNAMIC-VARIABLE-PROGV. Moreover DYNAMIC-EFFECTIVE-SLOT used functions BOUNDP and MAKUNBOUND, so we replace these with DYNAMIC-VARIABLE-BOUND-P and DYNAMIC-VARIABLE-MAKUNBOUND. To abstract away things further we also introduce the constructor MAKE-DYNAMIC-VARIABLE

(defpackage "EU.TURTLEWARE.BLOG/DLET"
  (:local-nicknames ("MOP" #+closer-mop "C2MOP"
                           #+(and (not closer-mop) ecl) "MOP"
                           #+(and (not closer-mop) ccl) "CCL"
                           #+(and (not closer-mop) sbcl) "SB-MOP"))
  (:use "CL"))
(in-package "EU.TURTLEWARE.BLOG/DLET")

(eval-when (:compile-toplevel :execute :load-toplevel)
  (unless (member :bordeaux-threads *features*)
    (error "Please load BORDEAUX-THREADS."))
  (when (member :sbcl *features*)
    (unless (member :fake-progv-kludge *features*)
      (format t "~&;; Using FAKE-PROGV-KLUDGE for SBCL.~%")
      (push :fake-progv-kludge *features*))))

(defmacro dlet (bindings &body body)
  (flet ((pred (binding)
           (and (listp binding) (= 2 (length binding)))))
    (unless (every #'pred bindings)
      (error "DLET: bindings must be lists of two values.~%~
                Invalid bindings:~%~{ ~s~%~}" (remove-if #'pred bindings))))
  (loop for (var val) in bindings
        collect var into vars
        collect val into vals
        finally (return `(dynamic-variable-progv (list ,@vars) (list ,@vals)
                           ,@body))))

(defmacro dset (&rest pairs)
  `(setf ,@(loop for (var val) on pairs by #'cddr
                 collect `(dref ,var)
                 collect val)))

(defmacro dref (variable)
  `(dynamic-variable-value ,variable))

;;; ...

(defmethod mop:slot-boundp-using-class
    ((class standard-class)
     object
     (slotd dynamic-effective-slot))
  (dynamic-variable-bound-p (slot-dvar object slotd)))

(defmethod mop:slot-makunbound-using-class
    ((class standard-class)
     object
     (slotd dynamic-effective-slot))
  (dynamic-variable-makunbound (slot-dvar object slotd)))

With these in place we can change the portable implementation to conform.

#-fake-progv-kludge
(progn
  (defun make-dynamic-variable ()
    (gensym))

  (defun dynamic-variable-value (variable)
    (symbol-value variable))

  (defun (setf dynamic-variable-value) (value variable)
    (setf (symbol-value variable) value))

  (defun dynamic-variable-bound-p (variable)
    (boundp variable))

  (defun dynamic-variable-makunbound (variable)
    (makunbound variable))

  (defmacro dynamic-variable-progv (vars vals &body body)
    `(progv ,vars ,vals ,@body)))

I can fix her

The implementation for SBCL will mediate access to the dynamic variable value with a synchronized hash table with weak keys. The current process is the key of the hash table and the list of bindings is the value of the hash table. For compatibility between implementations the top level value of the symbol will be shared.

The variable +FAKE-UNBOUND+ is the marker that signifies, that the variable has no value. When the list of bindings is EQ to +CELL-UNBOUND+, then it means that we should use the global value. We add new bindings by pushing to it.

#+fake-progv-kludge
(progn
  (defvar +fake-unbound+ 'unbound)
  (defvar +cell-unbound+ '(no-binding))

  (defclass dynamic-variable ()
    ((tls-table
      :initform (make-hash-table :synchronized t :weakness :key)
      :reader dynamic-variable-tls-table)
     (top-value
      :initform +fake-unbound+
      :accessor dynamic-variable-top-value)))

  (defun make-dynamic-variable ()
    (make-instance 'dynamic-variable))

  (defun dynamic-variable-bindings (dvar)
    (let ((process (bt:current-thread))
          (tls-table (dynamic-variable-tls-table dvar)))
      (gethash process tls-table +cell-unbound+)))

  (defun (setf dynamic-variable-bindings) (value dvar)
    (let ((process (bt:current-thread))
          (tls-table (dynamic-variable-tls-table dvar)))
      (setf (gethash process tls-table +cell-unbound+) value))))

We define two readers for the variable value - one that simply reads the value, and the other that signals an error if the variable is unbound. Writer for its value either replaces the current binding, or if the value cell is unbound, then we modify the top-level symbol value. We use the value +FAKE-UNBOUND+ to check whether the variable is bound and to make it unbound.

#+fake-progv-kludge
(progn
  (defun %dynamic-variable-value (dvar)
    (let ((tls-binds (dynamic-variable-bindings dvar)))
      (if (eq tls-binds +cell-unbound+)
          (dynamic-variable-top-value dvar)
          (car tls-binds))))

  (defun dynamic-variable-value (dvar)
    (let ((tls-value (%dynamic-variable-value dvar)))
      (when (eq tls-value +fake-unbound+)
        (error 'unbound-variable :name "(unnamed)"))
      tls-value))

  (defun (setf dynamic-variable-value) (value dvar)
    (let ((tls-binds (dynamic-variable-bindings dvar)))
      (if (eq tls-binds +cell-unbound+)
          (setf (dynamic-variable-top-value dvar) value)
          (setf (car tls-binds) value))))

  (defun dynamic-variable-bound-p (dvar)
    (not (eq +fake-unbound+ (%dynamic-variable-value dvar))))

  (defun dynamic-variable-makunbound (dvar)
    (setf (dynamic-variable-value dvar) +fake-unbound+)))

Finally we define the operator to dynamically bind variables that behaves similar to PROGV. Note that we PUSH and POP from the thread-local hash table DYNAMIC-VARIABLE-BINDINGS, so no synchronization is necessary.

#+fake-progv-kludge
(defmacro dynamic-variable-progv (vars vals &body body)
  (let ((svars (gensym))
        (svals (gensym))
        (var (gensym))
        (val (gensym)))
    `(let ((,svars ,vars))
       (loop for ,svals = ,vals then (rest ,svals)
             for ,var in ,svars
             for ,val = (if ,svals (car ,svals) +fake-unbound+)
             do (push ,val (dynamic-variable-bindings ,var)))
       (unwind-protect (progn ,@body)
         (loop for ,var in ,svars
               do (pop (dynamic-variable-bindings ,var)))))))

Let's write some tests!

But of course, we are going to also write a test framework. It's short, I promise. As a bonus point the API is compatibile with fiveam, so it is possible to drop tests as is in the appropriate test suite.

(defvar *all-tests* '())

(defun run-tests ()
  (dolist (test (reverse *all-tests*))
    (format *debug-io* "Test ~a... " test)
    (handler-case (funcall test)
      (serious-condition (c)
        (format *debug-io* "Failed: ~a~%" c))
      (:no-error (&rest args)
        (declare (ignore args))
        (format *debug-io* "Passed.~%")))))

(defmacro test (name &body body)
  `(progn
     (pushnew ',name *all-tests*)
     (defun ,name () ,@body)))

(defmacro is (form)
  `(assert ,form))

(defmacro pass ())

(defmacro signals (condition form)
  `(is (block nil
         (handler-case ,form
           (,condition () (return t)))
         nil)))

(defmacro finishes (form)
  `(is (handler-case ,form
         (serious-condition (c)
           (declare (ignore c))
           nil)
         (:no-error (&rest args)
           (declare (ignore args))
           t))))

Now let's get to tests. First we'll test our metaclass:

(defclass dynamic-let.test-class ()
  ((slot1 :initarg :slot1 :dynamic nil :accessor slot1)
   (slot2 :initarg :slot2 :dynamic t   :accessor slot2)
   (slot3 :initarg :slot3              :accessor slot3))
  (:metaclass class-with-dynamic-slots))

(defparameter *dynamic-let.test-instance-1*
  (make-instance 'dynamic-let.test-class
                 :slot1 :a :slot2 :b :slot3 :c))

(defparameter *dynamic-let.test-instance-2*
  (make-instance 'dynamic-let.test-class
                 :slot1 :x :slot2 :y :slot3 :z))

(test dynamic-let.1
  (let ((o1 *dynamic-let.test-instance-1*)
        (o2 *dynamic-let.test-instance-2*))
    (with-slots (slot1 slot2 slot3) o1
      (is (eq :a slot1))
      (is (eq :b slot2))
      (is (eq :c slot3)))
    (with-slots (slot1 slot2 slot3) o2
      (is (eq :x slot1))
      (is (eq :y slot2))
      (is (eq :z slot3)))))

(test dynamic-let.2
  (let ((o1 *dynamic-let.test-instance-1*)
        (o2 *dynamic-let.test-instance-2*))
    (signals error (slot-dlet (((o1 'slot1) 1)) nil))
    (slot-dlet (((o1 'slot2) :k))
      (is (eq :k (slot-value o1 'slot2)))
      (is (eq :y (slot-value o2 'slot2))))))

(test dynamic-let.3
  (let ((o1 *dynamic-let.test-instance-1*)
        (exit nil)
        (fail nil))
    (flet ((make-runner (values)
             (lambda ()
               (slot-dlet (((o1 'slot2) :start))
                 (let ((value (slot2 o1)))
                   (unless (eq value :start)
                     (setf fail value)))
                 (loop until (eq exit t) do
                   (setf (slot2 o1) (elt values (random (length values))))
                   (let ((value (slot2 o1)))
                     (unless (member value values)
                       (setf fail value)
                       (setf exit t))))))))
      (let ((r1 (bt:make-thread (make-runner '(:k1 :k2))))
            (r2 (bt:make-thread (make-runner '(:k3 :k4))))
            (r3 (bt:make-thread (make-runner '(:k5 :k6)))))
        (sleep .1)
        (setf exit t)
        (map nil #'bt:join-thread (list r1 r2 r3))
        (is (eq (slot2 o1) :b))
        (is (null fail))))))

Then let's test the dynamic variable itself:

(test dynamic-let.4
  "Test basic dvar operators."
  (let ((dvar (make-dynamic-variable)))
    (is (eql 42 (dset dvar 42)))
    (is (eql 42 (dref dvar)))
    (ignore-errors
     (dlet ((dvar :x))
       (is (eql :x (dref dvar)))
       (error "foo")))
    (is (eql 42 (dref dvar)))))

(test dynamic-let.5
  "Test bound-p operator."
  (let ((dvar (make-dynamic-variable)))
    (is (not (dynamic-variable-bound-p dvar)))
    (dset dvar 15)
    (is (dynamic-variable-bound-p dvar))
    (dynamic-variable-makunbound dvar)
    (is (not (dynamic-variable-bound-p dvar)))))

(test dynamic-let.6
  "Test makunbound operator."
  (let ((dvar (make-dynamic-variable)))
    (dset dvar t)
    (is (dynamic-variable-bound-p dvar))
    (finishes (dynamic-variable-makunbound dvar))
    (is (not (dynamic-variable-bound-p dvar)))))

(test dynamic-let.7
  "Test locally bound-p operator."
  (let ((dvar (make-dynamic-variable)))
    (is (not (dynamic-variable-bound-p dvar)))
    (dlet ((dvar 15))
      (is (dynamic-variable-bound-p dvar)))
    (is (not (dynamic-variable-bound-p dvar)))))

(test dynamic-let.8
  "Test locally unbound-p operator."
  (let ((dvar (make-dynamic-variable)))
    (dset dvar t)
    (is (dynamic-variable-bound-p dvar))
    (dlet ((dvar nil))
      (is (dynamic-variable-bound-p dvar))
      (finishes (dynamic-variable-makunbound dvar))
      (is (not (dynamic-variable-bound-p dvar))))
    (is (dynamic-variable-bound-p dvar))))

(test dynamic-let.9
  "Stress test the implementation (see :FAKE-PROGV-KLUDGE)."
  (finishes                              ; at the same time
    (let ((dvars (loop repeat 4096 collect (make-dynamic-variable))))
      ;; ensure tls variable
      (loop for v in dvars do
        (dlet ((v 1))))
      (loop for i from 0 below 4096
            for r = (random 4096)
            for v1 in dvars
            for v2 = (elt dvars r) do
              (when (zerop (mod i 64))
                (pass))
              (dlet ((v1 42)
                     (v2 43))
                (values))))))

(test dynamic-let.0
  "Stress test the implementation (see :FAKE-PROGV-KLUDGE)."
  (finishes                             ; can be gc-ed
    (loop for i from 0 below 4096 do
      (when (zerop (mod i 64))
        (pass))
      (dlet (((make-dynamic-variable) 42))
        (values)))))

All that is left is to test both dynamic variable implementations:

BLOG/DLET> (lisp-implementation-type)
"ECL"
BLOG/DLET> (run-tests)
Test DYNAMIC-LET.1... Passed.
Test DYNAMIC-LET.2... Passed.
Test DYNAMIC-LET.3... Passed.
Test DYNAMIC-LET.4... Passed.
Test DYNAMIC-LET.5... Passed.
Test DYNAMIC-LET.6... Passed.
Test DYNAMIC-LET.7... Passed.
Test DYNAMIC-LET.8... Passed.
Test DYNAMIC-LET.9... Passed.
Test DYNAMIC-LET.0... Passed.
NIL

And with the kludge:

BLOG/DLET> (lisp-implementation-type)
"SBCL"
BLOG/DLET> (run-tests)
Test DYNAMIC-LET.1... Passed.
Test DYNAMIC-LET.2... Passed.
Test DYNAMIC-LET.3... Passed.
Test DYNAMIC-LET.4... Passed.
Test DYNAMIC-LET.5... Passed.
Test DYNAMIC-LET.6... Passed.
Test DYNAMIC-LET.7... Passed.
Test DYNAMIC-LET.8... Passed.
Test DYNAMIC-LET.9... Passed.
Test DYNAMIC-LET.0... Passed.
NIL

Summary

In this post we've made our implementation to work on SBCL even when there are more than a few thousand dynamic variables. We've also added a simple test suite that checks the basic behavior.

As it often happens, after achieving some goal we get greedy and achieve more. That's the case here as well. In the next (and the last) post in this series I'll explore the idea of adding truly thread-local variables without a shared global value. This will be useful for lazily creating context on threads that are outside of our control. We'll also generalize the implementation so it is possible to subclass and implement ones own flavor of a dynamic variable.

Dynamic Vars - A New Hope

Daniel Kochmański — 2024-10-22

Dynamic Bindings
The problem
The solution
Dynamic slots
The context
Summary

Dynamic Bindings

Common Lisp has an important language feature called dynamic binding. It is possible to rebind a dynamic variable somewhere on the call stack and downstream functions will see that new value, and when the stack is unwound, the old value is brought back.

While Common Lisp does not specify multi-threading, it seems to be a consensus among various implementations that dynamic bindings are thread-local, allowing for controlling the computing context in a safe way.

Before we start experiments, let's define a package to isolate our namespace:

(defpackage "EU.TURTLEWARE.BLOG/DLET"
  (:local-nicknames ("MOP" #+closer-mop "C2MOP"
                           #+(and (not closer-mop) ecl) "MOP"
                           #+(and (not closer-mop) ccl) "CCL"
                           #+(and (not closer-mop) sbcl) "SB-MOP"))
  (:use "CL"))
(in-package "EU.TURTLEWARE.BLOG/DLET")

Dynamic binding of variables is transparent to the programmer, because the operator LET is used for both lexical and dynamic bindings. For example:

(defvar *dynamic-variable* 42)

(defun test ()
  (let ((*dynamic-variable* 15)
        (lexical-variable 12))
    (lambda ()
      (print (cons *dynamic-variable* lexical-variable)))))

(funcall (test))
;;; (42 . 12)

(let ((*dynamic-variable* 'xx))
  (funcall (test)))
;;; (xx . 12)

Additionally the language specifies a special operator PROGV that gives the programmer a control over the dynamic binding mechanism, by allowing passing the dynamic variable by value instead of its name. Dynamic variables are represented by symbols:

(progv (list '*dynamic-variable*) (list 'zz)
  (funcall (test)))
;;; (zz . 12)

The problem

Nowadays it is common to encapsulate the state in the instance of a class. Sometimes that state is dynamic. It would be nice if we could use dynamic binding to control it. That said slots are not variables, and if there are many objects of the same class with different states, then using dynamic variables defined with DEFVAR is not feasible.

Consider the following classes which we want to be thread-safe:

(defgeneric call-with-ink (cont window ink))

(defclass window-1 ()
  ((ink :initform 'red :accessor ink)))

(defmethod call-with-ink (cont (win window-1) ink)
  (let ((old-ink (ink win)))
    (setf (ink win) ink)
    (unwind-protect (funcall cont)
      (setf (ink win) old-ink))))

(defclass window-2 ()
  ())

(defvar *ink* 'blue)
(defmethod ink ((window window-2)) *ink*)

(defmethod call-with-ink (cont (win window-2) ink)
  (let ((*ink* ink))
    (funcall cont)))

The first example is clearly not thread safe. If we access the WINDOW-1 instance from multiple threads, then they will overwrite a value of the slot INK.

The second example is not good either, because when we have many instances of WINDOW-2 then they share the binding. Nesting CALL-WITH-INK will overwrite the binding of another window.

The solution

The solution is to use PROGV:

(defclass window-3 ()
  ((ink :initform (gensym))))

(defmethod initialize-instance :after ((win window-3) &key)
  (setf (symbol-value (slot-value win 'ink)) 'red))

(defmethod call-with-ink (cont (win window-3) ink)
  (progv (list (slot-value win 'ink)) (list ink)
    (funcall cont)))

This way each instance has its own dynamic variable that may be rebound with a designated operator CALL-WITH-INK. It is thread-safe and private. We may add some syntactic sugar so it is more similar to let:

(defmacro dlet (bindings &body body)
  (loop for (var val) in bindings
        collect var into vars
        collect val into vals
        finally (return `(progv (list ,@vars) (list ,@vals)
                           ,@body))))

(defmacro dset (&rest pairs)
  `(setf ,@(loop for (var val) on pairs by #'cddr
                 collect `(symbol-value ,var)
                 collect val)))

(defmacro dref (variable)
  `(symbol-value ,variable))

Dynamic slots

While meta-classes are not easily composable, it is worth noting that we can mold it better into the language by specifying that slot itself has a dynamic value. This way CLOS aficionados will have a new tool in their arsenal.

The approach we'll take is that a fresh symbol is stored as the value of each instance-allocated slot, and then accessors for the slot value will use these symbols as a dynamic variable. Here are low-level accessors:

;;; Accessing and binding symbols behind the slot. We don't use SLOT-VALUE,
;;; because it will return the _value_ of the dynamic variable, and not the
;;; variable itself.
(defun slot-dvar (object slotd)
  (mop:standard-instance-access
   object (mop:slot-definition-location slotd)))

(defun slot-dvar* (object slot-name)
  (let* ((class (class-of object))
         (slotd (find slot-name (mop:class-slots class)
                      :key #'mop:slot-definition-name)))
    (slot-dvar object slotd)))

(defmacro slot-dlet (bindings &body body)
  `(dlet ,(loop for ((object slot-name) val) in bindings
                 collect `((slot-dvar* ,object ,slot-name) ,val))
     ,@body))

Now we'll define the meta-class. We need that to specialize functions responsible for processing slot definitions and the instance allocation. Notice, that we make use of a kludge to communicate between COMPUTE-EFFECTIVE-SLOT-DEFINITION and EFFECTIVE-SLOT-DEFINITION-CLASS – this is because the latter has no access to the direct slot definitions.

;;; The metaclass CLASS-WITH-DYNAMIC-SLOTS specifies alternative effective slot
;;; definitions for slots with an initarg :dynamic.
(defclass class-with-dynamic-slots (standard-class) ())

;;; Class with dynamic slots may be subclasses of the standard class.
(defmethod mop:validate-superclass ((class class-with-dynamic-slots)
                                    (super standard-class))
  t)

;;; When allocating the instance we initialize all slots to a fresh symbol that
;;; represents the dynamic variable.
(defmethod allocate-instance ((class class-with-dynamic-slots) &rest initargs)
  (declare (ignore initargs))
  (let ((object (call-next-method)))
    (loop for slotd in (mop:class-slots class)
          when (typep slotd 'dynamic-effective-slot) do
            (setf (mop:standard-instance-access
                   object
                   (mop:slot-definition-location slotd))
                  (gensym (string (mop:slot-definition-name slotd)))))
    object))

;;; To improve potential composability of CLASS-WITH-DYNAMIC-SLOTS with other
;;; metaclasses we treat specially only slots that has :DYNAMIC in initargs,
;;; otherwise we call the next method.
(defmethod mop:direct-slot-definition-class
    ((class class-with-dynamic-slots) &rest initargs)
  (loop for (key val) on initargs by #'cddr
        when (eq key :dynamic)
          do (return-from mop:direct-slot-definition-class
               (find-class 'dynamic-direct-slot)))
  (call-next-method))

;;; The metaobject protocol did not specify an elegant way to communicate
;;; between the direct slot definition and the effective slot definition.
;;; Luckily we have dynamic bindings! :-)
(defvar *kludge/mop-deficiency/dynamic-slot-p* nil)
(defmethod mop:compute-effective-slot-definition
    ((class class-with-dynamic-slots)
     name
     direct-slotds)
  (if (typep (first direct-slotds) 'dynamic-direct-slot)
      (let* ((*kludge/mop-deficiency/dynamic-slot-p* t))
        (call-next-method))
      (call-next-method)))

(defmethod mop:effective-slot-definition-class
    ((class class-with-dynamic-slots) &rest initargs)
  (declare (ignore initargs))
  (if *kludge/mop-deficiency/dynamic-slot-p*
      (find-class 'dynamic-effective-slot)
      (call-next-method)))

Finally we define a direct and an effective slot classes, and specialize slot accessors that are invoked by the instance accessors.

;;; There is a considerable boilerplate involving customizing slots.
;;;
;;; - direct slot definition: local to a single defclass form
;;;
;;; - effective slot definition: combination of all direct slots with the same
;;;   name in the class and its superclasses
;;;
(defclass dynamic-direct-slot (mop:standard-direct-slot-definition)
  ((dynamic :initform nil :initarg :dynamic :reader dynamic-slot-p)))

;;; DYNAMIC-EFFECTIVE-SLOT is implemented to return as slot-value values of the
;;; dynamic variable that is stored with the instance.
;;;
;;; It would be nice if we could specify :ALLOCATION :DYNAMIC for the slot, but
;;; then STANDARD-INSTANCE-ACCESS would go belly up. We could make a clever
;;; workaround, but who cares?
(defclass dynamic-effective-slot (mop:standard-effective-slot-definition)
  ())

(defmethod mop:slot-value-using-class
    ((class class-with-dynamic-slots)
     object
     (slotd dynamic-effective-slot))
  (dref (slot-dvar object slotd)))

(defmethod (setf mop:slot-value-using-class)
    (new-value
     (class class-with-dynamic-slots)
     object
     (slotd dynamic-effective-slot))
  (dset (slot-dvar object slotd) new-value))

(defmethod mop:slot-boundp-using-class
  ((class class-with-dynamic-slots)
   object
   (slotd dynamic-effective-slot))
  (boundp (slot-dvar object slotd)))

(defmethod mop:slot-makunbound-using-class
  ((class class-with-dynamic-slots)
   object
   (slotd dynamic-effective-slot))
  (makunbound (slot-dvar object slotd)))

With this, we can finally define a class with slots that have dynamic values. What's more, we may bind them like dynamic variables.

;;; Let there be light.
(defclass window-4 ()
  ((ink :initform 'red :dynamic t :accessor ink)
   (normal :initform 'normal :accessor normal))
  (:metaclass class-with-dynamic-slots))

(let ((object (make-instance 'window-4)))
  (slot-dlet (((object 'ink) 15))
    (print (ink object)))
  (print (ink object)))

ContextL provides a similar solution with dynamic slots, although it provides much more, like layered classes. This example is much more self-contained.

The context

Lately I'm working on the repaint queue for McCLIM. While doing so I've decided to make stream operations thread-safe, so it is possible to draw on the stream and write to it from arbitrary thread asynchronously. The access to the output record history needs to be clearly locked, so that may be solved by the mutex. Graphics state is another story, consider the following functions running from separate threads:

(defun team-red ()
  (with-drawing-options (stream :ink +dark-red+)
    (loop for i from 0 below 50000 do
      (write-string (format nil "XXX: ~5d~%" i) stream))))

(defun team-blue ()
  (with-drawing-options (stream :ink +dark-blue+)
    (loop for i from 0 below 50000 do
      (write-string (format nil "YYY: ~5d~%" i) stream))))

(defun team-pink ()
  (with-drawing-options (stream :ink +deep-pink+)
    (loop for i from 0 below 25000 do
      (case (random 2)
        (0 (draw-rectangle* stream 200 (* i 100) 250 (+ (* i 100) 50)))
        (1 (draw-circle* stream 225 (+ (* i 100) 25) 25))))))

(defun gonow (stream)
  (window-clear stream)
  (time (let ((a (clim-sys:make-process #'team-red))
              (b (clim-sys:make-process #'team-blue))
              (c (clim-sys:make-process #'team-grue)))
          (bt:join-thread a)
          (bt:join-thread b)
          (bt:join-thread c)
          (format stream "done!~%")))  )

Operations like WRITE-STRING and DRAW-RECTANGLE can be implemented by holding a lock over the shared resource without much disruption. The drawing color on the other hand is set outside of the loop, so if we had locked the graphics state with a lock, then these functions would be serialized despite being called from different processes. The solution to this problem is to make graphics context a dynamic slot that is accessed with WITH-DRAWING-OPTIONS.

Summary

I hope that I've convinced you that dynamic variables are cool (I'm sure that majority of readers here are already convinced), and that dynamic slots are even cooler :-). Watch forward to the upcoming McCLIM release!

If you like technical writeups like this, please consider supporting me on Patreon.

Writing an ad hoc GUI for Coleslaw

Daniel Kochmański — 2024-01-30

Preliminary steps
Embracing the chaos
Presentations
Managing a blog collection
Managing a blog instance
Big ball of mud
Closing thoughts

Coleslaw is a "Flexible Lisp Blogware". It is a program that I'm using to manage my blogs and allows for an offline blog compilation. The functionality of the website may be extended with plugins and the visual appearance is defined by configurable themes.

Its design is straightforward (if not a bit messy), so it is a good candidate to show how to slap a CLIM interface on top of existing software. The integration will be very shallow to not encroach into Coleslaw responsibilities, yet deep enough to provide a convenience utility over the library.

Preliminary steps

In this post we will use a few dependencies. Of course one of them is mcclim. Please make sure that you are using an up-to-date version; i.e clone it from the repository to ~/quicklisp/local-projects. There are other dependencies too. Load them all in the REPL with:

(ql:quickload '(coleslaw-cli cl-fad alexandria local-time
                mcclim clouseau hunchentoot)
              :verbose t)

The whole program described in this tutorial is defined in a single package:

(defpackage "COLESLAW-GUI"
  (:use "CLIM-LISP"))
(in-package "COLESLAW-GUI")

We are good to go now.

Embracing the chaos

The README.md in the project's repository mentions a few commands that may be invoked from the command line and from the lisp REPL. What they have in common is that they assume, that the blog resides in the current working directory. Here we are going to introduce a macro that estabilishes a necessary context:

(defmacro with-current-directory ((path value) &body body)
  `(let* ((,path (cl-fad:pathname-as-directory ,value))
          (*default-pathname-defaults* ,path))
     (ensure-directories-exist ,path)
     (uiop:chdir ,path)
     ,@body))

Moreover Coleslaw assumes that only one blog will be loaded during its lifetime and many objects are treated as singletons. We will embrace this chaos and provide a macro that estabilishes an appropriate environment for a blog. The key to each environment is its directory pathname:

;;; Allow for passing "env" here.
(defun blog-key (blog)
  (etypecase blog
    (null nil)
    (cons (coleslaw:repo-dir (first blog)))
    (coleslaw::blog (coleslaw:repo-dir blog))))

(defun blog () coleslaw:*config*)
(defun site () coleslaw::*site*)

(defun make-null-env ()
  (list nil (make-hash-table :test #'equal)))

(defun copy-blog-env ()
  (list coleslaw:*config*
        coleslaw::*site*))

(defun load-blog-env (env)
  (destructuring-bind (blog site)
      (or env (make-null-env))
    (setf coleslaw:*config* blog
          coleslaw::*site* site)
    ;; Populates *ALL-TAGS* and *ALL-MONTHS* using *SITE*.
    (coleslaw::update-content-metadata)))

(defun save-blog-env (table)
  (when table
    (setf (gethash (blog-key coleslaw:*config*) table)
          (copy-blog-env))))

(defmacro with-blog-env ((env table) &body body)
  `(let (coleslaw:*config*
         coleslaw::*site*)
     (load-blog-env ,env)
     (multiple-value-prog1 (progn ,@body)
       (save-blog-env ,table))))

Presentations

First we will define presentation types, so we can associate them with objects on the screen. The blog environment is composed of a pair:

a blog: an instance of the class coleslaw::blog
a site: a hash table that contains posts

(clim:define-presentation-type coleslaw::blog () :description "(Configuration)")

(clim:define-presentation-type blog-env () :description "(Blog)")

Presentation types are like types denoted by classes, but with a twist - they may be additionally parametrized; i.e (INTEGER 3) is a presentation type. There are also an abstract presentation types that are not tied to a single class. For example we may have presentation types "red team" and "blue team", where some arbitrary objects are presented as one or the another.

The presentation method present is used to associate the object with the presentation type and put it on the screen as the presentation. In other words the presentation is a pair (object type). The method specializes arguments:

object: most notably the object class, sometimes left unspecialized
type: obligatory specialization to the presentation type (may be abstract)
stream: typically left unspecialized, but may be utilized for serialization
view: customizes how the object is presented depending on the local context

The most primitive view is the textual view. Methods specializing to it should treat the stream as if it handles only text, so the representation should be a string. Note that presentations may be nested, like in our case:

(clim:define-presentation-method clim:present
    (self (type coleslaw::blog) stream (view clim:textual-view) &key acceptably for-context-type)
  (declare (ignore view acceptably for-context-type))
  (format stream "~a" (blog-key self)))

(clim:define-presentation-method clim:present
    (env (type blog-env) stream (view clim:textual-view) &key acceptably for-context-type)
  (declare (ignore acceptably for-context-type))
  (with-blog-env (env nil)
    (princ "[" stream)
    (clim:present (blog) 'coleslaw::blog :stream stream :view view)
    (princ "]" stream)))

Managing a blog collection

The system coleslaw-cli that is bundled with coleslaw defines commands that allow for creating a blog, adding (stub) post files to it, compiling the blog to the staging area and deploying the blog using plugins.

We are going to extend this set of operations to allow working with a collection of blogs. Since we are not barbarians, we are going to encapsulate the state in the application frame, and not in a global variable.

(clim:define-application-frame coleslaw-cli ()
  ((envs :initform (make-hash-table :test #'equal) :reader envs)))

Adding new blogs to the collection is a result of opening them or creating new ones. Both operations require for the program to operate in a target directory:

(clim:define-command (com-open-blog :name t :command-table coleslaw-cli)
    ((directory 'pathname))
  (clim:with-application-frame (frame)
    (with-current-directory (path directory)
      (with-blog-env (nil (envs frame))
        (format *query-io* "Opening a blog in ~s.~%" path)
        (coleslaw::load-config path)))))

(clim:define-command (com-make-blog :name t :command-table coleslaw-cli)
    ((directory 'pathname))
  (clim:with-application-frame (frame)
    (with-current-directory (path directory)
      (with-blog-env (nil (envs frame))
        (format *query-io* "Creating a new blog in ~s. " path)
        (coleslaw-cli:setup)
        (coleslaw::load-config path)))))

We need a command to list loaded blogs. All remaining operations will specialize to presentation types blog-env and coleslaw::blog, so we will present them with the function present:

(clim:define-command (com-list-blogs :name t :command-table coleslaw-cli)
    ()
  (clim:with-application-frame (frame)
    (dolist (env (alexandria:hash-table-values (envs frame)))
      (clim:present env 'blog-env :stream (clim:frame-query-io frame)
                                  :single-box t)
      (terpri (clim:frame-query-io frame)))))

For completness we need a command that will remove a blog from the collection.

(clim:define-command (com-close-blog :name t :command-table coleslaw-cli)
    ((self 'blog-env))
  (clim:with-application-frame (frame)
    (remhash (blog-key self) (envs frame))))

Finally there are two very important commands that compile the blog. Note that both commands will fail if there are no posts in the blog (coleslaw behavior).

(clim:define-command (com-stage-blog :name t :command-table coleslaw-cli)
    ((self 'blog-env))
  (clim:with-application-frame (frame)
    (with-current-directory (path (blog-key self))
      (with-blog-env (self (envs frame))
        (format *query-io* "Staging the blog from ~s. " path)
        (coleslaw-cli:stage)))))

(clim:define-command (com-deploy-blog :name t :command-table coleslaw-cli)
    ((self 'blog-env))
  (clim:with-application-frame (frame)
    (with-current-directory (path (blog-key self))
      (with-blog-env (self (envs frame))
        (format *query-io* "Deploying the blog from ~s. " path)
        (coleslaw-cli:deploy)))))

Additionally we define a few convenience commands:

creating test data
clearing the screen

(clim:define-command (com-spam-blogs :name t :command-table coleslaw-cli)
    ()
  (dotimes (i 8)
    (let ((d (format nil "/tmp/blogs/specimen-~2,'0d/" i)))
      (if (probe-file d)
          (com-open-blog d)
          (with-current-directory (path d)
            (com-make-blog d)
            ;; Without any content "Stage" and "Deploy" will fail.
            (coleslaw-cli:new))))))

(clim:define-command (com-clear :name t :command-table coleslaw-cli)
    ()
  (clim:with-application-frame (frame)
    (clim:window-clear (clim:frame-query-io frame))))

Now to execute a command on the blog we may type the command name and select an element from the list (with a pointer). We want also to allow the user to click on the blog with the right pointer button and select the operation without explicitly typing the command, so we define presentation to command translators:

(macrolet ((def (name command short-description long-description)
             `(clim:define-presentation-to-command-translator ,name
                  (blog-env ,command coleslaw-cli
                   :gesture nil
                   :documentation ,short-description
                   :pointer-documentation ,long-description)
                  (self)
                `(,self))))
  (def trn-close-blog  com-close-blog  "Close"  "Remove blog from collection")
  (def trn-stage-blog  com-stage-blog  "Stage"  "Compile blog to staging area")
  (def trn-deploy-blog com-deploy-blog "Deploy" "Compile blog to production"))

Moreover we'd like to be able to type the blog from the keyboard, so we define a presentation method accept that matches the blog against loaded ones.

(clim:define-presentation-method clim:accept
    ((type blog-env) stream (view clim:textual-view) &rest args)
  (declare (ignore args))
  (clim:with-application-frame (frame)
    (clim:completing-from-suggestions (stream)
      (maphash (lambda (key val)
                 (clim:suggest (namestring key) val))
               (envs frame)))))

This concludes our command line blog manager. We've mentioned the following topics:

application frame: defines the dynamic context of the application
command table: defines available commands and translators
presentation types: specify ontologies that may be shared among programs
presentation methods: specify interactions like present and accept

Managing a blog instance

Until now we've been working with the interactor and the textual view. Focusing first on presentation types and commands is good, because it captures an essence of the application interface and delays distracting stuff like visuals. Now, to make this post more appealing (less appalling?), we will extend the application with additional functionality.

The display function is responsible for presenting content on the application stream. It may be anything really, but we will defer it to a method PRESENT specialized to the frame itself. That's the purest approach. We also define a few utilities for later.

(defun display (object stream)
  (clim:present object (clim:presentation-type-of object) :stream stream))

(defun present* (object stream)
  (clim:present object (clim:presentation-type-of object) :stream stream))

(defmacro dohash (((key val) hash &optional result) &body body)
  (let ((cont (gensym)))
    `(flet ((,cont (,key ,val) ,@body))
       (declare (dynamic-extent (function ,cont)))
       (maphash (function ,cont) ,hash)
       ,result)))

(defun format-today ()
  (local-time:format-timestring nil (local-time:now)
                                :format '((:year 4) "-" (:month 2) "-" (:day 2) "-"
                                          (:hour 2) "-" (:min 2) "-" (:sec 2))))

Our application frame will feature graphics and other fluff to cater to people who are into this kind of thing. To do that we define a separate view class that extends the textual-view. While we are technically subclassing it, this is not a semantically correct description. In reality we are extending the class with non-textual capabilities. If you were looking for CLOS conceptual limits, then here you have one.

;;; KLUDGE: FANCY-VIEW extends (not specializes) the TEXTUAL-VIEW.
(defclass fancy-view (clim:textual-view) ())
(defvar +fancy-view+ (make-instance 'fancy-view))

Finally the application frame definition. It inherits from coleslaw-cli and adds a new application pane to show the frame state.

(clim:define-application-frame coleslaw-gui (coleslaw-cli)
  ((current-blog :initform nil :accessor current-blog))
  (:command-table (coleslaw-gui :inherit-from (coleslaw-cli)))
  (:reinitialize-frames t)
  (:panes (app :application :display-function 'display :default-view +fancy-view+
               :text-margins '(:left 20 :top 10))
          (int :interactor)))

Now we define new commands to load content, select a loaded blog and create a new blog. Loading the content is the operation that walks directories and adds found resources to the model.

(clim:define-command (com-update :command-table coleslaw-gui)
    ((self 'blog-env))
  (clim:with-application-frame (frame)
    (with-current-directory (path (blog-key self))
      (with-blog-env (self (envs frame))
        ;; This function removes content from *site* before adding it back.
        (coleslaw::load-content)))))

(clim:define-command (com-select :command-table coleslaw-gui)
    ((self 'blog-env))
  (clim:with-application-frame (frame)
    (setf (current-blog frame) self)
    (com-update self)))

(clim:define-command (com-create :name t :command-table coleslaw-cli)
    ((self 'blog-env)
     (type 'string :default "post")
     (name 'string :default (format-today)))
  (clim:with-application-frame (frame)
    (with-current-directory (path (blog-key self))
      (with-blog-env (self (envs frame))
        ;; This function removes content from *site* before adding it back.
        (coleslaw-cli:new type name)
        (com-update self)))))

(macrolet ((def (name command gesture short-description long-description)
             `(clim:define-presentation-to-command-translator ,name
                  (blog-env ,command coleslaw-gui
                   :gesture ,gesture
                   :documentation ,short-description
                   :pointer-documentation ,long-description)
                  (self)
                `(,self))))
  (def trn-update com-update nil     "Update"  "Update blog from disk")
  (def trn-select com-select :select "Select"  "Show blog details")
  (def trn-create com-create nil     "Create"  "Create new content"))

The implementation of the present method specializes to fancy-view. First we show the list of opened blogs (using the textual view), and then we show the selected blog. Rendering of the current blog is defered to another present method.

The current blog will show the same content as it is presented on the list above, until we define a specialized method. Note that we present it so it is not sensitive to pointer clicks. This is to avoid unnecessary noise.

(clim:define-presentation-method clim:present
    ((frame coleslaw-gui) (type coleslaw-gui) stream (view fancy-view) &rest args)
  (declare (ignore args))
  (clim:formatting-item-list (stream)
   (dohash ((dir env) (envs frame))
     (declare (ignore dir))
     (clim:formatting-cell (stream)
       (clim:with-drawing-options (stream :ink (if (eql env (current-blog frame))
                                                   clim:+dark-red+
                                                   clim:+foreground-ink+))
         (clim:present env 'blog-env :stream stream :view clim:+textual-view+ :single-box t)))))
  (terpri stream)
  (clim:present (current-blog frame) 'blog-env :stream stream :view view
                                               :sensitive nil
                                               :allow-sensitive-inferiors t))

Presenting the current blog will be implemented as follows:

Show the blog title – header text style
Show available commands – deliberely goofy icons
Show the blog content – defered to the next method

(clim:define-presentation-type coleslaw::index ()
  :description "(Index)")

(clim:define-presentation-type site ()
  :description "(Site)")

(clim:define-presentation-type post ()
  :description "(Post)")

(clim:define-presentation-type post ()
  :description "(Page)")

(defun gap-the-gap (stream command label color)
  (clim:with-output-as-presentation (stream command '(clim:command :command-table coleslaw-gui))
    (clim:with-room-for-graphics (stream :first-quadrant nil)
      (clim:draw-circle* stream 0 0 40 :ink clim:+dark-red+ :filled nil :line-thickness 20)
      (clim:surrounding-output-with-border (stream :filled t :ink color)
        (clim:draw-text* stream label 0 0 :align-x :center :align-y :center
                                          :text-size :small
                                          :text-family :fix
                                          :ink clim:+white+)))))

(clim:define-presentation-method clim:present
    ((self cons) (type blog-env) stream (view fancy-view) &rest args)
  (declare (ignore args))
  (clim:with-application-frame (frame)
    (with-blog-env (self (envs frame))
      ;; Blog title
      (clim:with-text-style (stream (clim:make-text-style :serif :bold :large))
        (format stream "~a" (coleslaw:title (blog))))
      (terpri stream)
      ;; Update the blog bleeper
      (gap-the-gap stream `(com-update ,self) "Mind the gap!" clim:+dark-blue+)
      (princ " " stream)
      (gap-the-gap stream `(com-create ,self "post" ,(format-today)) "Fill the gap!" clim:+dark-green+)
      (princ " " stream)
      (gap-the-gap stream `(com-create ,self "page" ,(format-today)) "Keep the gap!" clim:+dark-red+)
      (terpri stream)
      ;; The content
      (clim:present (site) 'site :stream stream :view view))))

(clim:define-presentation-method clim:present
    (self (type site) stream (view fancy-view) &rest args)
  (declare (ignore args))
  (clim:formatting-table (stream)
   (dohash ((key val) self)
     (clim:formatting-row (stream)
       (clim:formatting-cell (stream) (present* key stream))
       (clim:formatting-cell (stream) (present* val stream))))))

The discovered content is stored in a hash table. Keys are URL addresses and values are content objects: posts, rss feeds, tag feeds and indexes. Values are presented, so these presentations may be selected with a pointer when the input context matches. For example we may invoke the inspector or a file editor:

(clim:define-presentation-action act-open-content
    (coleslaw::content nil coleslaw-gui
     :documentation "Open file"
     :pointer-documentation "Open the content file")
    (object)
  (uiop:launch-program (format nil "xdg-open ~a" (coleslaw::content-file object))))

(clim:define-presentation-action act-kill-content
    (coleslaw::content nil coleslaw-gui
     :documentation "Kill file"
     :pointer-documentation "Kill the content file")
    (object)
  (clim:with-application-frame (frame)
    (with-current-directory (dir (blog-key (current-blog frame)))
      (uiop:launch-program (format nil "rm ~a" (coleslaw::content-file object))))
    (clim:execute-frame-command frame `(com-update ,(current-blog frame)))))

(clim:define-presentation-action act-inspect
    ((or coleslaw::blog coleslaw::content coleslaw::feed coleslaw::index) nil coleslaw-gui
     :gesture nil
     :documentation "Inspect content"
     :pointer-documentation "Inspect site content")
  (object)
  (clouseau:inspect object :new-process t))

A difference between actions and commands is that actions are not expected to change the internal model, so they don't progress the display loop. Now we may click on a post and the default program that opens the file will be launched. We may also right-click on the content value and inspect it with clouseau.

In this section I've mentioned the following topics:

the textual view may be extended with graphical capabilities (i.e colors)
display function is a function that creates presentations on the stream
presentation translators may be used to call a command from a presentation
presentation method present may be nested inside another one
presentation types are used as specializers in presentation methods
it is possible to present on the stream a command along with arguments
presentation actions, unlike commands, are executed immedietely

Big ball of mud

Previously we've extended the application by specifying a new display function. Now we will extend it further by adding a web server to preview a blog.

(clim:define-application-frame durk (coleslaw-gui)
  ((acceptor :initarg :acceptor :accessor acceptor))
  (:panes
   (app :application :display-function 'display :default-view +fancy-view+)
   (int :interactor :height 100))
  (:reinitialize-frames t)
  (:command-table (durk :inherit-from (coleslaw-gui)))
  (:default-initargs :acceptor nil))

;;; We could enable and disable commands by calilng (SETF CLIM:COMMAND-ENABLED).
(defmethod clim:command-enabled (name (frame durk))
  (case name
    (com-stop-acceptor (hunchentoot:started-p (acceptor frame)))
    (com-start-acceptor (not (hunchentoot:started-p (acceptor frame))))
    (otherwise (call-next-method))))

(defmethod clim:adopt-frame :after (fm (self durk))
  (format *debug-io* "Booting up.~%")
  (setf (acceptor self) (make-instance 'hunchentoot:easy-acceptor :port 4242))
  (setf hunchentoot:*dispatch-table*
        (list (hunchentoot:create-static-file-dispatcher-and-handler "/" "/tmp/coleslaw/index.html")
              (hunchentoot:create-folder-dispatcher-and-handler "/" "/tmp/coleslaw/"))))

(defmethod clim:disown-frame :before (fm (self durk))
  (format *debug-io* "Cleaning up.~%")
  (when (hunchentoot:started-p (acceptor self))
    (hunchentoot:stop (acceptor self))))

(define-durk-command (com-start-acceptor)
    ((self 'hunchentoot:acceptor :gesture :select))
  (format *debug-io* "Starting acceptor.~%")
  (hunchentoot:start self))

(define-durk-command (com-stop-acceptor)
    ((self 'hunchentoot:acceptor :gesture :select))
  (format *debug-io* "Stopping acceptor.~%")
  (hunchentoot:stop self))

Here's the key part: instead of defining single method for presenting the frame, we define a :before method that presents named commands and the acceptor:

(clim:define-presentation-method clim:present :before ((self durk) (type durk) stream view &rest args)
  (declare (ignore args))
  (clim:formatting-item-list (stream)
    (clim:map-over-command-table-names
     (lambda (name command)
       (declare (ignore name))
       (clim:formatting-cell (stream)
         (clim:surrounding-output-with-border (stream)
          (clim:present command 'clim:command :stream stream))))
     (clim:find-command-table 'durk)))
  (terpri stream)
  (present* (acceptor self) stream)
  (terpri stream))

(clim:define-presentation-method clim:present
    ((self hunchentoot:acceptor) (type hunchentoot:acceptor) stream view &rest args)
  (declare (ignore view args))
  (clim:with-drawing-options (stream :ink (if (hunchentoot:started-p self)
                                              clim:+dark-green+
                                              clim:+dark-red+))
    (format stream "~a~%" self)))

In this section I mentioned the following topics:

presentation methods may have auxiliary methods like :after
we may extend existing applications by tweaking presentation methods and view
it is possible to enable and disable commands depending on the frame state
the frame life cycle starts when it is adopted, and ends when it is disowned
we may mix formatting macros, drawing options and stream output freely

And voila, now we can preview the blog:

Closing thoughts

In this post we've covered many CLIM features that are useful for writing applications. Some takeaways are:

commands have a straightforward interpretation compatible with CLI
command tables encapsulate commands and may inherit from each other
frames encapsulate the dynamic context and organize windows
presentations allow for associating a presentation type with an object
presentation types may be used to specialize numerous presentation methods
views provide an easy way to customize the interface depending on context
presentation translators may be used to coerce object to the input context
presentation actions allow for triggering immediate handlers
commands may be conditionally disabled
the display function may be extended by specializing the function present

Adding an ad-hoc GUI to existing libraries amounts for not so many lines of code and is moderately easy task. You may find the source code of this tutorial here:

/static/misc/coleslaw-gui.lisp

While the tool is rather on the simplistic side, I'm already using it to preview and manage a few of my blogs. Some extensions are due, but they'd rather make the tutorial more complex - contrary to the intention of this post.

Happy hacking,
Daniel

Proxy Generic Function

Daniel Kochmański — 2023-10-03

It is often hard to refactor software implementing an independent specification. There are already clients of the API so we can't remove operators, and newly added operators must play by the specified rules. There are a few possibilities: break the user contract and make pre-existing software obsolete, or abandon some improvements. There is also an option that software is written in Common Lisp, so you can eat your cake and have it too.

CLIM has two protocols that have a big overlap: sheets and output records. Both abstractions are organized in a similar way and have equivalent operators. In this example let's consider a part of the protocol for managing hierarchies:

;; Sheet hierarchy (sub-)protocol with an example implementation.
(defclass sheet () ()) ; protocol class
(defclass example-sheet (sheet)
  ((children :initform '() :accessor sheet-children)))

(defgeneric note-sheet-adopted (sheet)
  (:method (sheet) nil))

(defgeneric note-sheet-disowned (sheet)
  (:method (sheet) nil))

(defgeneric adopt-sheet (parent child)
  (:method ((parent example-sheet) child)
    (push child (sheet-children parent))
    (note-sheet-adopted child)))

(defgeneric disown-sheet (parent child &optional errorp)
  (:method ((parent example-sheet) child &optional (errorp t))
    (and errorp (assert (member child (sheet-children parent))))
    (setf (sheet-children parent)
          (remove child (sheet-children parent)))
    (note-sheet-disowned child)))

;; Output record hierarchy (sub-)protocol with an example implementation.
(defclass output-record () ()) ; protocol class
(defclass example-record (output-record)
  ((children :initform '() :accessor output-record-children)))

(defgeneric add-output-record (child parent)
  (:method (child (parent example-record))
    (push child (output-record-children parent))))

(defgeneric delete-output-record (child parent &optional errorp)
  (:method (child (parent example-record) &optional (errorp t))
    (and errorp (assert (member child (sheet-children parent))))
    (setf (output-record-children parent)
          (remove child (output-record-children parent)))))

Both protocols are very similar and do roughly the same thing. We are tempted to flesh out a single protocol to reduce the cognitive overhead when dealing with hierarchies.

;; The mixin is not strictly necessary - output records and sheets may have
;; wildly different internal structures - this is for the sake of simplicity;
;; most notably it is _not_ a protocol class. We don't do protocol classes.
(defclass node-mixin ()
  ((scions :initform '() :accessor node-scions)))

(defgeneric note-node-parent-changed (node parent adopted-p)
  (:method (node parent adopted-p)
    (declare (ignore node parent adopted-p))
    nil))

(defgeneric insert-node (elder scion)
  (:method :after (elder scion)
    (note-node-parent-changed scion elder t))
  (:method ((elder node-mixin) scion)
    (push scion (node-scions elder))))

(defgeneric delete-node (elder scion)
  (:method :after (elder scion)
    (note-node-parent-changed scion elder nil))
  (:method ((elder node-mixin) scion)
    (setf (node-scions elder) (remove scion (node-scions elder)))))

We define a mixin class for simplicity. In principle we care only about the new protocol and different classes may have different internal representations. Now that we have a brand new unified protocol, it is time to rewrite the old code:

;; Sheet hierarchy (sub-)protocol with an example implementation.
(defclass sheet () ()) ; protocol class
(defclass example-sheet (node-mixin sheet) ())

(defgeneric note-sheet-adopted (sheet)
  (:method (sheet)
    (declare (ignore sheet))
    nil))

(defgeneric note-sheet-disowned (sheet)
  (:method (sheet)
    (declare (ignore sheet))
    nil))

(defmethod note-node-parent-changed :after ((sheet sheet) parent adopted-p)
  (declare (ignore parent))
  (if adopted-p
      (note-sheet-adopted sheet)
      (note-sheet-disowned sheet)))

(defgeneric adopt-sheet (parent child)
  (:method (parent child)
    (insert-node parent child)))

(defgeneric disown-sheet (parent child &optional errorp)
  (:method (parent child &optional (errorp t))
    (and errorp (assert (member child (node-scions parent))))
    (delete-node parent child)))

;; Output record hierarchy (sub-)protocol with an example implementation.
(defclass output-record () ()) ; protocol class
(defclass example-record (node-mixin output-record) ())

(defgeneric add-output-record (child parent)
  (:method (child parent)
    (insert-node parent child)))

(defgeneric delete-output-record (child parent &optional errorp)
  (:method (child parent &optional (errorp t))
    (and errorp (assert (member child (node-scions parent))))
    (delete-node parent child)))

Peachy! Now we can call (delete-node parent child) and this will work equally well for both sheets and output records. It is time to ship the code and boost how clever we are (and advertise the new API). After a weekend we realize that there is a problem with our solution!

Since the old API is alive and kicking, the user may still call adopt-sheet, or if they want to switch to the new api they may call insert-node. This is fine and we have rewritten all our code so that the new element will always be added. But what about user methods?

There may be a legacy code that defines its additional constraints, for example:

(defvar *temporary-freeze* nil)
(defmethod add-output-record :before (child (record output-record))
  (declare (ignore child record))
  (when *temporary-freeze*
    (error "No-can-do's-ville, baby doll!")))

When the new code calls insert-node, then this method won't be called and the constraint will fail. There is an interesting idea, that perhaps instead of trampolining from the sheet protocol to the node protocol functions we could do it the other way around: specialized node protocol methods will call the sheet protocol functions. This is futile - the problem is symmetrical. In that case if some legacy code calls adopt-sheet, then our node methods won't be called.

That's quite a pickle we are in. The main problem is that we are not in control of all definitions and the cat is out of the bag. So what about the cake? The cake is a lie of course! … I'm kidding, of course there is the cake.

When Common Lisp programmers encounter a problem that seems impossible to solve, they usually think of one of three solutions: write a macro, write a dsl compiler or use the metaobject protocol. Usually the solution is a mix of these three things. We are dealing with generic functions - the MOP it is.

The problem could be summarized as follows:

We have under our control a new function that implements the program logic
We have under our control old functions that call the new function
We have legacy methods outside of our control defined on old functions
We will have new methods outside of our control defined on the new function
Sometimes lambda lists between protocols are not compatible

We want the new function to call legacy methods when invoked, and we want to ensure that old functions always call the new function (i.e it is not possible for legacy (sheet-disown-child :around) methods to bypass delete-node).

In order to do that, we will define a new generic function class responsible for mangling arguments when the method is called with make-method-lambda, and proxying add-method to the target class. That's all. When a new legacy method is added to the generic function sheet-disown-child, then it will be hijacked and added to the generic function delete-node instead.

First some syntactic sugar. defgeneric is a good operator except that it does error when we pass options that are not specified. Moreover some compilers are tempted to macroexpand methods at compile time, so we'll expand the new macro in the dynamic environment of a definition:

(eval-when (:compile-toplevel :load-toplevel :execute)
  (defun mappend (fun &rest lists)
    (loop for results in (apply #'mapcar fun lists) append results)))

;;; syntactic sugar -- like defgeneric but accepts unknown options
(defmacro define-generic (name lambda-list &rest options)
  (let ((declarations '())
        (methods '()))
    (labels ((parse-option (option)
               (destructuring-bind (name . value) option
                 (case name
                   (cl:declare
                    (setf declarations (append declarations value))
                    nil)
                   (:method
                     (push value methods)
                     nil)
                   ((:documentation :generic-function-class :method-class)
                    `(,name (quote ,@value)))
                   ((:argument-precedence-order :method-combination)
                    `(,name (quote ,value)))
                   (otherwise
                    `(,name (quote ,value))))))
             (expand-generic (options)
               `(c2mop:ensure-generic-function
                 ',name
                 :name ',name :lambda-list ',lambda-list
                 :declarations ',declarations ,@options))
             (expand-method (method)
               `(c2mop:ensure-method (function ,name) '(lambda ,@method))))
      ;; We always expand to ENSURE-FOO because we want dynamic variables like
      ;; *INSIDE-DEFINE-PROXY-P* to be correctly bound during the creation..
      `(progn
         ,(expand-generic (mappend #'parse-option options))
         ,@(mapcar #'expand-method methods)))))

Now we will add a macro that defines a proxy generic function. We include a dynamic flag that will communicte to make-method-lambda and add-method function, that we are still in the initialization phase and methods should be added to the proxy generic function:

(defvar *inside-define-proxy-p* nil)

(defmacro define-proxy-gf (name lambda-list &rest options)
  `(let ((*inside-define-proxy-p* t))
     (define-generic ,name ,lambda-list
       (:generic-function-class proxy-generic-function)
       ,@options)))

The proxy generic function may have a different lambda list than the target. That's indeed the case with our protocol - we don't have the argument errorp in the function delete-node. We want to allow default methods in order to implement that missing behavior. We will mangle arguments according to the specified template in :mangle-args in the function mangle-args-expressoin.

(defclass proxy-generic-function (c2mop:standard-generic-function)
  ((target-gfun                       :reader target-gfun)
   (target-args :initarg :target-args :reader target-args)
   (mangle-args :initarg :mangle-args :reader mangle-args))
  (:metaclass c2mop:funcallable-standard-class)
  (:default-initargs :target-gfun (error "~s required" :target-gfun)
                     :target-args nil
                     :mangle-args nil))

(defmethod shared-initialize :after ((gf proxy-generic-function) slot-names
                                     &key (target-gfun nil target-gfun-p))
  (when target-gfun-p
    (assert (null (rest target-gfun)))
    (setf (slot-value gf 'target-gfun)
          (ensure-generic-function (first target-gfun)))))

To ensure that a proxied method can invoke call-next-method we must be able to mangle arguments both ways. The target generic functions lambda list is stated verbatim in :target-args argument, while the source generic function lambda list is read from c2mop:generic-function-lambda-list.

The function make-method-lambda is tricky to get it right, but it gives quite a bit of control over the method invocation. Default methods are added normally so we don't mangle arguments in the trampoline method, otherwise we convert the target call into the lambda list of a defined method:

;;; MAKE-METHOD-LAMBDA is expected to return a lambda expression compatible with
;;; CALL-METHOD invocations in the method combination. The first argument are
;;; the prototype generic function arguments (the function a method is initially
;;; defined for) and the reminder are all arguments passed to CALL-METHOD - in a
;;; default combination there is one such argument - next-methods. The second
;;; returned value are extra initialization arguments for the method instance.
;;; 
;;; Our goal is to construct a lambda expression that will construct a function
;;; which instead of the prototype argument list accepts the proxied function
;;; arguments and mangles them to call the defined method body. Something like:
;;;
#+ (or)
(lambda (proxy-gfun-call-args &rest call-method-args)
  (flet ((original-method (method-arg-1 method-arg-2 ...)))
    (apply #'original-method (mangle-args proxy-gfun-call-args))))

(defun mangle-args-expression (gf type args)
  (let ((lambda-list (ecase type
                       (:target (target-args gf))
                       (:source (c2mop:generic-function-lambda-list gf)))))
    `(destructuring-bind ,lambda-list ,args
       (list ,@(mangle-args gf)))))

(defun mangle-method (gf gf-args lambda-expression)
  (let ((mfun (gensym)))
    `(lambda ,(second lambda-expression)
       (flet ((call-next-method (&rest args)
                (if (null args)
                    (call-next-method)
                    ;; CALL-NEXT-METHOD is called with arguments are meant for
                    ;; the proxy function lambda list. We first need to destruct
                    ;; them and then mangle again.
                    (apply #'call-next-method 
                           ,(mangle-args-expression gf :target
                             (mangle-args-expression gf :source 'args))))))
         (flet ((,mfun ,@(rest lambda-expression)))
           (apply (function ,mfun) ,(mangle-args-expression gf :target gf-args)))))))

(defmethod c2mop:make-method-lambda
    ((gf proxy-generic-function) method lambda-expression environment)
  (declare (ignorable method lambda-expression environment))
  (if (or *inside-define-proxy-p* (null (mangle-args gf)))
      (call-next-method)
      `(lambda (proxy-args &rest call-method-args)
         (apply ,(call-next-method gf method (mangle-method gf 'proxy-args lambda-expression) environment)
                proxy-args call-method-args))))

That leaves us with the last method add-method that decides where to add the method - to the proxy function or to the target function.

(defmethod add-method ((gf proxy-generic-function) method)
  (when *inside-define-proxy-p*
    (return-from add-method (call-next-method)))
  ;; The warning will go away in the production code because we don't want to
  ;; barf at a normal client code.
  (warn "~s is deprecated, please use ~s instead."
        (c2mop:generic-function-name gf)
        (c2mop:generic-function-name (target-gfun gf)))
  (if (or (typep method 'c2mop:standard-accessor-method) (null (mangle-args gf)))
      ;; XXX readers and writers always have congruent lambda lists so this should
      ;; be fine. Besides we don't know how to construct working accessors on some
      ;; (ekhm sbcl) implementations, because they have problems with invoking
      ;; user-constructed standard accessors (with passed :SLOT-DEFINITION SLOTD).
      (add-method (target-gfun gf) method)
      (let* ((method-class (class-of method))
             (old-lambda-list (c2mop:generic-function-lambda-list gf))
             (new-lambda-list (target-args gf))
             (new-specializers (loop with spec = (c2mop:method-specializers method)
                                     for arg in new-lambda-list
                                     until (member arg '(&rest &optional &key))
                                     collect (nth (position arg old-lambda-list) spec)))
             ;; It would be nice if we could reinitialize the method.. but we can't.
             (new-method (make-instance method-class
                                        :lambda-list new-lambda-list
                                        :specializers new-specializers
                                        :qualifiers (method-qualifiers method)
                                        :function (c2mop:method-function method))))
        (add-method (target-gfun gf) new-method))))

That's it. We've defined a new generic function class that allows specifying proxies. Now we can replace definitions of generic functions that are under our control. The new (the final) implementation looks like this:

;; Sheet hierarchy (sub-)protocol with an example implementation.
(defclass sheet () ()) ; protocol class
(defclass example-sheet (node-mixin sheet) ())

(defgeneric note-sheet-adopted (sheet)
  (:method (sheet)
    (declare (ignore sheet))
    nil))

(defgeneric note-sheet-disowned (sheet)
  (:method (sheet)
    (declare (ignore sheet))
    nil))

(defmethod note-node-parent-changed :after ((sheet sheet) parent adopted-p)
  (declare (ignore parent))
  (if adopted-p
      (note-sheet-adopted sheet)
      (note-sheet-disowned sheet)))

(define-proxy-gf adopt-sheet (parent child)
  (:target-gfun insert-node)
  (:target-args parent child)
  (:mangle-args parent child)
  (:method (parent child)
    (insert-node parent child)))

(define-proxy-gf disown-sheet (parent child &optional errorp)
  (:target-gfun delete-node)
  (:target-args parent child)
  (:mangle-args parent child nil)
  (:method (parent child &optional (errorp t))
    (and errorp (assert (member child (node-scions parent))))
    (delete-node parent child)))

;; Output record hierarchy (sub-)protocol with an example implementation.
(defclass output-record () ()) ; protocol class
(defclass example-record (node-mixin output-record) ())

(define-proxy-gf add-output-record (child parent)
  (:target-gfun insert-node)
  (:target-args parent child)
  (:mangle-args child parent)
  (:method (child parent)
    (insert-node parent child)))

(define-proxy-gf delete-output-record (child parent &optional errorp)
  (:target-gfun insert-node)
  (:target-args parent child)
  (:mangle-args child parent)
  (:method (child parent &optional (errorp t))
    (and errorp (assert (member child (node-scions parent))))
    (delete-node parent child)))

And this code is defined in a separate compilation unit:

;; Legacy code in a third-party library.
(defvar *temporary-freeze* nil)
(defmethod add-output-record :before (child (record output-record))
  (declare (ignore child))
  (when *temporary-freeze*
    (error "No-can-do's-ville, baby doll!")))

;; Bleeding edge code in an experimental third-party library.
(defvar *logging* nil)
(defmethod insert-node :after ((record output-record) child)
  (declare (ignore child))
  (when *logging*
    (warn "The record ~s has been extended!" record)))

Dare we try it? You bet we do!

(defparameter *parent* (make-instance 'example-record))
(defparameter *child1* (make-instance 'example-record))
(defparameter *child2* (make-instance 'example-record))
(defparameter *child3* (make-instance 'example-record))
(defparameter *child4* (make-instance 'example-record))
(defparameter *child5* (make-instance 'example-record))

(add-output-record *child1* *parent*)
(print (node-scions *parent*))        ;1 element

(insert-node *parent* *child2*)
(print (node-scions *parent*))        ;1 element

;; So far good!
(let ((*temporary-freeze* t))
  (handler-case (adopt-sheet *parent* *child3*)
    (error     (c) (print `("Good!" ,c)))
    (:no-error (c) (print `("Bad!!" ,c))))

  (handler-case (add-output-record *child3* *parent*)
    (error     (c) (print `("Good!" ,c)))
    (:no-error (c) (print `("Bad!!" ,c))))

  (handler-case (insert-node *parent* *child3*)
    (error     (c) (print `("Good!" ,c)))
    (:no-error (c) (print `("Bad!!" ,c)))))

;; Still perfect!
(let ((*logging* t))
  (handler-case (adopt-sheet *parent* *child3*)
    (error     (c) (print `("Bad!" ,c)))
    (warning   (c) (print `("Good!",c))))

  (handler-case (add-output-record *child4* *parent*)
    (error     (c) (print `("Bad!" ,c)))
    (warning   (c) (print `("Good!",c))))

  (handler-case (insert-node *parent* *child5*)
    (error     (c) (print `("Bad!" ,c)))
    (warning   (c) (print `("Good!",c)))))

(print `("We should have 5 children -- " ,(length (node-scions *parent*))))
(print (node-scions *parent*))

This solution has one possible drawback. We add methods from the proxy generic function to the target generic function without discriminating. That means that applicable methods defined on adopt-sheet are called when add-output-record is invoked (and vice versa). Moreover methods with the same set of specializers in the target function may replace each other. On the flip side this is what we arguably want – the unified protocol exhibits full behavior of all members. We could have mitigated this problem by signaling an error for conflicting methods from different proxies, but if you think about it, a conforming program must not define methods that are not specialized on a subclass of the standard class - otherwise they risk overwriting internal methods! In other words all is good.

Edit 1 Another caveat is that methods for the proxy generic function must be defined in a different compilation unit than the function. This is because of limitations of defmethod - the macro calls make-method-lambda when it is expanding the body (at compile time), while the function definition is processed at the execution time.

That means that make-method-lambda during the first compilation will be called with a standard-generic-function prototype and the proxy won't work.

Cheers!
Daniel

P.S. if you like writing like this you may consider supporting me on Patreon.

Method Combinations

Daniel Kochmański — 2023-01-18

Introduction
Defining method combinations - the short form
Defining method combinations - the long form
1. The Hooker
2. The Memoizer
Conclusions

Update [2023-01-23]

Christophe Rhodes pointed out that "The Hooker" method combination is not conforming because there are multiple methods with the same "role" that can't be ordered and that have different qualifiers:

Note that two methods with identical specializers, but with different qualifiers, are not ordered by the algorithm described in Step 2 of the method selection and combination process described in Section 7.6.6 (Method Selection and Combination). Normally the two methods play different roles in the effective method because they have different qualifiers, and no matter how they are ordered in the result of Step 2, the effective method is the same. If the two methods play the same role and their order matters, an error is signaled. This happens as part of the qualifier pattern matching in define-method-combination.

http://www.lispworks.com/documentation/HyperSpec/Body/m_defi_4.htm

So instead of using qualifier patterns we should use qualifier predicates. They are not a subject of the above paragraph because of its last sentence (there is also an example in the spec that has multiple methods with a predicate). So instead of

(define-method-combination hooker ()
  (... (hook-before (:before*)) ...) ...)

the method combination should use:

(defun hook-before-p (method-qualifier)
  (typep method-qualifier '(cons (eql :before) (cons t null))))

(define-method-combination hooker ()
  (... (hook-before hook-before-p) ...) ...)

and other "hook" groups should also use predicates.

Another thing worth mentioning is that both ECL and SBCL addressed issues with the qualifier pattern matching and :arguments since the publication of this blog post.

Introduction

Method combinations are used to compute the effective method for a generic function. An effective method is a body of the generic function that combines a set of applicable methods computed based on the invocation arguments.

For example we may have a function responsible for reporting the object status and each method focuses on a different aspect of the object. In that case we may want to append all results into a list:

(defgeneric status (object)
  (:method-combination append))

(defclass base-car ()
  ((engine-status :initarg :engine :accessor engine-status)
   (wheels-status :initarg :wheels :accessor wheels-status)
   (fuel-level :initarg :fuel :accessor fuel-level))
  (:default-initargs :engine 'ok :wheels 'ok :fuel 'full))

(defmethod status append ((object base-car))
  (list :engine (engine-status object)
        :wheels (wheels-status object)
        :fuel (fuel-level object)))

(defclass premium-car (base-car)
  ((gps-status :initarg :gps :accessor gps-status)
   (nitro-level :initarg :nitro :accessor nitro-level))
  (:default-initargs :gps 'no-signal :nitro 'low))

(defmethod status append ((object premium-car))
  (list :gps (gps-status object)
        :nitro (nitro-level object)))

CL-USER> (status (make-instance 'premium-car))
(:GPS NO-SIGNAL :NITRO LOW :ENGINE OK :WHEELS OK :FUEL FULL)

CL-USER> (status (make-instance 'base-car))
(:ENGINE OK :WHEELS OK :FUEL FULL)

The effective method may look like this:

(append (call-method #)
        (call-method #   ))

Note that append is a function so all methods are called. It is possible to use other operators (for example a macro and) and then the invocation of particular methods may be conditional:

(and (call-method #)
     (call-method #   ))

Defining method combinations - the short form

The short form allows us to define a method combination in the spirit of the previous example:

(OPERATOR (call-method #)
          (call-method #)
          ...)

For example we may want to return as the second value the count of odd numbers:

(defun sum-and-count-odd (&rest args)
  (values (reduce #'+ args)
          (count-if #'oddp args)))

(define-method-combination sum-and-count-odd)

(defclass a () ())
(defclass b (a) ())
(defclass c (b) ())

(defgeneric num (o)
  (:method-combination sum-and-count-odd)
  (:method sum-and-count-odd ((o a)) 1)
  (:method sum-and-count-odd ((o b)) 2)
  (:method sum-and-count-odd ((o c)) 3)
  (:method :around ((o c))
    (print "haa!")
    (call-next-method)))

(num (make-instance 'b)) ;; (values 3 1)
(num (make-instance 'c)) ;; (values 6 2)

Note that the short form supports also around methods. It is also important to note that effective methods are cached, that is unless the generic function or the method combination changes, the computation of the effective method may be called only once per the set of effective methods.

Admittedly these examples are not very useful. Usually we operate on data stored in instances and this is not a good abstraction to achieve that. Method combinations are useful to control method invocations and their results. Here is another example:

(defmacro majority-vote (&rest method-calls)
  (let* ((num-methods (length method-calls))
         (tie-methods (/ num-methods 2)))
    `(prog ((yes 0) (no 0))
        ,@(loop for invocation in method-calls
                append `((if ,invocation
                             (incf yes)
                             (incf no))
                         (cond
                           ((> yes ,tie-methods)
                            (return (values t yes no)))
                           ((> no ,tie-methods)
                            (return (values nil yes no))))))
        (error "we have a tie! ~d ~d" yes no))))

(define-method-combination majority-vote)

(defclass a () ())
(defclass b (a) ())
(defclass c (b) ())
(defclass d (c) ())

(defgeneric foo (object param)
  (:method-combination majority-vote)
  (:method majority-vote ((o a) param) nil)
  (:method majority-vote ((o b) param) t)
  (:method majority-vote ((o c) param) t)
  (:method majority-vote ((o d) param) nil))

(foo (make-instance 'a) :whatever) ; (values nil 0 1)
(foo (make-instance 'b) :whatever) ; #
(foo (make-instance 'c) :whatever) ; (values t 2 0)
(foo (make-instance 'd) :whatever) ; #

Defining method combinations - the long form

The long form is much more interesting. It allows us to specify numerous qualifiers and handle methods without any qualifiers at all.

The Hooker

Here we will define a method combination that allows us to define named hooks that are invoked before or after the method. It is possible to have any number of hooks for the same set of arguments (something we can't achieve with the standard :before and :after auxiliary methods):

(defun combine-auxiliary-methods (primary around before after)
  (labels ((call-primary ()
             `(call-method ,(first primary) ,(rest primary)))
           (call-methods (methods)
             (mapcar (lambda (method)
                       `(call-method ,method))
                     methods))
           (wrap-after (the-form)
             (if after
                 `(multiple-value-prog1 ,the-form
                    ,@(call-methods after))
                 the-form))
           (wrap-before (the-form)
             (if before
                 `(progn
                    ,@(call-methods before)
                    ,the-form)
                 the-form))
           (wrap-around (the-form)
             (if around
                 `(call-method ,(first around)
                               (,@(rest around)
                                (make-method ,the-form)))
                 the-form)))
    (wrap-around (wrap-after (wrap-before (call-primary))))))

(define-method-combination hooker ()
  ((normal-before (:before))
   (normal-after  (:after)
                  :order :most-specific-last)
   (normal-around (:around))
   (hook-before   (:before *))
   (hook-after    (:after  *)
                  :order :most-specific-last)
   (hook-around   (:around *))
   (primary () :required t))
  (let ((around (append hook-around normal-around))
        (before (append hook-before normal-before))
        (after  (append normal-after hook-after)))
    (combine-auxiliary-methods primary around before after)))

With this we may define a generic function and associated methods similar to other functions with an extra feature - we may provide named :before, :after and :around methods. Named auxiliary methods take a precedence over unnamed ones. Only after that the specialization is considered. There is one caveat - PCL-derived CLOS implementations (clasp, cmucl, ecl, sbcl) currently ([2023-01-18 śro]) have a bug preventing wildcard qualifier pattern symbol * from working. So better download ccl or wait for fixes. Here's an example for using it:

;;; The protocol.
(defgeneric note-buffer-dimensions-changed (buffer w h)
  (:method (b w h)
    (declare (ignore b w h))
    nil))

(defgeneric change-dimensions (buffer w h)
  (:method-combination hooker))

;;; The implementation of unspecialized methods.
(defmethod change-dimensions :after (buffer w h)
  (note-buffer-dimensions-changed buffer w h))

;;; The stanard class.
(defclass buffer ()
  ((w :initform 0 :accessor w)
   (h :initform 0 :accessor h)))

;;; The implementation for the standard class.
(defmethod change-dimensions ((buffer buffer) w h)
  (print "... Changing the buffer size ...")
  (setf (values (w buffer) (h buffer))
        (values w h)))

(defmethod note-buffer-dimensions-changed ((buffer buffer) w h)
  (declare (ignore buffer w h))
  (print "... Resizing the viewport ..."))

;;; Some dubious-quality third-party code that doesn't want to interfere with
;;; methods defined by the implementation.
(defmethod change-dimensions :after system (buffer w h)
  (print `(log :something-changed ,buffer ,w ,h)))

(defmethod change-dimensions :after my-hook ((buffer buffer) w h)
  (print `(send-email! :me ,buffer ,w ,h)))

CL-USER> (defvar *buffer* (make-instance 'buffer))
*BUFFER*
CL-USER> (change-dimensions *buffer* 10 30)

"... Changing the buffer size ..." 
"... Resizing the viewport ..." 
(LOG :SOMETHING-CHANGED # 10 30) 
(SEND-EMAIL! :ME # 10 30) 
10
30

The Memoizer

Another example (this time it will work on all implementations) is optional memoization of the function invocation. If we define a method with the qualifier :memoize then the result will be cached depending on arguments. The method combination allows also "normal" auxiliary functions by reusing the function combine-auxiliary-methods from the previous section.

The function ensure-memoized-result accepts the following arguments:

test: compare generations
memo: a form that returns the current generation
cache-key: a list composed of a generic function and its arguments
form: a form implementing the method to be called

When the current generation is nil that means that caching is disabled and we remove the result from the cache. Otherwise we use the test to compare the generation of a cached value and the current one - if they are the same, then the cached value is returned. Otherwise it is returned.

(defparameter *memo* (make-hash-table :test #'equal))
(defun ensure-memoized-result (test memo cache-key form)
  `(let ((new-generation ,memo))
     (if (null new-generation)
         (progn
           (remhash ,cache-key *memo*)
           ,form)
         (destructuring-bind (old-generation . cached-result)
             (gethash ,cache-key *memo* '(nil))
           (apply #'values
                  (if (,test old-generation new-generation)
                      cached-result
                      (rest
                       (setf (gethash ,cache-key *memo*)
                             (list* new-generation (multiple-value-list ,form))))))))))

The method with the qualifier :memoize is used to compute the current generation key. When there is no such method then the function behaves as if the standard method combination is used. The method combination accepts a single argument test, so it is possible to define different predicates for deciding whether the cache is up-to-date or not.

(define-method-combination memoizer (test)
  ((before (:before))
   (after  (:after) :order :most-specific-last)
   (around (:around))
   (memoize (:memoize))
   (primary () :required t))
  (:arguments &whole args)
  (:generic-function function)
  (let ((form (combine-auxiliary-methods primary around before after))
        (memo `(call-method ,(first memoize) ,(rest memoize)))
        (ckey `(list* ,function ,args)))
    (if memoize
        (ensure-memoized-result test memo ckey form)
        form)))

Now let's define a function with "our" method combination. We will use a counter to verify that values are indeed cached.

(defparameter *counter* 0)

(defgeneric test-function (arg &optional opt)
  (:method-combination memoizer eql))

(defmethod test-function ((arg integer) &optional opt)
  (list* `(:counter ,(incf *counter*)) arg opt))

CL-USER> (test-function 42)
((:COUNTER 1) 42)
CL-USER> (test-function 42)
((:COUNTER 2) 42)
CL-USER> (defmethod test-function :memoize ((arg integer) &optional (cache t))
           (and cache :gen-z))
#
CL-USER> (test-function 42)
((:COUNTER 3) 42)
CL-USER> (test-function 42)
((:COUNTER 3) 42)
CL-USER> (test-function 42 nil)
((:COUNTER 4) 42)
CL-USER> (test-function 42)
((:COUNTER 3) 42)
CL-USER> (test-function 43)
((:COUNTER 5) 43)
CL-USER> (test-function 43)
((:COUNTER 5) 43)
CL-USER> (defmethod test-function :memoize ((arg (eql 43)) &optional (cache t))
           (and cache :gen-x))
#
CL-USER> (test-function 43)
((:COUNTER 6) 43)
CL-USER> (test-function 43)
((:COUNTER 6) 43)
CL-USER> (test-function 42)
((:COUNTER 3) 42)

Conclusions

Method combinations are a feature that is often overlooked but give a great deal of control over the generic function invocation. The fact that ccl is the only implementation from a few that I've tried which got method combinations "right" doesn't surprise me - I've always had an impression that it shines in many unexpected places.

Buffering Output

Daniel Kochmański — 2022-10-01

Single buffering

In graphical applications buffering of output is necessary to avoid flickering - a displeasing effect where mid-drawing artifacts are displayed on the screen. For example consider the following function:

(defun draw-scene (sheet)
  (draw-rectangle* sheet 125 125 175 175 :ink +red+)
  (draw-rectangle* sheet 125 125 175 175 :ink +blue+))

Here we draw two rectangles one on top of the other. If the red square is visible for a brief period of time before the blue one, then it is called flickering. To avoid this effect a concept of output buffering was invented - only when the output is ready for display, show it on the screen.

Double buffering

With double buffering we draw on the "back" buffer, and when done the back buffer contents are shown on the front buffer.

(defun game-loop ()
  (loop (draw-scene sheet)
        (swap-buffers sheet (buffer-1 sheet) (buffer-2 sheet))))

Triple buffering

The triple buffering is used when new scenes are produced much faster than the front buffer could be updated. We have "render", "ready" and "front" buffers. The implicit assumption is that the game loop and the display loop operate in separate threads.

(defun display-loop ()
  (loop (swap-buffers sheet (buffer-2 sheet) (buffer-3 sheet))
        (display-buffer sheet (buffer-3 sheet))))

Incremental and non-incremental rendering

If each frame is drawn from scratch (like in many games), then it doesn't matter whether the "swap" operation copies or swaps buffers. Some applications however treat the canvas incrementally. In this case losing the old content is not acceptable and we must copy data.

;;; The frame is rendered from scratch (not incremental)
(defmacro swap-buffers (sheet buffer-1 buffer-2)
  `(with-swap-lock (sheet)
     (rotatef ,buffer-1 ,buffer-2)))

;;; The frame is rendered based on the previosu content (incremental)
(defmacro copy-buffers (sheet buffer-1 buffer-2)
  `(with-swap-lock (sheet)
     (copy-array ,buffer-1 ,buffer-2)))

Copying data is more expensive than rotating buffers. That said sometimes re-rendering a frame from scratch may outweigh that cost. Incremental rendering resembles drawing on a paper - unless we clear it manually, the old content will be visible.

Mixed buffering

Sometimes we may want to draw directly on the front buffer. This is the most performant when we write each pixel exactly once (for example when we render an image). In this case we are not only expected to synchronize the front buffer with the back buffer, but also the other way around.

;;; Buffer-1 is "back", Buffer-2 is "front".

(defun activate-single-buffering ()
  ;; Update the front buffer immedietely.
  (copy-buffers sheet (buffer-1 sheet) (buffer-2 sheet)))

(defun activate-double-buffering ()
  ;; Synchronize the back buffer with the front-buffer.
  (copy-buffers sheet (buffer-2 sheet) (buffer-1 sheet)))

Otherwise, if we turn the double buffering back on, the back buffer won't contain the data that was drawn when the output was single-buffered.

Closing thoughts

There are many techniques that makes this more performant. My main goal with this post was to emphasize the difference between the incremental and non-incremental rendering that was usually ommited in materials I've found on the Internet.

Interesting reads:

TurtleWare

McCLIM and 7GUIs - Part 1: The Counter

Table of Contents

Version 1: Using Gadgets and Layouts

Version 2: Using the CLIM Command Loop

Conclusion

Common Lisp and WebAssembly

Table of Contents

Building ECL

Building WECL

Building user programs

Extending ASDF

Funding

Using Common Lisp from inside the Browser

Table of Contents

Scripting a website with Common Lisp

JS-FFI – low level interface

LIME/SLUG – interacting from Emacs

Injecting CL runtime in arbitrary websites

Current Caveats

Funding

Dynamic Vars - Return of the Jedi

Table of Contents

The protocol

Control operators

Synchronized hash tables with weakness

First-class dynamic variables

STANDARD-DYNAMIC-VARIABLE

SURROGATE-DYNAMIC-VARIABLE

Thread-local variables

The protocol

The implementation

Thread-local slots

What can we use it for?

Dynamic Vars - The Empire Strikes Back

Table of Contents

Thread Local storage exhausted

The layer of indirection

I can fix her

Let's write some tests!

Summary

Dynamic Vars - A New Hope

Table of Contents

Dynamic Bindings

The problem

The solution

Dynamic slots

The context

Summary

Writing an ad hoc GUI for Coleslaw

Table of Contents

Preliminary steps

Embracing the chaos

Presentations

Managing a blog collection

Managing a blog instance

Big ball of mud

Closing thoughts

Proxy Generic Function

Method Combinations

Table of Contents

Introduction

Defining method combinations - the short form

Defining method combinations - the long form

The Hooker

The Memoizer

Conclusions

Buffering Output

Single buffering

Double buffering

Triple buffering

Incremental and non-incremental rendering

Mixed buffering

Closing thoughts

`STANDARD-DYNAMIC-VARIABLE`

`SURROGATE-DYNAMIC-VARIABLE`