gnu: Add scheme48-prescheme.

* gnu/packages/scheme.scm (scheme48-prescheme): New variable.

Signed-off-by: Ludovic Courtès <ludo@gnu.org>

1 files changed, 132 insertions, 0 deletions

diff --git a/gnu/packages/scheme.scm b/gnu/packages/scheme.scm
index d2f369282a..ddf77c53c6 100644
--- a/gnu/packages/scheme.scm
+++ b/gnu/packages/scheme.scm
@@ -20,6 +20,7 @@
 ;;; Copyright © 2022 Morgan Smith <Morgan.J.Smith@outlook.com>
 ;;; Copyright © 2022 jgart <jgart@dismail.de>
 ;;; Copyright © 2022 Robby Zambito <contact@robbyzambito.me>
+;;; Copyright © 2023 Andrew Whatson <whatson@tailcall.au>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -41,6 +42,7 @@
   #:use-module ((guix licenses)
                 #:select (gpl2+ lgpl2.0+ lgpl2.1 lgpl2.1+ lgpl3+ asl2.0 bsd-3
                           cc-by-sa4.0 non-copyleft expat public-domain))
+  #:use-module (guix gexp)
   #:use-module (guix packages)
   #:use-module (guix download)
   #:use-module (guix git-download)
@@ -409,6 +411,136 @@ implementation techniques and as an expository tool.")
     ;; Most files are BSD-3; see COPYING for the few exceptions.
     (license bsd-3)))
 
