gnu/packages/chez.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2016 Federico Beffa <beffa@fbengineering.ch>
   3 ;;;
   4 ;;; This file is part of GNU Guix.
   5 ;;;
   6 ;;; GNU Guix is free software; you can redistribute it and/or modify it
   7 ;;; under the terms of the GNU General Public License as published by
   8 ;;; the Free Software Foundation; either version 3 of the License, or (at
   9 ;;; your option) any later version.
  10 ;;;
  11 ;;; GNU Guix is distributed in the hope that it will be useful, but
  12 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  13 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14 ;;; GNU General Public License for more details.
  15 ;;;
  16 ;;; You should have received a copy of the GNU General Public License
  17 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
  18
  19 (define-module (gnu packages chez)
  20   #:use-module (gnu packages)
  21   #:use-module ((guix licenses)
  22                 #:select (gpl2+ lgpl2.0+ lgpl2.1+ asl2.0 bsd-3 expat))
  23   #:use-module (guix packages)
  24   #:use-module (guix download)
  25   #:use-module (guix utils)
  26   #:use-module (guix build-system gnu)
  27   #:use-module (gnu packages compression)
  28   #:use-module (gnu packages ncurses)
  29   #:use-module (gnu packages ghostscript)
  30   #:use-module (gnu packages netpbm)
  31   #:use-module (gnu packages tex)
  32   #:use-module (gnu packages compression)
  33   #:use-module (gnu packages image)
  34   #:use-module (gnu packages xorg)
  35   #:use-module (ice-9 match))
  36
  37 (define nanopass
  38   (let ((version "1.9"))
  39     (origin
  40       (method url-fetch)
  41       (uri (string-append
  42             "https://github.com/nanopass/nanopass-framework-scheme/archive"
  43             "/v" version ".tar.gz"))
  44       (sha256 (base32 "11pwyy4jiwhcl2am3a4ciczacjbjkyvdizqzdglb3l1hj2gj6nv2"))
  45       (file-name (string-append "nanopass-" version ".tar.gz")))))
  46
  47 (define stex
  48   (let ((version "1.2.1"))
  49     (origin
  50       (method url-fetch)
  51       (uri (string-append
  52             "https://github.com/dybvig/stex/archive"
  53             "/v" version ".tar.gz"))
  54       (sha256 (base32 "03pl3f668h24dn51vccr1sj5lsba9zq3j37bnxjvdadcdaj4qy5z"))
  55       (file-name (string-append "stex-" version ".tar.gz")))))
  56
  57 (define-public chez-scheme
  58   (package
  59     (name "chez-scheme")
  60     (version "9.4")
  61     (source
  62      (origin
  63        (method url-fetch)
  64        (uri (string-append "https://github.com/cisco/ChezScheme/archive/"
  65                            "v" version ".tar.gz"))
  66        (sha256
  67         (base32 "0lprmpsjg2plc6ykgkz482zyvhkzv6gd0vnar71ph21h6zknyklz"))
  68        (file-name (string-append "chez-scheme-" version ".tar.gz"))))
  69     (build-system gnu-build-system)
  70     (inputs
  71      `(("ncurses" ,ncurses)
  72        ("libx11" ,libx11)
  73        ("xorg-rgb" ,xorg-rgb)
  74        ("nanopass" ,nanopass)
  75        ("zlib" ,zlib)
  76        ("stex" ,stex)))
  77     (native-inputs
  78      `(("texlive" ,texlive)
  79        ("ghostscript" ,ghostscript-gs)
  80        ("netpbm" ,netpbm)))
  81     (native-search-paths
  82      (list (search-path-specification
  83             (variable "CHEZSCHEMELIBDIRS")
  84             (files (list (string-append "lib/csv" version "-site"))))))
  85     (outputs '("out" "doc"))
  86     (arguments
  87      `(#:modules ((guix build gnu-build-system)
  88                   (guix build utils)
  89                   (ice-9 match))
  90        #:test-target "test"
  91        #:configure-flags
  92        (list ,(match (or (%current-target-system) (%current-system))
  93                 ("x86_64-linux" '(list "--machine=ta6le"))
  94                 ("i686-linux" '(list "--machine=ti3le"))
  95                 ;; FIXME: Some people succeeded in cross-compiling to
  96                 ;; ARM. https://github.com/cisco/ChezScheme/issues/13
  97                 (_
  98                  '())))
  99        #:phases
 100        (modify-phases %standard-phases
 101          ;; Adapt the custom 'configure' script.
 102          (replace 'configure
 103            (lambda* (#:key inputs outputs #:allow-other-keys)
 104              (let ((out (assoc-ref outputs "out"))
 105                    (nanopass (assoc-ref inputs "nanopass"))
 106                    (stex (assoc-ref inputs "stex"))
 107                    (zlib (assoc-ref inputs "zlib"))
 108                    (unpack (assoc-ref %standard-phases 'unpack))
 109                    (patch-source-shebangs
 110                     (assoc-ref %standard-phases 'patch-source-shebangs)))
 111                (map (match-lambda
 112                       ((src orig-name new-name)
 113                        (with-directory-excursion "."
 114                          (apply unpack (list #:source src))
 115                          (apply patch-source-shebangs (list #:source src)))
 116                        (delete-file-recursively new-name)
 117                        (system* "mv" orig-name new-name)))
 118                     `((,nanopass "nanopass-framework-scheme-1.9" "nanopass")
 119                       (,stex "stex-1.2.1" "stex")))
 120                ;; The Makefile wants to download and compile "zlib".  We patch
 121                ;; it to use the one from our 'zlib' package.
 122                (substitute* "configure"
 123                  (("rmdir zlib .*$") "echo \"using system zlib\"\n"))
 124                (substitute* (find-files "./c" "Mf-[a-zA-Z0-9.]+")
 125                  (("\\$\\{Kernel\\}: \\$\\{kernelobj\\} \\.\\./zlib/libz\\.a")
 126                   "${Kernel}: ${kernelobj}")
 127                  (("ld ([-a-zA-Z0-9_${} ]+) \\.\\./zlib/libz\\.a" all args)
 128                   (string-append "ld " args " " zlib "/lib/libz.a"))
 129                  (("\\(cd \\.\\./zlib; ([-a-zA-Z0-9=./ ]+))")
 130                   (which "true")))
 131                (substitute* (find-files "mats" "Mf-.*")
 132                  (("^[[:space:]]+(cc ) *") "\tgcc "))
 133                (substitute*
 134                    (find-files "." (string-append
 135                                     "("
 136                                     "Mf-[a-zA-Z0-9.]+"
 137                                     "|Makefile[a-zA-Z0-9.]*"
 138                                     "|checkin"
 139                                     "|stex\\.stex"
 140                                     "|newrelease"
 141                                     "|workarea"
 142                                     ;;"|[a-zA-Z0-9.]+\\.ms" ; guile can't read
 143                                     ")"))
 144                  (("/bin/rm") (which "rm"))
 145                  (("/bin/ln") (which "ln"))
 146                  (("/bin/cp") (which "cp")))
 147                (substitute* "makefiles/installsh"
 148                  (("/bin/true") (which "true")))
 149                (substitute* "stex/Makefile"
 150                  (("PREFIX=/usr") (string-append "PREFIX=" out)))
 151                (zero? (system* "./configure" "--threads"
 152                                (string-append "--installprefix=" out))))))
 153          ;; Installation of the documentation requires a running "chez".
 154          (add-after 'install 'install-doc
 155            (lambda* (#:key inputs outputs #:allow-other-keys)
 156              (let ((bin (string-append (assoc-ref outputs "out") "/bin"))
 157                    (doc (string-append (assoc-ref outputs "doc")
 158                                        "/share/doc/" ,name "-" ,version)))
 159                (setenv "HOME" (getcwd))
 160                (setenv "PATH" (string-append (getenv "PATH") ":" bin))
 161                (with-directory-excursion "stex"
 162                  (system* "make" (string-append "BIN=" bin)))
 163                (system* "make" "docs")
 164                (with-directory-excursion "csug"
 165                  (substitute* "Makefile"
 166                    (("/tmp/csug9") doc))
 167                  (system* "make" "install")
 168                  (install-file "csug.pdf" doc))
 169                (with-directory-excursion "release_notes"
 170                  (install-file "release_notes.pdf" doc))
 171                #t)))
 172          ;; The binary file name is called "scheme" as the one from MIT/GNU
 173          ;; Scheme.  We add a symlink to use in case both are installed.
 174          (add-after 'install 'install-symlink
 175            (lambda* (#:key outputs #:allow-other-keys)
 176              (let* ((out (assoc-ref outputs "out"))
 177                     (bin (string-append out "/bin"))
 178                     (lib (string-append out "/lib"))
 179                     (name "chez-scheme"))
 180                (symlink (string-append bin "/scheme")
 181                         (string-append bin "/" name))
 182                (map (lambda (file)
 183                       (symlink file (string-append (dirname file)
 184                                                    "/" name ".boot")))
 185                     (find-files lib "scheme.boot"))
 186                #t))))))
 187     ;; According to the documentation MIPS is not supported.
 188     (supported-systems (delete "mips64el-linux" %supported-systems))
 189     (home-page "http://www.scheme.com")
 190     (synopsis "R6RS Scheme compiler and run-time")
 191     (description
 192      "Chez Scheme is a compiler and run-time system for the language of the
 193 Revised^6 Report on Scheme (R6RS), with numerous extensions.  The compiler
 194 generates native code for each target processor, with support for x86, x86_64,
 195 and 32-bit PowerPC architectures.")
 196     (license asl2.0)))