srfi-1, fixed, for r6rs and r7rs

1 files changed, 58 insertions, 0 deletions

diff --git a/mcgoron/guix/srfi-util.scm b/mcgoron/guix/srfi-util.scm
new file mode 100644
index 0000000..cc54fa3
--- /dev/null
+++ b/mcgoron/guix/srfi-util.scm
@@ -0,0 +1,58 @@
+#| 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 srfi-util)
+  #:use-module (rnrs))
+
+(define-public (splice-files output version name exports imports . filenames)
+  (with-output-to-file output
+    (lambda ()
+      (case version
+        ((6)
+         (display "(library ")
+         (write name)
+         (newline)
+         (write (cons 'export exports))
+         (newline)
+         (write (cons 'import imports))
+         (newline))
+        ((7)
+         (display "(define-library ")
+         (write name)
+         (newline)
+         (write (cons 'import imports))
+         (newline)
+         (write (cons 'export exports))
+         (newline)
+         (display "(begin\n"))
+        (else (error "unknown version" version)))
+      (for-each (lambda (filename)
+                  (cond
+                    ((string? filename)
+                     (do ((file (open-input-file filename))
+                          (s "" (get-line file)))
+                         ((eof-object? s))
+                       (display s) (newline)))
+                    ((pair? filename)
+                     (write filename)
+                     (newline))
+                    (else (error "invalid file" filename))))
+                filenames)
+      (case version
+        ((6) (display ")\n"))
+        ((7) (display "))\n"))
+        (else (error "unknown version" version))))))
+