From 4ca491255e1a8bbe18be092b213940e4fed00a5c Mon Sep 17 00:00:00 2001
From: Mark Wooding <mdw@distorted.org.uk>
Date: Mon, 17 Jun 2024 11:55:46 +0100
Subject: [PATCH] runlisp-base.conf: Etch SBCL's idea of where its `home' is.

Older SBCL versions end up believing that their `home' directory is
wherever the image was loaded from, but this is wrong for our dumped
images.

The directory is set by the C runtime code and (rather unpleasantly)
passed through the `SBCL_HOME' environment variable to Lisp, which
retrieves it via the `sb-impl::sbcl-homedir-pathname' function.

On the affected older SBCL versions, when we're dumping an image,
replace `sb-impl::sbcl-homedir-pathname' with a version which just
parrots the pre-dumped value.

Mention in `README.org' that it doesn't describe the actual SBCL
configuration any more.  (Sadness.)
---
 README.org        |  4 +++-
 runlisp-base.conf | 14 ++++++++++++++
 tests.at          | 11 +++++++++++
 3 files changed, 28 insertions(+), 1 deletion(-)

diff --git a/README.org b/README.org
index fd8c9e4..29fb37d 100644
--- a/README.org
+++ b/README.org
@@ -328,7 +328,9 @@ Lisp.  (SBCL's command-line interface is well thought-out, so this is an
 ideal opportunity to explain how ~runlisp~ configuration works, without
 getting bogged down in the details of fighting less amenable Lisps.)
 
-The provided ~0base.conf~ file defines SBCL as follows.
+The provided ~0base.conf~ file used to define SBCL as follows.  (The
+real version now contains a kludge for old versions, which needn't
+concern us here.)
 
 : [sbcl]
 : 
diff --git a/runlisp-base.conf b/runlisp-base.conf
index dc1ecef..7634e42 100644
--- a/runlisp-base.conf
+++ b/runlisp-base.conf
@@ -148,6 +148,19 @@ image-path = ${@image-dir}/${image-file}
 command = ${@ENV:SBCL?sbcl}
 image-file = ${@name}+asdf.core
 
+;; Older versions of SBCL forget their home directory when an image is
+;; dumped, so we must help this one to remember.
+etch-sbcl-home =
+	(let* ((#100=#:sfs (find-symbol "*STATIC-FOREIGN-SYMBOLS*" "SB-IMPL"))
+	       (#101=#:shp (find-symbol "SBCL-HOMEDIR-PATHNAME" "SB-IMPL")))
+	  (unless (or (not #100#) (not #101#)
+		      (gethash "sbcl_home" (symbol-value #100#)))
+	    (#+sb-package-locks without-package-locks
+	     #-sb-package-locks progn
+	      (setf (symbol-function #101#)
+		    (let ((#102=#:etched-sbcl-home (funcall #101#)))
+		      (lambda () #102#))))))
+
 run-script =
 	${command} --noinform
 		$?@image{--core "${image-path}" --eval "${image-restore}" |
@@ -157,6 +170,7 @@ run-script =
 dump-image =
 	${command} --noinform --no-userinit --no-sysinit --disable-debugger
 		--eval "${dump-image-prelude}"
+		--eval "${etch-sbcl-home}"
 		--eval "(sb-ext:save-lisp-and-die \"${@image-new|q}\")"
 
 ;;;--------------------------------------------------------------------------
diff --git a/tests.at b/tests.at
index b7991db..c765753 100644
--- a/tests.at
+++ b/tests.at
@@ -341,4 +341,15 @@ done
 
 AT_CLEANUP
 
+###--------------------------------------------------------------------------
+### Implementation-specific tests.
+
+AT_SETUP([specific sbcl])
+AT_KEYWORDS([specific sbcl])
+PREPARE_LISP_TEST([sbcl])
+
+AT_CHECK([RUNLISP_PATH -e"(require 'sb-bsd-sockets)"])
+
+AT_CLEANUP
+
 ###----- That's all, folks --------------------------------------------------
-- 
2.11.0