gauche

6 files changed, 193 insertions, 12 deletions

diff --git a/lib/mcgoron/guix/chibi.scm b/mcgoron/guix/chibi.scm
index 9419013..beb432d 100644
--- a/lib/mcgoron/guix/chibi.scm
+++ b/mcgoron/guix/chibi.scm
@@ -50,4 +50,3 @@
            (variable "CHIBI_MODULE_PATH")
            (files (list chibi-lib-dir chibi-binlib-dir)))))))
 
-
diff --git a/lib/mcgoron/guix/foment.scm b/mcgoron/guix/foment.scm
index 77cdd70..56db217 100644
--- a/lib/mcgoron/guix/foment.scm
+++ b/mcgoron/guix/foment.scm
@@ -48,7 +48,7 @@
 (define-public foment
   (package
     (name "foment")
-    (version "6089c3c")
+    (version "0.4.1-0.6089c3c")
     (source
       (origin
          (method git-fetch)
diff --git a/mcgoron/guix/gauche-build-system.scm b/mcgoron/guix/gauche-build-system.scm
new file mode 100644
index 0000000..6a4b8f5
--- /dev/null
+++ b/mcgoron/guix/gauche-build-system.scm
@@ -0,0 +1,98 @@
+#| Copyright (C) 2025 Peter McGoron
+ |
+ | This program is free software: you can redistribute it and/or modify it
+ | under the terms of the GNU General Public License as published by the
+ | Free Software Foundation, either version 3 of the License, or (at your
+ | option) any later version.
+ |
+ | This program is distributed in the hope that it will be useful, but
+ | WITHOUT ANY WARRANTY; without even the implied warranty of
+ | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+ | General Public License for more details.
+ |
+ | You should have received a copy of the GNU General Public License along
+ | with this program.  If not, see <https://www.gnu.org/licenses/>.
+ |#
+
+(define-module (mcgoron guix gauche-build-system)
+  #:use-module (guix build utils))
+
+(define-public gauche-configure
+(lambda* (#:key build target outputs
+          (configure-flags '()) out-of-source?
+          (configure-file-name "configure")
+          #:allow-other-keys)
+  ;; Copied from gnu-build-system.scm, rev. f0c0769189d11debf7b237a02695c44c9773d52a
+  ;; modified for Gauche.
+  ;; Allows for the configure file to have a different name (not tested).
+  (define (package-name)
+    (let* ((out  (assoc-ref outputs "out"))
+           (base (basename out))
+           (dash (string-rindex base #\-)))
+      ;; XXX: We'd rather use `package-name->name+version' or similar.
+      (string-drop (if dash
+                       (substring base 0 dash)
+                       base)
+                   (+ 1 (string-index base #\-)))))
+
+  (let* ((prefix     (assoc-ref outputs "out"))
+         (bindir     (assoc-ref outputs "bin"))
+         (libdir     (assoc-ref outputs "lib"))
+         (includedir (assoc-ref outputs "include"))
+         (docdir     (assoc-ref outputs "doc"))
+         (flags      `(,@(if target             ; cross building
+                             '("CC_FOR_BUILD=gcc")
+                             '())
+                       ,(string-append "--prefix=" prefix)
+                       ;; Produce multiple outputs when specific output names
+                       ;; are recognized.
+                       ,@(if bindir
+                              (list (string-append "--bindir=" bindir "/bin"))
+                              '())
+                       ,@(if libdir
+                              (cons (string-append "--libdir=" libdir "/lib")
+                                    (if includedir
+                                        '()
+                                        (list
+                                         (string-append "--includedir="
+                                                        libdir "/include"))))
+                              '())
+                       ,@(if includedir
+                             (list (string-append "--includedir="
+                                                  includedir "/include"))
+                             '())
+                       ,@(if docdir
+                             (list (string-append "--docdir=" docdir
+                                                  "/share/doc/" (package-name)))
+                             '())
+                       ,@(if build
+                             (list (string-append "--build=" build))
+                             '())
+                       ,@(if target               ; cross building
+                             (list (string-append "--host=" target))
+                             '())
+                       ,@configure-flags))
+         (abs-srcdir (getcwd))
+         (srcdir     (if out-of-source?
+                         (string-append "../" (basename abs-srcdir))
+                         ".")))
+    (format #t "source directory: ~s (relative from build: ~s)~%"
+            abs-srcdir srcdir)
+    (if out-of-source?
+        (begin
+          (mkdir "../build")
+          (chdir "../build")))
+    (format #t "build directory: ~s~%" (getcwd))
+    (format #t "configure flags: ~s~%" flags)
+
+    ;; Gauche configure scripts are written in Gauche.
+    ;;
+    ;; Call `configure' with a relative path.  Otherwise, GCC's build system
+    ;; (for instance) records absolute source file names, which typically
+    ;; contain the hash part of the `.drv' file, leading to a reference leak.
+    (apply invoke "gosh"
+           (string-append srcdir "/" configure-file-name)
+           flags))))
+
+
+
diff --git a/mcgoron/guix/gauche.scm b/mcgoron/guix/gauche.scm
new file mode 100644
index 0000000..099b6ec
--- /dev/null
+++ b/mcgoron/guix/gauche.scm
@@ -0,0 +1,52 @@
+#| Copyright (C) 2025 Peter McGoron
+ |
+ | This program is free software: you can redistribute it and/or modify it
+ | under the terms of the GNU General Public License as published by the
+ | Free Software Foundation, either version 3 of the License, or (at your
+ | option) any later version.
+ |
+ | This program is distributed in the hope that it will be useful, but
+ | WITHOUT ANY WARRANTY; without even the implied warranty of
+ | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+ | General Public License for more details.
+ |
+ | You should have received a copy of the GNU General Public License along
+ | with this program.  If not, see <https://www.gnu.org/licenses/>.
+ |#
+
+(define-module (mcgoron guix gauche)
+  #:use-module (guix packages)
+  #:use-module (gnu packages scheme)
+  #:use-module (guix gexp))
+
+(define-public gauche-abi-version
+  (let* ((version (string-split (package-version gauche) #\.))
+         (major (string->number (car version)))
+         (minor (string->number (list-ref version 1)))
+         (patch (string->number (list-ref version 2))))
+    (cond
+      ((and (= major 0) (= minor 9) (= patch 10))
+       "0.97")
+      ((and (= major 0) (= minor 9) (> patch 11))
+       "0.98")
+      (else (error 'gauche-abi-version "unknown gauche version: patch me!"
+                   major minor patch)))))
+
+(define-public gauche-lib-dir
+  (string-append "share/gauche-" gauche-abi-version "/site/lib"))
+
+;;; TODO: machine triple
+(define-public gauche-binlib-dir
+  (string-append "lib/gauche-" gauche-abi-version "/site/x86_64-unknown-linux-gnu"))
+
+(define-public gauche-with-path
+  (package
+   (inherit gauche)
+   (name "gauche-with-path")
+   (native-search-paths
+    (list (search-path-specification
+           (variable "GAUCHE_LOAD_PATH")
+           (files (list gauche-lib-dir)))
+          (search-path-specification
+           (variable "GAUCHE_DTNLOAD_PATH")
+           (files (list gauche-lib-dir)))))))
diff --git a/lib/mcgoron/guix/sagittarius.scm b/mcgoron/guix/sagittarius.scm
index 880391e..880391e 100644
--- a/lib/mcgoron/guix/sagittarius.scm
+++ b/mcgoron/guix/sagittarius.scm
diff --git a/examples-lib/mcgoron/guix/mcgoron-hello-world.scm b/mcgoron/guix/scheme-hello-world.scm
index ebefb38..1bbef44 100644
--- a/examples-lib/mcgoron/guix/mcgoron-hello-world.scm
+++ b/mcgoron/guix/scheme-hello-world.scm
@@ -14,49 +14,81 @@
  | with this program.  If not, see <https://www.gnu.org/licenses/>.
  |#
 
-(define-module (mcgoron guix mcgoron-hello-world)
+(define-module (mcgoron guix scheme-hello-world)
   #:use-module (guix packages)
+  #:use-module (guix download)
   #:use-module (guix licenses)
   #:use-module (guix gexp)
+  #:use-module (guix build-system gnu)
+  #:use-module (gnu packages tls)
   #:use-module (mcgoron guix chibi)
   #:use-module (mcgoron guix foment)
-  #:use-module (mcgoron guix sagittarius))
- 
-(define hello-world-path "./examples-src/hello-world")
+  #:use-module (mcgoron guix sagittarius)
+  #:use-module (mcgoron guix gauche))
+
+(define (hello-world-r7rs version)
+  (origin
+    (method url-fetch)
+    (uri (string-append "https://florida.moe/ftp/hello-world-r7rs/"
+                        version ".tar.gz"))
+    (sha256 (base32 "1cx9p2mz3cmn02imp137vqmq8aw3mh5s23ybprgkc8pshgmaf8jn"))))
 
 (define-public hello-world-chibi
   (package
    (name "hello-world-chibi")
-   (version "1.0")
+   (version "1.0.0")
    (synopsis "Prints hello world")
    (description "Prints hello world")
    (license asl2.0)
    (home-page "https://example.com")
-   (source (local-file hello-world-path #:recursive? #t))
+   (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")
+   (version "1.0.0")
    (synopsis "Prints hello world")
    (description "Prints hello world")
    (license asl2.0)
    (home-page "https://example.com")
-   (source (local-file hello-world-path #:recursive? #t))
+   (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")
+   (version "1.0.0")
    (synopsis "Prints hello world")
    (description "Prints hello world")
    (license asl2.0)
    (home-page "https://example.com")
-   (source (local-file hello-world-path #:recursive? #t))
+   (source (hello-world-r7rs version))
    (build-system sagittarius-build-system)
    (inputs (list foment))))
 
+(define-public hello-world-gauche
+  (package
+   (name "hello-world-gauche")
+   (version "1.0.0")
+   (synopsis "Prints hello world")
+   (description "Prints hello world")
+   (license asl2.0)
+   (home-page "https://example.com")
+   (source (origin
+             (method url-fetch)
+             (uri (string-append "https://florida.moe/ftp/hello-world-gauche/"
+                                 version ".tar.gz"))
+             (sha256 (base32 "0qfjzx5kwf8c5cjh5p72fg7wiyfn6mak4h5wsrhigzn9fzakxv3b"))))
+   (build-system gnu-build-system)
+   (arguments
+     (list
+      #:imported-modules `(,@%default-gnu-imported-modules (mcgoron guix gauche-build-system))
+      #:modules '((mcgoron guix gauche-build-system) (guix build utils) (guix build gnu-build-system))
+      #:phases
+      #~(modify-phases %standard-phases
+          (replace 'configure gauche-configure))))
+   (inputs (list gauche-with-path))
+   (native-inputs (list mbedtls gauche-with-path))))