patch foment to respect new envar R7RS_LIBRARY_PATH

4 files changed, 184 insertions, 57 deletions

diff --git a/README.md b/README.md
index c1c85e2..ce4d9d7 100644
--- a/README.md
+++ b/README.md
@@ -3,8 +3,12 @@
 Run Scheme implementations in Guix containers/environments, and package
 libraries for them.
 
-TODO: portable r7rs and r6rs install location. Use a dummy library and
-patches.
+## Portable R6RS and R7RS Libraries
+
+Some Scheme systems packaged here will read `R7RS_LIBRARY_PATH`
+(or `R6RS_LIBRARY_PATH` for R6RS systems) to find paths for strictly
+conforming R7RS (R6RS) libraries. To copy libraries to these pathes,
+use the `portable-r7rs-build-system` (`portable-r6rs-build-system`).
 
 ## Chibi Scheme
 
@@ -17,6 +21,7 @@ patches.
 * Library: `(mcgoron guix foment)`
 * Package: `foment`
 * Pure Scheme: `foment-build-system`
+* Supports `portable-r7rs-build-system`
 
 The build script here will build [Foment](https://github.com/leftmike/foment).
 The last release of Foment was a long time ago, so the build is for the
diff --git a/mcgoron/guix/patches/foment-0.4.1-library-path.patch b/mcgoron/guix/patches/foment-0.4.1-library-path.patch
new file mode 100644
index 0000000..72312d7
--- /dev/null
+++ b/mcgoron/guix/patches/foment-0.4.1-library-path.patch
@@ -0,0 +1,126 @@
+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/scheme-hello-world.scm b/mcgoron/guix/scheme-hello-world.scm
index 1bbef44..5322db8 100644
--- a/mcgoron/guix/scheme-hello-world.scm
+++ b/mcgoron/guix/scheme-hello-world.scm
@@ -33,42 +33,6 @@
                         version ".tar.gz"))
     (sha256 (base32 "1cx9p2mz3cmn02imp137vqmq8aw3mh5s23ybprgkc8pshgmaf8jn"))))
 
-(define-public hello-world-chibi
-  (package
-   (name "hello-world-chibi")
-   (version "1.0.0")
-   (synopsis "Prints hello world")
-   (description "Prints hello world")
-   (license asl2.0)
-   (home-page "https://example.com")
-   (source (hello-world-r7rs version))
-   (build-system chibi-scheme-build-system)
-   (inputs (list chibi-scheme-with-path))))
-
-(define-public hello-world-foment
-  (package
-   (name "hello-world-foment")
-   (version "1.0.0")
-   (synopsis "Prints hello world")
-   (description "Prints hello world")
-   (license asl2.0)
-   (home-page "https://example.com")
-   (source (hello-world-r7rs version))
-   (build-system foment-build-system)
-   (inputs (list foment))))
-
-(define-public hello-world-sagittarius
-  (package
-   (name "hello-world-sagittarius")
-   (version "1.0.0")
-   (synopsis "Prints hello world")
-   (description "Prints hello world")
-   (license asl2.0)
-   (home-page "https://example.com")
-   (source (hello-world-r7rs version))
-   (build-system sagittarius-build-system)
-   (inputs (list foment))))
-
 (define-public hello-world-gauche
   (package
    (name "hello-world-gauche")
diff --git a/mcgoron/guix/foment.scm b/mcgoron/guix/scheme-packages.scm
index 56db217..bbec95b 100644
--- a/mcgoron/guix/foment.scm
+++ b/mcgoron/guix/scheme-packages.scm
@@ -14,10 +14,12 @@
  | with this program.  If not, see <https://www.gnu.org/licenses/>.
  |#
 
-(define-module (mcgoron guix foment)
+(define-module (mcgoron guix scheme-packages)
   #:use-module (guix packages)
+  #:use-module (gnu packages)
   #:use-module (guix licenses)
   #:use-module (guix git-download)
+  #:use-module (guix download)
   #:use-module (gnu packages version-control)
   #:use-module (gnu packages bash)
   #:use-module (guix build-system gnu)
@@ -25,41 +27,71 @@
   #:use-module (guix build-system copy)
   #:use-module (guix gexp))
 
-(define-public foment-build-system
+(define-public r7rs-lib-dir "share/scheme/r7rs")
+(define-public r6rs-lib-dir "share/scheme/r6rs")
+
+(define-public (default-copying-build-system name desc dir)
   (let ((lower* (build-system-lower copy-build-system)))
-    (build-system
-     (name 'foment-scheme)
-     (description "Build system for copying Scheme libraries to Foment module directory")
-     (lower
-      (lambda args
-        (apply lower*
-               (if (memq #:install-plan args)
-                   args
-                   (append
-                    args
-                    (list
-                     #:install-plan
-                     `'(("." ,(string-append foment-lib-dir
-                                             "/"))))))))))))
+      (build-system
+       (name name)
+       (description desc)
+       (lower
+        (lambda args
+          (apply lower*
+                 (if (memq #:install-plan args)
+                     args
+                     (append
+                      args
+                      (list
+                       #:install-plan
+                       `'(("." ,(string-append dir "/"))))))))))))
 
+(define-public portable-r7rs-build-system
+  (default-copying-build-system 'r7rs
+                                "Copy Scheme libraries into R7RS directory"
+                                r7rs-lib-dir))
+
+(define-public hello-world-r7rs
+  (package
+    (name "hello-world-r7rs")
+    (version "1.0.0")
+    (synopsis "Prints hello world")
+    (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"))))))
 
 (define-public foment-lib-dir "share/foment")
+(define-public foment-build-system
+  (default-copying-build-system 'foment-scheme
+                                "Copy Scheme libraries into Foment Scheme directory"
+                                foment-lib-dir))
 
 (define-public foment
   (package
     (name "foment")
-    (version "0.4.1-0.6089c3c")
+    (version "0.4.1-1.6089c3c")
     (source
       (origin
          (method git-fetch)
          (uri (git-reference (url "https://github.com/leftmike/foment")
                              (commit "6089c3c9e762875f619ef382d27943819bbe002b")))
-         (sha256 (base32 "1a6q8qfd6ggc6fl9lf1d8m20q8k498jrswc4qcn3bb7rkq4w258a"))))
+         (sha256 (base32 "1a6q8qfd6ggc6fl9lf1d8m20q8k498jrswc4qcn3bb7rkq4w258a"))
+         (patches (search-patches "mcgoron/guix/patches/foment-0.4.1-library-path.patch"))))
     (build-system gnu-build-system)
     (native-search-paths (list
                           (search-path-specification
                            (variable "FOMENT_LIBPATH")
-                           (files (list foment-lib-dir)))))
+                           (files (list foment-lib-dir)))
+                          (search-path-specification
+                           (variable "R7RS_LIBRARY_PATH")
+                           (files (list r7rs-lib-dir)))))
+    
     (arguments 
       (list
        #:phases