(address . guix-patches@gnu.org)(name . Andrew Whatson)(address . whatson@tailcall.au)
20230210142931.8711-1-whatson@tailcall.au
* gnu/packages/scheme.scm (scheme48-prescheme): New variable.
---
gnu/packages/scheme.scm | 132 ++++++++++++++++++++++++++++++++++++++++
1 file changed, 132 insertions(+)
Toggle diff (159 lines)
diff --git a/gnu/packages/scheme.scm b/gnu/packages/scheme.scm
index c13de9d65b..dabd41e32d 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 @@ (define-module (gnu packages scheme)
#: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 @@ (define-public scheme48
;; 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")
--
2.39.1