gnu: Add Scheme48.

* gnu/packages/scheme.scm (scheme48): New variable.
* gnu/packages/patches/scheme48-tests.patch: New file.
* Makefile.am (dist_patch_DATA): Add it.

2 files changed, 60 insertions, 0 deletions

diff --git a/gnu/packages/patches/scheme48-tests.patch b/gnu/packages/patches/scheme48-tests.patch
new file mode 100644
index 00000000000..7ee228f3aaa
--- /dev/null
+++ b/gnu/packages/patches/scheme48-tests.patch
@@ -0,0 +1,36 @@
+The test case below relies on /etc/groups and similar info that is
+not available in chroot builds, so skip it.
+
+--- scheme48-1.9/scheme/posix/check.scm 2013-05-11 21:55:36.000000000 +0200
++++ scheme48-1.9/scheme/posix/check.scm 2013-05-11 21:55:40.000000000 +0200
+@@ -229,29 +229,7 @@
+ 
+ ; This assumes that we are not running as root and that / is owned by root.
+ 
+-(define-test-case users&groups posix-core-tests
+-  (let ((my-info (get-file-info directory-name))
+-       (root-info (get-file-info "/")))
+-    (let ((my-user (user-id->user-info (file-info-owner my-info)))
+-         (root-user (user-id->user-info (file-info-owner root-info)))
+-         (my-group (group-id->group-info (file-info-group my-info)))
+-         (root-group (group-id->group-info (file-info-group root-info))))
+-      (let ((my-other-user (name->user-info (user-info-name my-user)))
+-           (my-other-group (name->group-info (group-info-name my-group))))
+-       (check-that (file-info-owner my-info)
+-                   (is user-id=? (user-info-id my-user)))
+-       (check-that (file-info-owner root-info)
+-                   (opposite (is user-id=? (user-info-id my-user))))
+-       (check-that (file-info-group my-info)
+-                   (is group-id=? (group-info-id my-group)))
+-       ;; doesn't work reliably
+-       ;; (specifically, if the user is member of wheel)
+-       ;; (check (not (group-id=? (file-info-group root-info)
+-       ;;              (group-info-id my-group))))
+-       (check-that (os-string->string (user-info-name root-user))
+-                   (member-of '("root"
+-                                "bin" ; AIX
+-                                )))))))
++
+ 
+ (define-test-case environment posix-core-tests
+   (let ((env (reverse (environment-alist))))
diff --git a/gnu/packages/scheme.scm b/gnu/packages/scheme.scm
index 13f1002090b..c79a709ecd9 100644
--- a/gnu/packages/scheme.scm
+++ b/gnu/packages/scheme.scm
@@ -295,3 +295,27 @@ mashups, office (web agendas, mail clients, ...), etc.")
 produces portable and efficient C, supports almost all of the R5RS Scheme
 language standard, and includes many enhancements and extensions.")
     (license bsd-3)))
+
+(define-public scheme48
+  (package
+    (name "scheme48")
+    (version "1.9")
+    (source (origin
+             (method url-fetch)
+             (uri (string-append "http://s48.org/" version
+                                 "/scheme48-" version ".tgz"))
+             (sha256
+              (base32
+               "0rw2lz5xgld0klvld292ds6hvfk5l12vskzgf1hhwjdpa38r3fnw"))))
+    (build-system gnu-build-system)
+    (arguments `(#:patches (list (assoc-ref %build-inputs "patch/tests"))))
+    (inputs `(("patch/tests" ,(search-patch "scheme48-tests.patch"))))
+    (home-page "http://s48.org/")
+    (synopsis "Scheme implementation using a bytecode interpreter")
+    (description
+     "Scheme 48 is an implementation of Scheme based on a byte-code
+interpreter and is designed to be used as a testbed for experiments in
+implementation techniques and as an expository tool.")
+
+    ;; Most files are BSD-3; see COPYING for the few exceptions.
+    (license bsd-3)))