working path append wrapper, add r6rs

5 files changed, 142 insertions, 237 deletions

diff --git a/mcgoron/guix/patches/COPYING b/mcgoron/guix/patches/COPYING
deleted file mode 100644
index e389742..0000000
--- a/mcgoron/guix/patches/COPYING
+++ /dev/null
@@ -1,15 +0,0 @@
-The source code to all patches is licensed under the zero-clause BSD license:
-
-Copyright © 2025 Peter McGoron
-
-Permission to use, copy, modify, and/or distribute this software for
-any purpose with or without fee is hereby granted.
-
-THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
-WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
-MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
-ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
-WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
-ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
-OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
-
diff --git a/mcgoron/guix/patches/chibi-scheme-0.11-library-path.patch b/mcgoron/guix/patches/chibi-scheme-0.11-library-path.patch
deleted file mode 100644
index 309681b..0000000
--- a/mcgoron/guix/patches/chibi-scheme-0.11-library-path.patch
+++ /dev/null
@@ -1,21 +0,0 @@
-diff --git a/eval.c b/eval.c
-index 8a7f0de2..41239fa4 100644
---- a/eval.c
-+++ b/eval.c
-@@ -509,9 +509,16 @@ void sexp_init_eval_context_globals (sexp ctx) {
-   sexp_init_eval_context_bytecodes(ctx);
- #endif
-   sexp_global(ctx, SEXP_G_MODULE_PATH) = SEXP_NULL;
-+
-+
-+  user_path = getenv("R7RS_LIBRARY_PATH");
-+  if (user_path)
-+    sexp_add_path(ctx, user_path);
-+
-   user_path = getenv(SEXP_MODULE_PATH_VAR);
-   if (!user_path) user_path = sexp_default_user_module_path;
-   sexp_add_path(ctx, user_path);
-+
-   no_sys_path = getenv(SEXP_NO_SYSTEM_PATH_VAR);
-   if (!no_sys_path || strcmp(no_sys_path, "0")==0)
-     sexp_add_path(ctx, sexp_default_module_path);
diff --git a/mcgoron/guix/patches/foment-0.4.1-library-path.patch b/mcgoron/guix/patches/foment-0.4.1-library-path.patch
deleted file mode 100644
index 72312d7..0000000
--- a/mcgoron/guix/patches/foment-0.4.1-library-path.patch
+++ /dev/null
@@ -1,126 +0,0 @@
-diff --git a/src/foment.cpp b/src/foment.cpp
-index bafb058..7535a03 100644
---- a/src/foment.cpp
-+++ b/src/foment.cpp
-@@ -1402,6 +1402,57 @@ FObjectType ObjectTypes[] =
-     {FreeTag, "free", 0, 0}
- };
- 
-+void PrependPath(const char *EnvarName)
-+{
-+    FObject lp = Assoc(MakeStringC(EnvarName), EnvironmentVariables);
-+    if (PairP(lp))
-+    {
-+        FAssert(StringP(First(lp)));
-+
-+        lp = Rest(lp);
-+
-+        ulong_t strt = 0;
-+        ulong_t idx = 0;
-+        FObject InsertionPoint = LibraryPath;
-+        while (InsertionPoint != EmptyListObject &&
-+               Rest(InsertionPoint) != EmptyListObject) {
-+            InsertionPoint = Rest(InsertionPoint);
-+        }
-+
-+        while (idx < StringLength(lp))
-+        {
-+            if (AsString(lp)->String[idx] == PathSep)
-+            {
-+                if (idx > strt) {
-+                    FObject str = MakeString(AsString(lp)->String + strt, idx - strt);
-+                    if (InsertionPoint == EmptyListObject) {
-+                        InsertionPoint = List(str);
-+                    } else {
-+                        SetRest(InsertionPoint, List(str));
-+                        InsertionPoint = Rest(InsertionPoint);
-+                    }
-+                }
-+
-+                idx += 1;
-+                strt = idx;
-+            }
-+
-+            idx += 1;
-+        }
-+
-+        if (idx > strt) {
-+            FObject str = MakeString(AsString(lp)->String + strt, idx - strt);
-+
-+            if (InsertionPoint == EmptyListObject) {
-+                InsertionPoint = List(str);
-+            } else {
-+                SetRest(InsertionPoint, List(str));
-+                InsertionPoint = Rest(InsertionPoint);
-+            }
-+        }
-+    }
-+}
-+
- long_t SetupFoment(FThreadState * ts)
- {
- #ifdef FOMENT_WINDOWS
-@@ -1548,35 +1599,6 @@ long_t SetupFoment(FThreadState * ts)
- 
-     GetEnvironmentVariables();
- 
--    FObject lp = Assoc(MakeStringC("FOMENT_LIBPATH"), EnvironmentVariables);
--    if (PairP(lp))
--    {
--        FAssert(StringP(First(lp)));
--
--        lp = Rest(lp);
--
--        ulong_t strt = 0;
--        ulong_t idx = 0;
--        while (idx < StringLength(lp))
--        {
--            if (AsString(lp)->String[idx] == PathSep)
--            {
--                if (idx > strt)
--                    LibraryPath = MakePair(
--                            MakeString(AsString(lp)->String + strt, idx - strt), LibraryPath);
--
--                idx += 1;
--                strt = idx;
--            }
--
--            idx += 1;
--        }
--
--        if (idx > strt)
--            LibraryPath = MakePair(
--                    MakeString(AsString(lp)->String + strt, idx - strt), LibraryPath);
--    }
--
-     LibraryExtensions = List(MakeStringC("sld"), MakeStringC("scm"));
- 
-     if (CheckHeapFlag)
-diff --git a/src/foment.hpp b/src/foment.hpp
-index 745d5e4..22df578 100644
---- a/src/foment.hpp
-+++ b/src/foment.hpp
-@@ -1904,4 +1904,8 @@ inline long_t PathChP(FCh ch)
- }
- #endif // FOMENT_WINDOWS
- 
-+// Misc
-+
-+void PrependPath(const char *EnvarName);
-+
- #endif // __FOMENT_HPP__
-diff --git a/src/main.cpp b/src/main.cpp
-index f333d47..da6ebd5 100644
---- a/src/main.cpp
-+++ b/src/main.cpp
-@@ -873,7 +873,10 @@ int main(int argc, FChS * argv[])
-             AddToLibraryPath(argv[pdx]);
-         else if (RunMode == InteractiveMode)
-             LibraryPath = ReverseListModify(MakePair(MakeStringC("."), LibraryPath));
-+
-         LibraryPathOptions();
-+	PrependPath("FOMENT_LIBPATH");
-+	PrependPath("R7RS_LIBRARY_PATH");
- 
-         if (ShowVersion != 0)
-         {
diff --git a/mcgoron/guix/patches/sagittarius-scheme-0.9.13-library-path.patch b/mcgoron/guix/patches/sagittarius-scheme-0.9.13-library-path.patch
deleted file mode 100644
index b47d17e..0000000
--- a/mcgoron/guix/patches/sagittarius-scheme-0.9.13-library-path.patch
+++ /dev/null
@@ -1,23 +0,0 @@
-diff --git a/src/os/posix/system.c b/src/os/posix/system.c
-index 474891c5..9bb991ce 100644
---- a/src/os/posix/system.c
-+++ b/src/os/posix/system.c
-@@ -131,12 +131,17 @@ SgObject Sg_GetLastErrorMessage()
- 
- SgObject Sg_GetDefaultLoadPath()
- {
--  SgObject env = Sg_Getenv(UC("SAGITTARIUS_LOADPATH"));
-+  SgObject env = Sg_Getenv(UC("R7RS_LIBRARY_PATH"));
-   SgObject h = SG_NIL, t = SG_NIL;
-   if (!SG_FALSEP(env) && SG_STRING_SIZE(env) != 0) {
-     SG_APPEND(h, t, Sg_StringSplitChar(SG_STRING(env), ':'));
-   }
- 
-+  env = Sg_Getenv(UC("SAGITTARIUS_LOADPATH"));
-+  if (!SG_FALSEP(env) && SG_STRING_SIZE(env) != 0) {
-+    SG_APPEND(h, t, Sg_StringSplitChar(SG_STRING(env), ':'));
-+  }
-+
-   SG_APPEND1(h, t, Sg_SitelibPath());
-   SG_APPEND1(h, t, SG_MAKE_STRING(SAGITTARIUS_SHARE_SITE_LIB_PATH));
-   SG_APPEND1(h, t, SG_MAKE_STRING(SAGITTARIUS_SHARE_LIB_PATH));
diff --git a/mcgoron/guix/scheme-packages.scm b/mcgoron/guix/scheme-packages.scm
index 701294f..4959a34 100644
--- a/mcgoron/guix/scheme-packages.scm
+++ b/mcgoron/guix/scheme-packages.scm
@@ -63,6 +63,11 @@
                                 "Copy Scheme libraries into R7RS directory"
                                 r7rs-lib-dir))
 
