pkgs/development/compilers/chicken/4/0001-Introduce-CHICKEN_REPOSITORY_EXTRA.patch

   1 From 2877f33747e3871c3a682b3a0c812b8ba2e4da5a Mon Sep 17 00:00:00 2001
   2 From: Caolan McMahon <caolan@caolanmcmahon.com>
   3 Date: Sat, 25 Jun 2016 11:52:28 +0100
   4 Subject: [PATCH] Introduce CHICKEN_REPOSITORY_EXTRA
   5
   6 This environment variable works like CHICKEN_REPOSITORY but supports
   7 multiple paths separated by `:'. Those paths are searched after
   8 CHICKEN_REPOSITORY when loading extensions via `require-library' and
   9 friends. It can be accessed and changed at runtime via the new procedure
  10 `repository-extra-paths' which is analog to `repository-path'.
  11
  12 Original patch by Moritz Heidkamp.
  13 Updated by Caolan McMahon for CHICKEN 4.11.0
  14 ---
  15  chicken-install.scm | 29 ++++++++++++++++++++++++-----
  16  chicken.import.scm  |  1 +
  17  eval.scm            | 37 +++++++++++++++++++++++++++++++------
  18  3 files changed, 56 insertions(+), 11 deletions(-)
  19
  20 diff --git a/chicken-install.scm b/chicken-install.scm
  21 index 7bc6041..f557793 100644
  22 --- a/chicken-install.scm
  23 +++ b/chicken-install.scm
  24 @@ -120,6 +120,19 @@
  25                  (sprintf "lib/chicken/~a" (##sys#fudge 42)))
  26                 (repository-path)))))
  27
  28 +  (define (repo-paths)
  29 +    (if *deploy*
  30 +       *prefix*
  31 +       (if (and *cross-chicken* (not *host-extension*))
  32 +           (list (make-pathname C_TARGET_LIB_HOME (sprintf "chicken/~a" C_BINARY_VERSION)))
  33 +           (cons
  34 +            (if *prefix*
  35 +                (make-pathname
  36 +                       *prefix*
  37 +                       (sprintf "lib/chicken/~a" (##sys#fudge 42)))
  38 +                (repository-path))
  39 +            (repository-extra-paths)))))
  40 +
  41    (define (get-prefix #!optional runtime)
  42      (cond ((and *cross-chicken*
  43                 (not *host-extension*))
  44 @@ -226,10 +239,13 @@
  45             (chicken-version) )
  46           ;; Duplication of (extension-information) to get custom
  47           ;; prefix.  This should be fixed.
  48 -          ((let* ((ep (##sys#canonicalize-extension-path x 'ext-version))
  49 -                 (sf (make-pathname (repo-path) ep "setup-info")))
  50 -            (and (file-exists? sf)
  51 -                 (with-input-from-file sf read))) =>
  52 +      ((let ((ep (##sys#canonicalize-extension-path x 'ext-version)))
  53 +         (let loop ((paths (repo-paths)))
  54 +           (cond ((null? paths) #f)
  55 +                 ((let ((sf (make-pathname (car paths) ep "setup-info")))
  56 +                    (and (file-exists? sf)
  57 +                         (with-input-from-file sf read))))
  58 +                 (else (loop (cdr paths)))))) =>
  59             (lambda (info)
  60               (let ((a (assq 'version info)))
  61                 (if a
  62 @@ -776,7 +792,10 @@
  63                   "installed extension has no information about which egg it belongs to"
  64                   (pathname-file sf))
  65                  #f))))
  66 -      (glob (make-pathname (repo-path) "*" "setup-info")))
  67 +      (append-map
  68 +       (lambda (path)
  69 +       (glob (make-pathname path "*" "setup-info")))
  70 +       (repo-paths)))
  71       equal?))
  72
  73    (define (list-available-extensions trans locn)
  74 diff --git a/chicken.import.scm b/chicken.import.scm
  75 index f6e3a19..be1637c 100644
  76 --- a/chicken.import.scm
  77 +++ b/chicken.import.scm
  78 @@ -200,6 +200,7 @@
  79     repl
  80     repl-prompt
  81     repository-path
  82 +   repository-extra-paths
  83     require
  84     reset
  85     reset-handler
  86 diff --git a/eval.scm b/eval.scm
  87 index 6242f62..f7d76d4 100644
  88 --- a/eval.scm
  89 +++ b/eval.scm
  90 @@ -81,6 +81,7 @@
  91  (define-constant source-file-extension ".scm")
  92  (define-constant setup-file-extension "setup-info")
  93  (define-constant repository-environment-variable "CHICKEN_REPOSITORY")
  94 +(define-constant repository-extra-environment-variable "CHICKEN_REPOSITORY_EXTRA")
  95  (define-constant prefix-environment-variable "CHICKEN_PREFIX")
  96
  97  ; these are actually in unit extras, but that is used by default
  98 @@ -1176,6 +1177,25 @@
  99
 100  (define ##sys#repository-path repository-path)
 101
 102 +(define ##sys#repository-extra-paths
 103 +  (let* ((repaths (get-environment-variable repository-extra-environment-variable))
 104 +        (repaths (if repaths
 105 +                     (let ((len (string-length repaths)))
 106 +                       (let loop ((i 0) (offset 0) (res '()))
 107 +                         (cond ((> i len)
 108 +                                (reverse res))
 109 +                               ((or (= i len) (eq? #\: (string-ref repaths i)))
 110 +                                (loop (+ i 1) (+ i 1) (cons (substring repaths offset i) res)))
 111 +                               (else
 112 +                                (loop (+ i 1) offset res)))))
 113 +                     '())))
 114 +    (lambda (#!optional val)
 115 +      (if val
 116 +         (set! repaths val)
 117 +         repaths))))
 118 +
 119 +(define repository-extra-paths ##sys#repository-extra-paths)
 120 +
 121  (define ##sys#setup-mode #f)
 122
 123  (define ##sys#find-extension
 124 @@ -1193,6 +1213,7 @@
 125         (let loop ((paths (##sys#append
 126                            (if ##sys#setup-mode '(".") '())
 127                            (if rp (list rp) '())
 128 +                          (##sys#repository-extra-paths)
 129                            (if inc? ##sys#include-pathnames '())
 130                            (if ##sys#setup-mode '() '("."))) ))
 131           (and (pair? paths)
 132 @@ -1252,12 +1273,16 @@
 133         [string-append string-append]
 134         [read read] )
 135      (lambda (id loc)
 136 -      (and-let* ((rp (##sys#repository-path)))
 137 -       (let* ((p (##sys#canonicalize-extension-path id loc))
 138 -              (rpath (string-append rp "/" p ".")) )
 139 -         (cond ((file-exists? (string-append rpath setup-file-extension))
 140 -                => (cut with-input-from-file <> read) )
 141 -               (else #f) ) ) ) ) ))
 142 +      (let loop ((rpaths (cons (##sys#repository-path) (##sys#repository-extra-paths))))
 143 +       (and (pair? rpaths)
 144 +            (let ((rp (car rpaths)))
 145 +              (if (not rp)
 146 +                  (loop (cdr rpaths))
 147 +                  (let* ((p (##sys#canonicalize-extension-path id loc))
 148 +                         (rpath (string-append rp "/" p ".")) )
 149 +                    (cond ((file-exists? (string-append rpath setup-file-extension))
 150 +                           => (cut with-input-from-file <> read) )
 151 +                          (else (loop (cdr rpaths))) ) )) ))) ) ))
 152
 153  (define (extension-information ext)
 154    (##sys#extension-information ext 'extension-information) )
 155 --
 156 2.1.4
 157