| 17 | | ;;; store-transient-init-functions |
|---|
| 18 | | ;;; |
|---|
| 19 | | ;;; Allows for registering transient init functions that |
|---|
| 20 | | ;;; will be called after each restore of m2-store |
|---|
| 21 | | |
|---|
| 22 | | (defvar *store-transient-init-functions* nil) |
|---|
| 23 | | (defvar *store-transient-init-constraints* nil) |
|---|
| 24 | | |
|---|
| 25 | | (defun register-store-transient-init-function (init-function &rest dependencies) |
|---|
| 26 | | "Register INIT-FUNCTION (a function-name) to be called after |
|---|
| 27 | | each restore of m2-store. Optionally, names of other |
|---|
| 28 | | init-functions can be specified as DEPENDENCIES. The specified |
|---|
| 29 | | INIT-FUNCTION will only be called after all of its DEPENDENCIES |
|---|
| 30 | | have been called." |
|---|
| 31 | | (labels ((ignorant-tie-breaker (choices reverse-partial-solution) |
|---|
| 32 | | (declare (ignore reverse-partial-solution)) |
|---|
| 33 | | ;; we dont care about making any particular choice here - |
|---|
| 34 | | ;; this would be different for computing the class |
|---|
| 35 | | ;; precedence list, for which the topological-sort used here |
|---|
| 36 | | ;; was originally intended |
|---|
| 37 | | (first choices)) |
|---|
| 38 | | (build-constraints () |
|---|
| 39 | | (loop for dependency in dependencies |
|---|
| 40 | | collect (cons dependency init-function)))) |
|---|
| 41 | | (check-type init-function symbol) |
|---|
| 42 | | (dolist (dependency dependencies) |
|---|
| 43 | | (check-type dependency symbol)) |
|---|
| 44 | | (let (new-store-transient-init-functions |
|---|
| 45 | | new-store-transient-init-constraints) |
|---|
| 46 | | (let ((constraints (build-constraints)) |
|---|
| 47 | | ;; dont know yet whether we have a circular dependency - so |
|---|
| 48 | | ;; we want to be able to abort without changes |
|---|
| 49 | | (*store-transient-init-functions* *store-transient-init-functions*) |
|---|
| 50 | | (*store-transient-init-constraints* *store-transient-init-constraints*)) |
|---|
| 51 | | (pushnew init-function *store-transient-init-functions*) |
|---|
| 52 | | (dolist (dependency dependencies) |
|---|
| 53 | | (pushnew dependency *store-transient-init-functions*)) |
|---|
| 54 | | (dolist (constraint constraints) |
|---|
| 55 | | (pushnew constraint *store-transient-init-constraints* :test #'equal)) |
|---|
| 56 | | (setq new-store-transient-init-functions |
|---|
| 57 | | (topological-sort *store-transient-init-functions* |
|---|
| 58 | | *store-transient-init-constraints* |
|---|
| 59 | | #'ignorant-tie-breaker) |
|---|
| 60 | | new-store-transient-init-constraints |
|---|
| 61 | | *store-transient-init-constraints*)) |
|---|
| 62 | | (setq *store-transient-init-functions* |
|---|
| 63 | | new-store-transient-init-functions |
|---|
| 64 | | *store-transient-init-constraints* |
|---|
| 65 | | new-store-transient-init-constraints)))) |
|---|
| 66 | | |
|---|
| 67 | | (defun invoke-store-transient-init-functions () |
|---|
| 68 | | (dolist (function-name *store-transient-init-functions*) |
|---|
| 69 | | (with-simple-restart (skip-init-function "Skip transient-init-function ~A" |
|---|
| 70 | | function-name) |
|---|
| 71 | | (funcall function-name)))) |
|---|