+(define-public portable-r6rs-build-system
+  (default-copying-build-system 'r6rs
+                                "Copy Scheme libraries into R6RS directory"
+                                r6rs-lib-dir))
+
 (define-public hello-world-r7rs
   (package
     (name "hello-world-r7rs")
@@ -71,27 +76,89 @@
     (description "A test library for packages that respect R7RS_LIBRARY_PATH")
     (license public-domain)
     (home-page "https://example.com")
-    (build-system portable-r7rs-build-system)
-    (source
-      (origin
-        (method url-fetch)
-        (uri "https://florida.moe/ftp/hello-world-r7rs/1.0.0.tar.gz")
-        (sha256 (base32 "1cx9p2mz3cmn02imp137vqmq8aw3mh5s23ybprgkc8pshgmaf8jn"))))))
+    (build-system trivial-build-system)
+    (source #f)
+    (arguments
+      `(#:modules ((guix build utils))
+        #:builder
+        (begin
+          (use-modules (guix build utils))
+          (let ((dir (string-append (assoc-ref %outputs "out") "/" ,r7rs-lib-dir)))
+            (mkdir-p dir)
+            (with-output-to-file (string-append dir "/hello-world.sld")
+              (lambda () (write '(define-library (hello-world)
+                                   (import (scheme base) (scheme write))
+                                   (export hello-world)
+                                   (begin (define (hello-world)
+                                            (display "hello, world")
+                                            (newline)))))))))))))
+
+(define-public hello-world-r6rs
+  (package
+    (name "hello-world-r6rs")
+    (version "1.0.0")
+    (synopsis "Prints hello world")
+    (description "A test library for packages that respect R6RS_LIBRARY_PATH")
+    (license public-domain)
+    (home-page "https://example.com")
+    (build-system trivial-build-system)
+    (source #f)
+    (arguments
+      `(#:modules ((guix build utils))
+        #:builder
+        (begin
+          (use-modules (guix build utils))
+          (let ((dir (string-append (assoc-ref %outputs "out") "/" ,r7rs-lib-dir)))
+            (mkdir-p dir)
+            (with-output-to-file (string-append dir "/hello-world.sls")
+              (lambda () (write '(library (hello-world)
+                                   (export hello-world)
+                                   (import (rnrs (6)))
+                                   (define (hello-world)
+                                     (display "hello, world")
+                                     (newline))))))))))))
+
 (define-public r7rs-search-path-specification 
   (search-path-specification
     (variable "R7RS_LIBRARY_PATH")
     (files (list r7rs-lib-dir))))
 