+(define-public scheme48-prescheme
+  (package
+    (inherit scheme48)
+    (name "scheme48-prescheme")
+    (arguments
+     (list
+      #:tests? #f ; tests only cover scheme48
+      #:modules '((guix build gnu-build-system)
+                  (guix build utils)
+                  (ice-9 popen)
+                  (srfi srfi-1))
+      #:phases
+      #~(modify-phases %standard-phases
+          (add-after 'configure 'patch-prescheme-version
+            (lambda _
+              ;; Ensure the Pre-Scheme version matches the package version
+              (call-with-output-file "ps-compiler/minor-version-number"
+                (lambda (port)
+                  (let* ((version #$(package-version this-package))
+                         (vparts (string-split version #\.))
+                         (vminor (string-join (drop vparts 1) ".")))
+                    (write vminor port))))))
+          (add-after 'configure 'patch-prescheme-headers
+            (lambda _
+              ;; Rename "io.h" to play nicely with others
+              (copy-file "c/io.h" "c/prescheme-io.h")
+              (substitute* "c/prescheme.h"
+                (("^#include \"io\\.h\"")
+                 "#include \"prescheme-io.h\""))))
+          (add-after 'configure 'generate-pkg-config
+            (lambda _
+              ;; Generate a pkg-config file
+              (call-with-output-file "prescheme.pc"
+                (lambda (port)
+                  (let ((s48-version #$(package-version scheme48))
+                        (version #$(package-version this-package)))
+                    (format port (string-join
+                                  '("prefix=~a"
+                                    "exec_prefix=${prefix}"
+                                    "libdir=${prefix}/lib/scheme48-~a"
+                                    "includedir=${prefix}/include"
+                                    ""
+                                    "Name: Pre-Scheme (Scheme 48)"
+                                    "Description: Pre-Scheme C runtime"
+                                    "Version: ~a"
+                                    "Libs: -L${libdir} -lprescheme"
+                                    "Cflags: -I${includedir}")
+                                  "\n" 'suffix)
+                            #$output s48-version version))))))
+          (add-after 'configure 'generate-prescheme-wrapper
+            (lambda _
+              ;; Generate a wrapper to load and run ps-compiler.image
+              (call-with-output-file "prescheme"
+                (lambda (port)
+                  (let ((s48-version #$(package-version scheme48)))
+                    (format port (string-join
+                                  '("#!/bin/sh"
+                                    "scheme48=~a/lib/scheme48-~a/scheme48vm"
+                                    "prescheme=~a/lib/scheme48-~a/prescheme.image"
+                                    "exec ${scheme48} -i ${prescheme} \"$@\"")
+                                  "\n" 'suffix)
+                            #$scheme48 s48-version #$output s48-version))))
+              (chmod "prescheme" #o755)))
+          (replace 'build
+            (lambda _
+              ;; Build a minimal static library for linking Pre-Scheme code
+              (let ((lib "c/libprescheme.a")
+                    (objs '("c/unix/io.o"
+                            "c/unix/misc.o")))
+                (apply invoke "make" objs)
+                (apply invoke "ar" "rcs" lib objs))
+              ;; Dump a Scheme 48 image with both the Pre-Scheme compatibility
+              ;; library and compiler pre-loaded, courtesy of Taylor Campbell's
+              ;; Pre-Scheme Manual:
+              ;; https://groups.scheme.org/prescheme/1.3/#Invoking-the-Pre_002dScheme-compiler
+              (with-directory-excursion "ps-compiler"
+                (let ((version #$(package-version this-package))
+                      (port (open-pipe* OPEN_WRITE "scheme48")))
+                  (format port (string-join
+                                '(",batch"
+                                  ",config ,load ../scheme/prescheme/interface.scm"
+                                  ",config ,load ../scheme/prescheme/package-defs.scm"
+                                  ",exec ,load load-ps-compiler.scm"
+                                  ",in prescheme-compiler prescheme-compiler"
+                                  ",user (define prescheme-compiler ##)"
+                                  ",dump ../prescheme.image \"(Pre-Scheme ~a)\""
+                                  ",exit")
+                                "\n" 'suffix)
+                          version)
+                  (close-pipe port)))))
+          (replace 'install
+            (lambda _
+              (let* ((s48-version #$(package-version scheme48))
+                     (bin-dir     (string-append #$output "/bin"))
+                     (lib-dir     (string-append #$output "/lib/scheme48-" s48-version))
+                     (pkgconf-dir (string-append #$output "/lib/pkgconfig"))
+                     (share-dir   (string-append #$output "/share/scheme48-" s48-version))
+                     (include-dir (string-append #$output "/include")))
+                ;; Install Pre-Scheme compiler image
+                (install-file "prescheme" bin-dir)
+                (install-file "prescheme.image" lib-dir)
+                ;; Install Pre-Scheme config, headers, and lib
+                (install-file "prescheme.pc" pkgconf-dir)
+                (install-file "c/prescheme.h" include-dir)
+                (install-file "c/prescheme-io.h" include-dir)
+                (install-file "c/libprescheme.a" lib-dir)
+                ;; Install Pre-Scheme sources
+                (copy-recursively "scheme/prescheme"
+                                  (string-append share-dir "/prescheme"))
+                (copy-recursively "ps-compiler"
+                                  (string-append share-dir "/ps-compiler"))
+                ;; Remove files specific to building the Scheme 48 VM
+                (for-each (lambda (file)
+                            (delete-file (string-append share-dir "/" file)))
+                          '("ps-compiler/compile-bibop-gc-32.scm"
+                            "ps-compiler/compile-bibop-gc-64.scm"
+                            "ps-compiler/compile-gc.scm"
+                            "ps-compiler/compile-twospace-gc-32.scm"
+                            "ps-compiler/compile-twospace-gc-64.scm"
+                            "ps-compiler/compile-vm-no-gc-32.scm"
+                            "ps-compiler/compile-vm-no-gc-64.scm"))))))))
+    (propagated-inputs (list scheme48))
+    (home-page "http://s48.org/")
+    (synopsis "Pre-Scheme compiler from Scheme 48")
+    (description
+     "Pre-Scheme is a statically compilable dialect of Scheme, used to implement the
+Scheme 48 virtual machine.  Scheme 48 ships with a Pre-Scheme to C compiler written
+in Scheme, and a runtime library which allows Pre-Scheme code to run as Scheme.")
+    (license bsd-3)))
+
 (define-public gambit-c
   (package
     (name "gambit-c")