-(define* (package/path imported-package
-                       package-name
-                       synopsis
-                       description
-                       binary-name
-                       target-binary-name
-                       impl-envar
-                       guix-impl-envar
-                       portable-envar
-                       #:optional (set-environment-beforehand ""))
+(define-public r6rs-search-path-specification 
+  (search-path-specification
+    (variable "R6RS_LIBRARY_PATH")
+    (files (list r6rs-lib-dir))))
+
+(define (append-to name . variables)
+  (define the-variables
+    (let loop ((variables variables)
+               (string ""))
+      (if (null? variables)
+          string
+          (loop (cdr variables)
+                (string-append string "\"$" (car variables) "\" ")))))
+  (format #f
+          "for s in ~a ; do
+             if [ -n \"$s\" ]; then
+               if [ -n \"$~a\" ]; then
+                 export ~a+=\":\"
+               fi
+               export ~a+=\"$s\"
+             fi
+           done" the-variables name name name))
+
+(define (splicing-path-component name)
+  (format #f "${~a:+${~a}:}" name name))
+
+(define (package/path imported-package
+                      package-name
+                      synopsis
+                      description
+                      binary-name
+                      target-binary-name
+                      guix-impl-envar
+                      extra-path-specifications
+                      libdir
+                      generator-script)
 (package
   (name (string-append package-name "-with-path"))
   (synopsis synopsis)
@@ -117,30 +184,14 @@
           (mkdir-p (dirname script))
           (with-output-to-file script
             (lambda ()
-              (format #t
-"#!~a
-
-if [ -z \"$~a\" ] && [ -z \"$~a\" ]; then
-    exec -a $0 \"~a\" \"$@\"
-else
-    ~a
-    ~a=\"${~a:+${~a}:}${~a:+${~a}:}${~a:+${~a}:}\" exec -a $0 \"~a\" \"$@\"
-fi"
-               sh
-               ,guix-impl-envar ,portable-envar
-               impl
-               ,set-environment-beforehand
-               ,impl-envar ,impl-envar ,impl-envar 
-               ,guix-impl-envar ,guix-impl-envar
-               ,portable-envar ,portable-envar
-               impl)))
+              (,generator-script sh impl)))
           (chmod script #o755)))))
   (inputs (list imported-package bash-minimal))
   (native-inputs (list imported-package bash-minimal))
-  (native-search-paths (list (search-path-specification
+  (native-search-paths (cons (search-path-specification
                                (variable guix-impl-envar)
-                               (files (list foment-lib-dir)))
-                             r7rs-search-path-specification))))
+                               (files (list libdir)))
+                             extra-path-specifications))))
 
 ;;;;;;;;;;;;;;
 ;;;; Foment
@@ -161,8 +212,7 @@ fi"
          (method git-fetch)
          (uri (git-reference (url "https://github.com/leftmike/foment")
                              (commit "6089c3c9e762875f619ef382d27943819bbe002b")))
-         (sha256 (base32 "1a6q8qfd6ggc6fl9lf1d8m20q8k498jrswc4qcn3bb7rkq4w258a"))
-         #;(patches (search-patches "mcgoron/guix/patches/foment-0.4.1-library-path.patch"))))
+         (sha256 (base32 "1a6q8qfd6ggc6fl9lf1d8m20q8k498jrswc4qcn3bb7rkq4w258a"))))
     (build-system gnu-build-system)
     (arguments 
       (list
@@ -215,9 +265,18 @@ fi"
                 "Wrapper for Foment Scheme that adds Guix-managed paths to Foment search path"
                 "/bin/foment"
                 "/bin/foment"
-                "FOMENT_LIBPATH"
                 "GUIX_FOMENT_PATH"
-                "R7RS_LIBRARY_PATH"))
+                (list r7rs-search-path-specification)
+                foment-lib-dir
+                `(lambda (sh impl)
+                   (format #t
+                    "#!~a
+
+                     ~a
+                     exec -a $0 \"~a\" \"$@\""
+                    sh
+                    ,(append-to "FOMENT_LIBPATH" "GUIX_FOMENT_PATH" "R7RS_LIBRARY_PATH")
+                    impl))))
 
 ;;;;;;;;;;;;;;;;;;;
 ;;;; Chibi
@@ -231,17 +290,30 @@ fi"
                                 "Copy Scheme libraries into Chibi Scheme directory"
                                 foment-lib-dir))
 
-#;(define-public chibi-scheme-with-path
-  (package
-   (name "chibi-scheme-with-path")
-   (home-page "https://github.com/ashinn/chibi-scheme")
-   (version "0.11")
-   (source #f)
-   (native-search-paths
-    (list (search-path-specification
-           (variable "GUIX_CHIBI_PATH")
-           (files (list chibi-lib-dir chibi-binlib-dir)))
-          r7rs-search-path-specification))))
+(define-public chibi-scheme-with-path
+  (package/path
+   chibi-scheme
+   "chibi-scheme"
+   "Chibi Scheme with Guix paths"
+   "Wrapper for Chibi Scheme that adds Guix-managed paths to search path"
+   "/bin/chibi-scheme"
+   "/bin/chibi-scheme"
+   "GUIX_CHIBI_PATH"
+   (list r7rs-search-path-specification)
+   chibi-lib-dir
+   `(lambda (sh impl)
+      (format #t
+       "#!~a
+
+        ~a
+        if [ -z \"$CHIBI_MODULE_PATH\" ]; then
+            export CHIBI_MODULE_PATH=\".:./lib\"
+        fi
+
+        exec -a $0 \"~a\" \"$@\""
+       sh 
+       ,(append-to "CHIBI_MODULE_PATH" "GUIX_CHIBI_PATH" "R7RS_LIBRARY_PATH")
+       impl))))
 
 ;;;;;;;;;;;;;;;;
 ;;;; Sagittarius
@@ -262,7 +334,6 @@ fi"
       (origin
          (method url-fetch)
          (uri "https://github.com/ktakashi/sagittarius-scheme/releases/download/v0.9.13/sagittarius-0.9.13.tar.gz")
-         (patches (search-patches "mcgoron/guix/patches/sagittarius-scheme-0.9.13-library-path.patch"))
          (sha256 (base32 "0wspsv7mr1lchv0lfc50s750a358534pgri1c2fqlws31hci5y4c"))))
     (build-system cmake-build-system)
     (arguments '(#:phases (modify-phases %standard-phases
@@ -274,3 +345,22 @@ fi"
     (license bsd-2)
     (description "Sagittarius Scheme is a R6RS/R7RS Scheme implementation with a lot of practical libraries, especially cryptographic libraries.")))
 
+(define-public sagittarius-scheme-with-path
+  (package/path sagittarius-scheme
+                "sagittarius-scheme"
+                "Sagittarius Scheme with Guix paths"
+                "Wrapper for Sagittarius Scheme that adds Guix-managed paths"
+                "/bin/sagittarius"
+                "/bin/sagittarius"
+                "GUIX_SAGITTARIUS_PATH"
+                (list r6rs-search-path-specification r7rs-search-path-specification)
+                foment-lib-dir
+                `(lambda (sh impl)
+                   (format #t
+                    "#!~a
+
+                     ~a
+                     exec -a $0 \"~a\" \"$@\""
+                    sh
+                    ,(append-to "SAGITTARIUS_LOADPATH" "GUIX_SAGITTARIUS_PATH" "R6RS_LIBRARY_PATH" "R7RS_LIBRARY_PATH")
+                    impl))))