| 1 | From 520c6d44dbe916555e3b8b3ad3d50d82b3ac2aec Mon Sep 17 00:00:00 2001
|
|---|
| 2 | From: Jim Ursetto <jim@3e8.org>
|
|---|
| 3 | Date: Sun, 1 Jan 2012 02:22:19 -0600
|
|---|
| 4 | Subject: [PATCH 01/13] Add initial repository pathspec code
|
|---|
| 5 |
|
|---|
| 6 | Add repository-pathspec list which splits CHICKEN_REPOSITORY on :,
|
|---|
| 7 | and have repository-path return the car. Empty path elements are
|
|---|
| 8 | replaced with the default repository path (i.e. the path if
|
|---|
| 9 | the env var is not set). However, if a private repository is
|
|---|
| 10 | active, the path is set to that exclusively.
|
|---|
| 11 | ---
|
|---|
| 12 | chicken.import.scm | 1 +
|
|---|
| 13 | eval.scm | 43 +++++++++++++++++++++++++++++--------------
|
|---|
| 14 | 2 files changed, 30 insertions(+), 14 deletions(-)
|
|---|
| 15 |
|
|---|
| 16 | diff --git a/chicken.import.scm b/chicken.import.scm
|
|---|
| 17 | index 9811d8f..58798a9 100644
|
|---|
| 18 | --- a/chicken.import.scm
|
|---|
| 19 | +++ b/chicken.import.scm
|
|---|
| 20 | @@ -194,6 +194,7 @@
|
|---|
| 21 | repl
|
|---|
| 22 | repl-prompt
|
|---|
| 23 | repository-path
|
|---|
| 24 | + repository-pathspec
|
|---|
| 25 | require
|
|---|
| 26 | reset
|
|---|
| 27 | reset-handler
|
|---|
| 28 | diff --git a/eval.scm b/eval.scm
|
|---|
| 29 | index 6fdc3bf..bb81b8e 100644
|
|---|
| 30 | --- a/eval.scm
|
|---|
| 31 | +++ b/eval.scm
|
|---|
| 32 | @@ -27,7 +27,7 @@
|
|---|
| 33 |
|
|---|
| 34 | (declare
|
|---|
| 35 | (unit eval)
|
|---|
| 36 | - (uses expand)
|
|---|
| 37 | + (uses expand data-structures)
|
|---|
| 38 | (hide ##sys#r4rs-environment ##sys#r5rs-environment
|
|---|
| 39 | ##sys#interaction-environment pds pdss pxss d)
|
|---|
| 40 | (not inline ##sys#repl-eval-hook ##sys#repl-read-hook ##sys#repl-print-hook
|
|---|
| 41 | @@ -1094,22 +1094,37 @@
|
|---|
| 42 | (check (##sys#substring p 0 (fx- n 1))) ]
|
|---|
| 43 | [else p] ) ) ) ) ) ) )
|
|---|
| 44 |
|
|---|
| 45 | -(define ##sys#repository-path
|
|---|
| 46 | - (let ((rpath
|
|---|
| 47 | - (if (##sys#fudge 22) ; private repository?
|
|---|
| 48 | - (foreign-value "C_private_repository_path()" c-string)
|
|---|
| 49 | - (or (get-environment-variable repository-environment-variable)
|
|---|
| 50 | - (##sys#chicken-prefix
|
|---|
| 51 | - (##sys#string-append
|
|---|
| 52 | +(define ##sys#repository-path)
|
|---|
| 53 | +(define ##sys#repository-pathspec)
|
|---|
| 54 | +
|
|---|
| 55 | +(let ((dpath (or (##sys#chicken-prefix
|
|---|
| 56 | + (##sys#string-append
|
|---|
| 57 | "lib/chicken/"
|
|---|
| 58 | - (##sys#number->string (##sys#fudge 42))) )
|
|---|
| 59 | - install-egg-home))))
|
|---|
| 60 | - (lambda (#!optional val)
|
|---|
| 61 | - (if val
|
|---|
| 62 | - (set! rpath val)
|
|---|
| 63 | - rpath))))
|
|---|
| 64 | + (##sys#number->string (##sys#fudge 42))))
|
|---|
| 65 | + install-egg-home))
|
|---|
| 66 | + (split-pathspec (lambda (p)
|
|---|
| 67 | + (if p
|
|---|
| 68 | + (string-split p ":" #t) ;; FIXME: use ; on Windows
|
|---|
| 69 | + '("")))))
|
|---|
| 70 | + (let ((rspec (if (##sys#fudge 22) ; private repository? currently overrides repo path, shall we place in : instead?
|
|---|
| 71 | + (list (foreign-value "C_private_repository_path()" c-string))
|
|---|
| 72 | + (map (lambda (x)
|
|---|
| 73 | + (if (string=? x "") dpath x))
|
|---|
| 74 | + (split-pathspec
|
|---|
| 75 | + (get-environment-variable repository-environment-variable))))))
|
|---|
| 76 | + (set! ##sys#repository-pathspec
|
|---|
| 77 | + (lambda (#!optional val)
|
|---|
| 78 | + (if val
|
|---|
| 79 | + (set! rspec val) ;; like original, won't #f arg not perform set! ?
|
|---|
| 80 | + rspec)))
|
|---|
| 81 | + (set! ##sys#repository-path
|
|---|
| 82 | + (lambda (#!optional val)
|
|---|
| 83 | + (if val
|
|---|
| 84 | + (set! rspec (list val)) ;; should we be able to zero this?
|
|---|
| 85 | + (and (pair? rspec) (car rspec)))))))
|
|---|
| 86 |
|
|---|
| 87 | (define repository-path ##sys#repository-path)
|
|---|
| 88 | +(define repository-pathspec ##sys#repository-pathspec)
|
|---|
| 89 |
|
|---|
| 90 | (define ##sys#setup-mode #f)
|
|---|
| 91 |
|
|---|
| 92 | --
|
|---|
| 93 | 2.2.1
|
|---|
| 94 |
|
|---|
| 95 |
|
|---|
| 96 | From a80847ffa4b259547c0b6b3e1c8999bc4e38aed8 Mon Sep 17 00:00:00 2001
|
|---|
| 97 | From: Jim Ursetto <jim@3e8.org>
|
|---|
| 98 | Date: Sun, 1 Jan 2012 02:55:14 -0600
|
|---|
| 99 | Subject: [PATCH 02/13] Use ; instead of : for repository pathspec separator,
|
|---|
| 100 | as in CHICKEN_INCLUDE_PATH
|
|---|
| 101 |
|
|---|
| 102 | ---
|
|---|
| 103 | eval.scm | 2 +-
|
|---|
| 104 | 1 file changed, 1 insertion(+), 1 deletion(-)
|
|---|
| 105 |
|
|---|
| 106 | diff --git a/eval.scm b/eval.scm
|
|---|
| 107 | index bb81b8e..902b8f3 100644
|
|---|
| 108 | --- a/eval.scm
|
|---|
| 109 | +++ b/eval.scm
|
|---|
| 110 | @@ -1104,7 +1104,7 @@
|
|---|
| 111 | install-egg-home))
|
|---|
| 112 | (split-pathspec (lambda (p)
|
|---|
| 113 | (if p
|
|---|
| 114 | - (string-split p ":" #t) ;; FIXME: use ; on Windows
|
|---|
| 115 | + (string-split p ";" #t)
|
|---|
| 116 | '("")))))
|
|---|
| 117 | (let ((rspec (if (##sys#fudge 22) ; private repository? currently overrides repo path, shall we place in : instead?
|
|---|
| 118 | (list (foreign-value "C_private_repository_path()" c-string))
|
|---|
| 119 | --
|
|---|
| 120 | 2.2.1
|
|---|
| 121 |
|
|---|
| 122 |
|
|---|
| 123 | From e7eb8d318cc49ae5843456b847e2fb008cbfbf50 Mon Sep 17 00:00:00 2001
|
|---|
| 124 | From: Jim Ursetto <zbigniewsz@gmail.com>
|
|---|
| 125 | Date: Mon, 2 Jan 2012 00:41:14 -0600
|
|---|
| 126 | Subject: [PATCH 03/13] Modify chicken-status to follow repository pathspec,
|
|---|
| 127 | preferring eggs earlier in path.
|
|---|
| 128 |
|
|---|
| 129 | ---
|
|---|
| 130 | chicken-status.scm | 58 ++++++++++++++++++++++++++++++------------------------
|
|---|
| 131 | 1 file changed, 32 insertions(+), 26 deletions(-)
|
|---|
| 132 |
|
|---|
| 133 | diff --git a/chicken-status.scm b/chicken-status.scm
|
|---|
| 134 | index 9f56cd1..69e4ce0 100644
|
|---|
| 135 | --- a/chicken-status.scm
|
|---|
| 136 | +++ b/chicken-status.scm
|
|---|
| 137 | @@ -42,18 +42,22 @@
|
|---|
| 138 |
|
|---|
| 139 | (define (repo-path)
|
|---|
| 140 | (if (and *cross-chicken* (not *host-extensions*))
|
|---|
| 141 | - (make-pathname C_TARGET_LIB_HOME (sprintf "chicken/~a" C_BINARY_VERSION))
|
|---|
| 142 | - (repository-path)))
|
|---|
| 143 | -
|
|---|
| 144 | - (define (grep rx lst)
|
|---|
| 145 | - (filter (cut irregex-search rx <>) lst))
|
|---|
| 146 | -
|
|---|
| 147 | - (define (gather-eggs patterns)
|
|---|
| 148 | - (let ((eggs (map pathname-file
|
|---|
| 149 | - (glob (make-pathname (repo-path) "*" "setup-info")))))
|
|---|
| 150 | + (list (make-pathname C_TARGET_LIB_HOME (sprintf "chicken/~a" C_BINARY_VERSION)))
|
|---|
| 151 | + (repository-pathspec)))
|
|---|
| 152 | + (define (pretty-repo-path)
|
|---|
| 153 | + (string-intersperse (repo-path) ";"))
|
|---|
| 154 | +
|
|---|
| 155 | + (define (gather-eggs patterns) ; returns (("eggname" . "/path/to/repo") ...), preferring earliest path
|
|---|
| 156 | + (define (grep-car rx lst)
|
|---|
| 157 | + (filter (lambda (x) (irregex-search rx (car x))) lst))
|
|---|
| 158 | + (let ((eggs (append-map (lambda (path)
|
|---|
| 159 | + (map (lambda (f)
|
|---|
| 160 | + (cons (pathname-file f) path))
|
|---|
| 161 | + (glob (make-pathname path "*" "setup-info"))))
|
|---|
| 162 | + (repo-path))))
|
|---|
| 163 | (delete-duplicates
|
|---|
| 164 | - (concatenate (map (cut grep <> eggs) patterns))
|
|---|
| 165 | - string=?)))
|
|---|
| 166 | + (concatenate (map (cut grep-car <> eggs) patterns))
|
|---|
| 167 | + (lambda (x y) (string=? (car x) (car y))))))
|
|---|
| 168 |
|
|---|
| 169 | (define (format-string str cols #!optional right (padc #\space))
|
|---|
| 170 | (let* ((len (string-length str))
|
|---|
| 171 | @@ -77,15 +81,16 @@
|
|---|
| 172 | (let ((w (quotient (- (get-terminal-width) 2) 2)))
|
|---|
| 173 | (for-each
|
|---|
| 174 | (lambda (egg)
|
|---|
| 175 | - (let ((version (assq 'version (read-info egg (repo-path)))))
|
|---|
| 176 | - (if version
|
|---|
| 177 | - (print
|
|---|
| 178 | - (format-string (string-append egg " ") w #f #\.)
|
|---|
| 179 | - (format-string
|
|---|
| 180 | - (string-append " version: " (->string (cadr version)))
|
|---|
| 181 | - w #t #\.))
|
|---|
| 182 | - (print egg))))
|
|---|
| 183 | - (sort eggs string<?))))
|
|---|
| 184 | + (let ((name (car egg)) (path (cdr egg)))
|
|---|
| 185 | + (let ((version (assq 'version (read-info name path))))
|
|---|
| 186 | + (if version
|
|---|
| 187 | + (print
|
|---|
| 188 | + (format-string (string-append name " ") w #f #\.)
|
|---|
| 189 | + (format-string
|
|---|
| 190 | + (string-append " version: " (->string (cadr version)))
|
|---|
| 191 | + w #t #\.))
|
|---|
| 192 | + (print name)))))
|
|---|
| 193 | + (sort eggs (lambda (x y) (string<? (car x) (car y)))))))
|
|---|
| 194 |
|
|---|
| 195 | (define (list-installed-files eggs)
|
|---|
| 196 | (for-each
|
|---|
| 197 | @@ -93,10 +98,11 @@
|
|---|
| 198 | (sort
|
|---|
| 199 | (append-map
|
|---|
| 200 | (lambda (egg)
|
|---|
| 201 | - (let ((files (assq 'files (read-info egg (repo-path)))))
|
|---|
| 202 | - (if files
|
|---|
| 203 | - (cdr files)
|
|---|
| 204 | - '())))
|
|---|
| 205 | + (let ((name (car egg)) (path (cdr egg)))
|
|---|
| 206 | + (let ((files (assq 'files (read-info name path))))
|
|---|
| 207 | + (if files
|
|---|
| 208 | + (cdr files)
|
|---|
| 209 | + '()))))
|
|---|
| 210 | eggs)
|
|---|
| 211 | string<?)))
|
|---|
| 212 |
|
|---|
| 213 | @@ -137,10 +143,10 @@ EOF
|
|---|
| 214 | ((if files list-installed-files list-installed-eggs)
|
|---|
| 215 | eggs))))))
|
|---|
| 216 | (cond ((and *host-extensions* *target-extensions*)
|
|---|
| 217 | - (print "host at " (repo-path) ":\n")
|
|---|
| 218 | + (print "host at " (pretty-repo-path) ":\n")
|
|---|
| 219 | (status)
|
|---|
| 220 | (fluid-let ((*host-extensions* #f))
|
|---|
| 221 | - (print "\ntarget at " (repo-path) ":\n")
|
|---|
| 222 | + (print "\ntarget at " (pretty-repo-path) ":\n")
|
|---|
| 223 | (status)))
|
|---|
| 224 | (else (status))))
|
|---|
| 225 | (let ((arg (car args)))
|
|---|
| 226 | --
|
|---|
| 227 | 2.2.1
|
|---|
| 228 |
|
|---|
| 229 |
|
|---|
| 230 | From 9dfae2f7d7b803e0bcc83c8dda75f3b0ff556c4b Mon Sep 17 00:00:00 2001
|
|---|
| 231 | From: Jim Ursetto <zbigniewsz@gmail.com>
|
|---|
| 232 | Date: Mon, 2 Jan 2012 01:22:56 -0600
|
|---|
| 233 | Subject: [PATCH 04/13] Update extension-information to search
|
|---|
| 234 | repository-pathspec
|
|---|
| 235 |
|
|---|
| 236 | ---
|
|---|
| 237 | eval.scm | 14 ++++++++------
|
|---|
| 238 | 1 file changed, 8 insertions(+), 6 deletions(-)
|
|---|
| 239 |
|
|---|
| 240 | diff --git a/eval.scm b/eval.scm
|
|---|
| 241 | index 902b8f3..190589b 100644
|
|---|
| 242 | --- a/eval.scm
|
|---|
| 243 | +++ b/eval.scm
|
|---|
| 244 | @@ -1201,12 +1201,14 @@
|
|---|
| 245 | [string-append string-append]
|
|---|
| 246 | [read read] )
|
|---|
| 247 | (lambda (id loc)
|
|---|
| 248 | - (and-let* ((rp (##sys#repository-path)))
|
|---|
| 249 | - (let* ((p (##sys#canonicalize-extension-path id loc))
|
|---|
| 250 | - (rpath (string-append rp "/" p ".")) )
|
|---|
| 251 | - (cond ((file-exists? (string-append rpath setup-file-extension))
|
|---|
| 252 | - => (cut with-input-from-file <> read) )
|
|---|
| 253 | - (else #f) ) ) ) ) ))
|
|---|
| 254 | + (let* ((p (##sys#canonicalize-extension-path id loc))
|
|---|
| 255 | + (rfn (string-append "/" p "." setup-file-extension)))
|
|---|
| 256 | + (let loop ((rps (##sys#repository-pathspec)))
|
|---|
| 257 | + (if (null? rps)
|
|---|
| 258 | + #f
|
|---|
| 259 | + (cond ((file-exists? (string-append (car rps) rfn))
|
|---|
| 260 | + => (cut with-input-from-file <> read) )
|
|---|
| 261 | + (else (loop (cdr rps))) )))) ) ))
|
|---|
| 262 |
|
|---|
| 263 | (define (extension-information ext)
|
|---|
| 264 | (##sys#extension-information ext 'extension-information) )
|
|---|
| 265 | --
|
|---|
| 266 | 2.2.1
|
|---|
| 267 |
|
|---|
| 268 |
|
|---|
| 269 | From 71d904f7e1f5adfa08488865a394459398f6829e Mon Sep 17 00:00:00 2001
|
|---|
| 270 | From: Jim Ursetto <zbigniewsz@gmail.com>
|
|---|
| 271 | Date: Mon, 2 Jan 2012 01:37:45 -0600
|
|---|
| 272 | Subject: [PATCH 05/13] Update ##sys#find-extension to search
|
|---|
| 273 | repository-pathspec.
|
|---|
| 274 |
|
|---|
| 275 | We retain the current behavior of searching . at the end (or beginning, if
|
|---|
| 276 | -setup-mode) of the search path. It may make sense to remove the end . search
|
|---|
| 277 | when CHICKEN_REPOSITORY is explicitly set and require the user to add it to
|
|---|
| 278 | the path, but that may also break things.
|
|---|
| 279 | ---
|
|---|
| 280 | eval.scm | 6 +++---
|
|---|
| 281 | 1 file changed, 3 insertions(+), 3 deletions(-)
|
|---|
| 282 |
|
|---|
| 283 | diff --git a/eval.scm b/eval.scm
|
|---|
| 284 | index 190589b..784a193 100644
|
|---|
| 285 | --- a/eval.scm
|
|---|
| 286 | +++ b/eval.scm
|
|---|
| 287 | @@ -1131,10 +1131,10 @@
|
|---|
| 288 | (define ##sys#find-extension
|
|---|
| 289 | (let ((string-append string-append) )
|
|---|
| 290 | (lambda (p inc?)
|
|---|
| 291 | - (let ((rp (##sys#repository-path)))
|
|---|
| 292 | + (let ((rps (##sys#repository-pathspec)))
|
|---|
| 293 | (define (check path)
|
|---|
| 294 | (let ((p0 (string-append path "/" p)))
|
|---|
| 295 | - (and (or (and rp
|
|---|
| 296 | + (and (or (and (pair? rps)
|
|---|
| 297 | (not ##sys#dload-disabled)
|
|---|
| 298 | (##sys#fudge 24) ; dload?
|
|---|
| 299 | (file-exists? (##sys#string-append p0 ##sys#load-dynamic-extension)))
|
|---|
| 300 | @@ -1142,7 +1142,7 @@
|
|---|
| 301 | p0) ) )
|
|---|
| 302 | (let loop ((paths (##sys#append
|
|---|
| 303 | (if ##sys#setup-mode '(".") '())
|
|---|
| 304 | - (if rp (list rp) '())
|
|---|
| 305 | + rps
|
|---|
| 306 | (if inc? ##sys#include-pathnames '())
|
|---|
| 307 | (if ##sys#setup-mode '() '("."))) ))
|
|---|
| 308 | (and (pair? paths)
|
|---|
| 309 | --
|
|---|
| 310 | 2.2.1
|
|---|
| 311 |
|
|---|
| 312 |
|
|---|
| 313 | From c8b69f40088f7b9db8843e9a02b9dde269308f3f Mon Sep 17 00:00:00 2001
|
|---|
| 314 | From: Jim Ursetto <zbigniewsz@gmail.com>
|
|---|
| 315 | Date: Mon, 2 Jan 2012 17:40:32 -0600
|
|---|
| 316 | Subject: [PATCH 06/13] Update resolve-include-filename to follow repository
|
|---|
| 317 | pathspec (when searching repository)
|
|---|
| 318 |
|
|---|
| 319 | Retains the current behavior of always searching CWD first. Only relevant
|
|---|
| 320 | when doing a repo search, so this change affects only -extend and
|
|---|
| 321 | -inline-global (.inline files).
|
|---|
| 322 | ---
|
|---|
| 323 | eval.scm | 7 ++-----
|
|---|
| 324 | 1 file changed, 2 insertions(+), 5 deletions(-)
|
|---|
| 325 |
|
|---|
| 326 | diff --git a/eval.scm b/eval.scm
|
|---|
| 327 | index 784a193..3b4a69a 100644
|
|---|
| 328 | --- a/eval.scm
|
|---|
| 329 | +++ b/eval.scm
|
|---|
| 330 | @@ -1489,11 +1489,8 @@
|
|---|
| 331 | (or (test fname)
|
|---|
| 332 | (let loop ((paths (if repo
|
|---|
| 333 | (##sys#append
|
|---|
| 334 | - ##sys#include-pathnames
|
|---|
| 335 | - (let ((rp (##sys#repository-path)))
|
|---|
| 336 | - (if rp
|
|---|
| 337 | - (list (##sys#repository-path))
|
|---|
| 338 | - '())))
|
|---|
| 339 | + ##sys#include-pathnames
|
|---|
| 340 | + (##sys#repository-pathspec))
|
|---|
| 341 | ##sys#include-pathnames) ) )
|
|---|
| 342 | (cond ((eq? paths '()) fname)
|
|---|
| 343 | ((test (string-append (##sys#slot paths 0)
|
|---|
| 344 | --
|
|---|
| 345 | 2.2.1
|
|---|
| 346 |
|
|---|
| 347 |
|
|---|
| 348 | From 3b1dcad69662021b78e79111e2d4ef7da6e13737 Mon Sep 17 00:00:00 2001
|
|---|
| 349 | From: Jim Ursetto <zbigniewsz@gmail.com>
|
|---|
| 350 | Date: Mon, 2 Jan 2012 17:48:54 -0600
|
|---|
| 351 | Subject: [PATCH 07/13] Show full repository pathspec in csi ,r
|
|---|
| 352 |
|
|---|
| 353 | ---
|
|---|
| 354 | csi.scm | 2 +-
|
|---|
| 355 | 1 file changed, 1 insertion(+), 1 deletion(-)
|
|---|
| 356 |
|
|---|
| 357 | diff --git a/csi.scm b/csi.scm
|
|---|
| 358 | index 7552df8..41e00e5 100644
|
|---|
| 359 | --- a/csi.scm
|
|---|
| 360 | +++ b/csi.scm
|
|---|
| 361 | @@ -516,7 +516,7 @@ EOF
|
|---|
| 362 | (software-version)
|
|---|
| 363 | (build-platform)
|
|---|
| 364 | prefix
|
|---|
| 365 | - (repository-path)
|
|---|
| 366 | + (repository-pathspec)
|
|---|
| 367 | ##sys#include-pathnames
|
|---|
| 368 | (shorten (vector-ref sinfo 0))
|
|---|
| 369 | (shorten (vector-ref sinfo 1))
|
|---|
| 370 | --
|
|---|
| 371 | 2.2.1
|
|---|
| 372 |
|
|---|
| 373 |
|
|---|
| 374 | From 0ddd9371d566bbebe564d21f29ae4bfd667fb34b Mon Sep 17 00:00:00 2001
|
|---|
| 375 | From: Jim Ursetto <zbigniewsz@gmail.com>
|
|---|
| 376 | Date: Tue, 3 Jan 2012 01:17:35 -0600
|
|---|
| 377 | Subject: [PATCH 08/13] Update load-identifier-database to load the database
|
|---|
| 378 | from all repository paths
|
|---|
| 379 |
|
|---|
| 380 | Paths are traversed in order and all identifiers from shadowed modules are
|
|---|
| 381 | ignored. Here, a shadowed module is simply one whose name appears in an
|
|---|
| 382 | earlier identifier database; the installed module files are not considered.
|
|---|
| 383 | ---
|
|---|
| 384 | support.scm | 37 ++++++++++++++++++++++++++-----------
|
|---|
| 385 | 1 file changed, 26 insertions(+), 11 deletions(-)
|
|---|
| 386 |
|
|---|
| 387 | diff --git a/support.scm b/support.scm
|
|---|
| 388 | index 1b7bd31..304cef4 100644
|
|---|
| 389 | --- a/support.scm
|
|---|
| 390 | +++ b/support.scm
|
|---|
| 391 | @@ -1425,19 +1425,34 @@
|
|---|
| 392 |
|
|---|
| 393 | ;;; Load support files
|
|---|
| 394 |
|
|---|
| 395 | +;; Load the specified identifier database from all repositories in order,
|
|---|
| 396 | +;; skipping any identifiers from shadowed modules (seen in an earlier database).
|
|---|
| 397 | (define (load-identifier-database name)
|
|---|
| 398 | - (and-let* ((rp (repository-path))
|
|---|
| 399 | - (dbfile (file-exists? (make-pathname rp name))))
|
|---|
| 400 | - (when verbose-mode
|
|---|
| 401 | - (printf "loading identifier database ~a ...~%" dbfile))
|
|---|
| 402 | + (let* ((seen (make-vector 301 '()))
|
|---|
| 403 | + (was-seen (make-vector (##sys#size seen)))
|
|---|
| 404 | + (seen? (cut ##sys#hash-table-ref was-seen <>))
|
|---|
| 405 | + (seen! (cut ##sys#hash-table-set! seen <> #t)))
|
|---|
| 406 | (for-each
|
|---|
| 407 | - (lambda (e)
|
|---|
| 408 | - (let ((id (car e)))
|
|---|
| 409 | - (##sys#put!
|
|---|
| 410 | - id '##core#db
|
|---|
| 411 | - (append (or (##sys#get id '##core#db) '()) (list (cdr e))) )))
|
|---|
| 412 | - (read-file dbfile))))
|
|---|
| 413 | -
|
|---|
| 414 | + (lambda (rp)
|
|---|
| 415 | + (and-let* ((dbfile (file-exists? (make-pathname rp name))))
|
|---|
| 416 | + (when verbose-mode
|
|---|
| 417 | + (printf "loading identifier database ~a ...~%" dbfile))
|
|---|
| 418 | + (vector-copy! seen was-seen) ; safe b/c values are not mutated or deleted
|
|---|
| 419 | + (for-each
|
|---|
| 420 | + (lambda (e)
|
|---|
| 421 | + (let ((id (car e)) (mname (caddr e)))
|
|---|
| 422 | + (cond ((not (seen? mname))
|
|---|
| 423 | + (when verbose-mode
|
|---|
| 424 | + (printf " adding identifier ~a from ~a~%" id mname))
|
|---|
| 425 | + (##sys#put!
|
|---|
| 426 | + id '##core#db
|
|---|
| 427 | + (append (or (##sys#get id '##core#db) '()) (list (cdr e))))
|
|---|
| 428 | + (seen! mname))
|
|---|
| 429 | + (else
|
|---|
| 430 | + (when verbose-mode
|
|---|
| 431 | + (printf " skipped identifier ~a from ~a~%" id mname))))))
|
|---|
| 432 | + (read-file dbfile))))
|
|---|
| 433 | + (repository-pathspec))))
|
|---|
| 434 |
|
|---|
| 435 | ;;; Print version/usage information:
|
|---|
| 436 |
|
|---|
| 437 | --
|
|---|
| 438 | 2.2.1
|
|---|
| 439 |
|
|---|
| 440 |
|
|---|
| 441 | From c041bc25d68255fbba7e37338996226c1ed67ab2 Mon Sep 17 00:00:00 2001
|
|---|
| 442 | From: Jim Ursetto <zbigniewsz@gmail.com>
|
|---|
| 443 | Date: Tue, 3 Jan 2012 01:38:31 -0600
|
|---|
| 444 | Subject: [PATCH 09/13] Remove per-id debugging from load-identifier-database
|
|---|
| 445 |
|
|---|
| 446 | ---
|
|---|
| 447 | support.scm | 15 +++++----------
|
|---|
| 448 | 1 file changed, 5 insertions(+), 10 deletions(-)
|
|---|
| 449 |
|
|---|
| 450 | diff --git a/support.scm b/support.scm
|
|---|
| 451 | index 304cef4..5d91b19 100644
|
|---|
| 452 | --- a/support.scm
|
|---|
| 453 | +++ b/support.scm
|
|---|
| 454 | @@ -1441,16 +1441,11 @@
|
|---|
| 455 | (for-each
|
|---|
| 456 | (lambda (e)
|
|---|
| 457 | (let ((id (car e)) (mname (caddr e)))
|
|---|
| 458 | - (cond ((not (seen? mname))
|
|---|
| 459 | - (when verbose-mode
|
|---|
| 460 | - (printf " adding identifier ~a from ~a~%" id mname))
|
|---|
| 461 | - (##sys#put!
|
|---|
| 462 | - id '##core#db
|
|---|
| 463 | - (append (or (##sys#get id '##core#db) '()) (list (cdr e))))
|
|---|
| 464 | - (seen! mname))
|
|---|
| 465 | - (else
|
|---|
| 466 | - (when verbose-mode
|
|---|
| 467 | - (printf " skipped identifier ~a from ~a~%" id mname))))))
|
|---|
| 468 | + (unless (seen? mname)
|
|---|
| 469 | + (##sys#put!
|
|---|
| 470 | + id '##core#db
|
|---|
| 471 | + (append (or (##sys#get id '##core#db) '()) (list (cdr e))))
|
|---|
| 472 | + (seen! mname))))
|
|---|
| 473 | (read-file dbfile))))
|
|---|
| 474 | (repository-pathspec))))
|
|---|
| 475 |
|
|---|
| 476 | --
|
|---|
| 477 | 2.2.1
|
|---|
| 478 |
|
|---|
| 479 |
|
|---|
| 480 | From 81f3f79bb80124134f868813cc3c35243cb4339c Mon Sep 17 00:00:00 2001
|
|---|
| 481 | From: Jim Ursetto <zbigniewsz@gmail.com>
|
|---|
| 482 | Date: Fri, 6 Jan 2012 23:06:45 -0600
|
|---|
| 483 | Subject: [PATCH 10/13] Add path field to module record, representing
|
|---|
| 484 | current-load-path
|
|---|
| 485 |
|
|---|
| 486 | ---
|
|---|
| 487 | expand.scm | 9 ++++++---
|
|---|
| 488 | 1 file changed, 6 insertions(+), 3 deletions(-)
|
|---|
| 489 |
|
|---|
| 490 | diff --git a/expand.scm b/expand.scm
|
|---|
| 491 | index 12af83a..3e86a58 100644
|
|---|
| 492 | --- a/expand.scm
|
|---|
| 493 | +++ b/expand.scm
|
|---|
| 494 | @@ -1610,7 +1610,7 @@
|
|---|
| 495 | (define-record-type module
|
|---|
| 496 | (%make-module name export-list defined-list exist-list defined-syntax-list
|
|---|
| 497 | undefined-list import-forms meta-import-forms meta-expressions
|
|---|
| 498 | - vexports sexports)
|
|---|
| 499 | + vexports sexports path)
|
|---|
| 500 | module?
|
|---|
| 501 | (name module-name) ; SYMBOL
|
|---|
| 502 | (export-list module-export-list set-module-export-list!) ; (SYMBOL | (SYMBOL ...) ...)
|
|---|
| 503 | @@ -1622,9 +1622,12 @@
|
|---|
| 504 | (meta-import-forms module-meta-import-forms set-module-meta-import-forms!) ; (SPEC ...)
|
|---|
| 505 | (meta-expressions module-meta-expressions set-module-meta-expressions!) ; (EXP ...)
|
|---|
| 506 | (vexports module-vexports set-module-vexports!) ; ((SYMBOL . SYMBOL) ...)
|
|---|
| 507 | - (sexports module-sexports set-module-sexports!) ) ; ((SYMBOL SE TRANSFORMER) ...)
|
|---|
| 508 | + (sexports module-sexports set-module-sexports!) ; ((SYMBOL SE TRANSFORMER) ...)
|
|---|
| 509 | + (path module-path) ; STRING or #f (from current-load-path)
|
|---|
| 510 | + )
|
|---|
| 511 |
|
|---|
| 512 | (define ##sys#module-name module-name)
|
|---|
| 513 | +(define ##sys#module-path module-path)
|
|---|
| 514 |
|
|---|
| 515 | (define (##sys#module-exports m)
|
|---|
| 516 | (values
|
|---|
| 517 | @@ -1633,7 +1636,7 @@
|
|---|
| 518 | (module-sexports m)))
|
|---|
| 519 |
|
|---|
| 520 | (define (make-module name explist vexports sexports)
|
|---|
| 521 | - (%make-module name explist '() '() '() '() '() '() '() vexports sexports))
|
|---|
| 522 | + (%make-module name explist '() '() '() '() '() '() '() vexports sexports ##sys#current-load-path))
|
|---|
| 523 |
|
|---|
| 524 | (define (##sys#find-module name #!optional (err #t))
|
|---|
| 525 | (cond ((assq name ##sys#module-table) => cdr)
|
|---|
| 526 | --
|
|---|
| 527 | 2.2.1
|
|---|
| 528 |
|
|---|
| 529 |
|
|---|
| 530 | From 263b8249bf3374ab3bb9692b23587c43f5931098 Mon Sep 17 00:00:00 2001
|
|---|
| 531 | From: Jim Ursetto <zbigniewsz@gmail.com>
|
|---|
| 532 | Date: Fri, 6 Jan 2012 23:07:17 -0600
|
|---|
| 533 | Subject: [PATCH 11/13] Update current-load-path and current-source-filename
|
|---|
| 534 | when dloading as well as reading source
|
|---|
| 535 |
|
|---|
| 536 | ---
|
|---|
| 537 | eval.scm | 93 ++++++++++++++++++++++++++++++++--------------------------------
|
|---|
| 538 | 1 file changed, 47 insertions(+), 46 deletions(-)
|
|---|
| 539 |
|
|---|
| 540 | diff --git a/eval.scm b/eval.scm
|
|---|
| 541 | index 3b4a69a..ea5ca01 100644
|
|---|
| 542 | --- a/eval.scm
|
|---|
| 543 | +++ b/eval.scm
|
|---|
| 544 | @@ -919,52 +919,53 @@
|
|---|
| 545 | (display fname)
|
|---|
| 546 | (display " ...\n")
|
|---|
| 547 | (flush-output)] )
|
|---|
| 548 | - (or (and fname
|
|---|
| 549 | - (or (##sys#dload (##sys#make-c-string fname 'load) topentry #t)
|
|---|
| 550 | - (and (not (has-sep? fname))
|
|---|
| 551 | - (##sys#dload
|
|---|
| 552 | - (##sys#make-c-string
|
|---|
| 553 | - (##sys#string-append "./" fname)
|
|---|
| 554 | - 'load)
|
|---|
| 555 | - topentry #t) ) ) )
|
|---|
| 556 | - (call-with-current-continuation
|
|---|
| 557 | - (lambda (abrt)
|
|---|
| 558 | - (fluid-let ((##sys#read-error-with-line-number #t)
|
|---|
| 559 | - (##sys#current-source-filename fname)
|
|---|
| 560 | - (##sys#current-load-path
|
|---|
| 561 | - (and fname
|
|---|
| 562 | - (let ((i (has-sep? fname)))
|
|---|
| 563 | - (if i (##sys#substring fname 0 (fx+ i 1)) "") ) ) )
|
|---|
| 564 | - (##sys#abort-load (lambda () (abrt #f))) )
|
|---|
| 565 | - (let ((in (if fname (open-input-file fname) input)))
|
|---|
| 566 | - (##sys#dynamic-wind
|
|---|
| 567 | - (lambda () #f)
|
|---|
| 568 | - (lambda ()
|
|---|
| 569 | - (let ((c1 (peek-char in)))
|
|---|
| 570 | - (when (char=? c1 (integer->char 127))
|
|---|
| 571 | - (##sys#error
|
|---|
| 572 | - 'load
|
|---|
| 573 | - (##sys#string-append
|
|---|
| 574 | - "unable to load compiled module - "
|
|---|
| 575 | - (or _dlerror "unknown reason"))
|
|---|
| 576 | - fname)))
|
|---|
| 577 | - (let ((x1 (read in)))
|
|---|
| 578 | - (do ((x x1 (read in)))
|
|---|
| 579 | - ((eof-object? x))
|
|---|
| 580 | - (when printer (printer x))
|
|---|
| 581 | - (##sys#call-with-values
|
|---|
| 582 | - (lambda ()
|
|---|
| 583 | - (if timer
|
|---|
| 584 | - (time (evproc x))
|
|---|
| 585 | - (evproc x) ) )
|
|---|
| 586 | - (lambda results
|
|---|
| 587 | - (when pf
|
|---|
| 588 | - (for-each
|
|---|
| 589 | - (lambda (r)
|
|---|
| 590 | - (write r)
|
|---|
| 591 | - (newline) )
|
|---|
| 592 | - results) ) ) ) ) ) )
|
|---|
| 593 | - (lambda () (close-input-port in)) ) ) ) ) ) )
|
|---|
| 594 | + (fluid-let ((##sys#current-source-filename fname)
|
|---|
| 595 | + (##sys#current-load-path
|
|---|
| 596 | + (and fname
|
|---|
| 597 | + (let ((i (has-sep? fname)))
|
|---|
| 598 | + (if i (##sys#substring fname 0 (fx+ i 1)) "")))))
|
|---|
| 599 | + (or (and fname
|
|---|
| 600 | + (or (##sys#dload (##sys#make-c-string fname 'load) topentry #t)
|
|---|
| 601 | + (and (not (has-sep? fname))
|
|---|
| 602 | + (let ((fname (##sys#string-append "./" fname)))
|
|---|
| 603 | + (fluid-let ((##sys#current-source-filename fname)
|
|---|
| 604 | + (##sys#current-load-path "./"))
|
|---|
| 605 | + (##sys#dload
|
|---|
| 606 | + (##sys#make-c-string fname 'load)
|
|---|
| 607 | + topentry #t))) ) ) )
|
|---|
| 608 | + (call-with-current-continuation
|
|---|
| 609 | + (lambda (abrt)
|
|---|
| 610 | + (fluid-let ((##sys#read-error-with-line-number #t)
|
|---|
| 611 | + (##sys#abort-load (lambda () (abrt #f))) )
|
|---|
| 612 | + (let ((in (if fname (open-input-file fname) input)))
|
|---|
| 613 | + (##sys#dynamic-wind
|
|---|
| 614 | + (lambda () #f)
|
|---|
| 615 | + (lambda ()
|
|---|
| 616 | + (let ((c1 (peek-char in)))
|
|---|
| 617 | + (when (char=? c1 (integer->char 127))
|
|---|
| 618 | + (##sys#error
|
|---|
| 619 | + 'load
|
|---|
| 620 | + (##sys#string-append
|
|---|
| 621 | + "unable to load compiled module - "
|
|---|
| 622 | + (or _dlerror "unknown reason"))
|
|---|
| 623 | + fname)))
|
|---|
| 624 | + (let ((x1 (read in)))
|
|---|
| 625 | + (do ((x x1 (read in)))
|
|---|
| 626 | + ((eof-object? x))
|
|---|
| 627 | + (when printer (printer x))
|
|---|
| 628 | + (##sys#call-with-values
|
|---|
| 629 | + (lambda ()
|
|---|
| 630 | + (if timer
|
|---|
| 631 | + (time (evproc x))
|
|---|
| 632 | + (evproc x) ) )
|
|---|
| 633 | + (lambda results
|
|---|
| 634 | + (when pf
|
|---|
| 635 | + (for-each
|
|---|
| 636 | + (lambda (r)
|
|---|
| 637 | + (write r)
|
|---|
| 638 | + (newline) )
|
|---|
| 639 | + results) ) ) ) ) ) )
|
|---|
| 640 | + (lambda () (close-input-port in)) ) ) ) ) ) ))
|
|---|
| 641 | (##core#undefined) ) ) )
|
|---|
| 642 | (set! load
|
|---|
| 643 | (lambda (filename . evaluator)
|
|---|
| 644 | --
|
|---|
| 645 | 2.2.1
|
|---|
| 646 |
|
|---|
| 647 |
|
|---|
| 648 | From b0f10e8bbe195ba46f749d152211ef7f5ace431f Mon Sep 17 00:00:00 2001
|
|---|
| 649 | From: Jim Ursetto <zbigniewsz@gmail.com>
|
|---|
| 650 | Date: Sat, 7 Jan 2012 00:32:06 -0600
|
|---|
| 651 | Subject: [PATCH 12/13] chicken-install: Update modules.db in all repos; uses
|
|---|
| 652 | ##sys#module-path to filter out modules from other repos.
|
|---|
| 653 |
|
|---|
| 654 | ---
|
|---|
| 655 | chicken-install.scm | 71 +++++++++++++++++++++++++++++++----------------------
|
|---|
| 656 | 1 file changed, 41 insertions(+), 30 deletions(-)
|
|---|
| 657 |
|
|---|
| 658 | diff --git a/chicken-install.scm b/chicken-install.scm
|
|---|
| 659 | index 90ab801..a8d0861 100644
|
|---|
| 660 | --- a/chicken-install.scm
|
|---|
| 661 | +++ b/chicken-install.scm
|
|---|
| 662 | @@ -519,43 +519,54 @@
|
|---|
| 663 | (and-let* ((tmpdir (temporary-directory)))
|
|---|
| 664 | (remove-directory tmpdir))))
|
|---|
| 665 |
|
|---|
| 666 | - (define (update-db)
|
|---|
| 667 | - (let* ((files (glob (make-pathname (repository-path) "*.import.*")))
|
|---|
| 668 | - (tmpdir (create-temporary-directory))
|
|---|
| 669 | - (dbfile (make-pathname tmpdir +module-db+))
|
|---|
| 670 | - (rx (irregex ".*/([^/]+)\\.import\\.(scm|so)")))
|
|---|
| 671 | + ;; Create the +module-db+ file in repository PATH by loading all .import.* files
|
|---|
| 672 | + ;; in that directory and then walking the module table. Import files can import other
|
|---|
| 673 | + ;; modules recursively; since those may reside in another repository, we filter out
|
|---|
| 674 | + ;; any modules in the table not loaded directly from PATH.
|
|---|
| 675 | + (define (update-db path)
|
|---|
| 676 | + (let* ((path (make-pathname path #f)) ;; match ##sys#module-path's trailing forward slash
|
|---|
| 677 | + (files (glob (make-pathname path "*.import.*")))
|
|---|
| 678 | + (tmpdir (create-temporary-directory))
|
|---|
| 679 | + (dbfile (make-pathname tmpdir +module-db+))
|
|---|
| 680 | + (rx (irregex ".*/([^/]+)\\.import\\.(scm|so)")))
|
|---|
| 681 | (print "loading import libraries ...")
|
|---|
| 682 | (fluid-let ((##sys#warnings-enabled #f))
|
|---|
| 683 | - (for-each
|
|---|
| 684 | - (lambda (f)
|
|---|
| 685 | - (let ((m (irregex-match rx f)))
|
|---|
| 686 | + (for-each
|
|---|
| 687 | + (lambda (f)
|
|---|
| 688 | + (let ((m (irregex-match rx f)))
|
|---|
| 689 | (handle-exceptions ex
|
|---|
| 690 | (print-error-message
|
|---|
| 691 | ex (current-error-port)
|
|---|
| 692 | (sprintf "Failed to import from `~a'" f))
|
|---|
| 693 | (eval `(import ,(string->symbol (irregex-match-substring m 1)))))))
|
|---|
| 694 | - files))
|
|---|
| 695 | - (print "generating database")
|
|---|
| 696 | + files))
|
|---|
| 697 | + (print "generating database for " path)
|
|---|
| 698 | (let ((db
|
|---|
| 699 | - (sort
|
|---|
| 700 | - (append-map
|
|---|
| 701 | - (lambda (m)
|
|---|
| 702 | - (let* ((mod (cdr m))
|
|---|
| 703 | - (mname (##sys#module-name mod)))
|
|---|
| 704 | - (print* " " mname)
|
|---|
| 705 | - (let-values (((_ ve se) (##sys#module-exports mod)))
|
|---|
| 706 | - (append
|
|---|
| 707 | - (map (lambda (se) (list (car se) 'syntax mname)) se)
|
|---|
| 708 | - (map (lambda (ve) (list (car ve) 'value mname)) ve)))))
|
|---|
| 709 | - ##sys#module-table)
|
|---|
| 710 | - (lambda (e1 e2)
|
|---|
| 711 | - (string<? (symbol->string (car e1)) (symbol->string (car e2)))))))
|
|---|
| 712 | - (newline)
|
|---|
| 713 | - (with-output-to-file dbfile
|
|---|
| 714 | - (lambda ()
|
|---|
| 715 | - (for-each (lambda (x) (write x) (newline)) db)))
|
|---|
| 716 | - (copy-file dbfile (make-pathname (repository-path) +module-db+))
|
|---|
| 717 | - (remove-directory tmpdir))))
|
|---|
| 718 | + (sort
|
|---|
| 719 | + (append-map
|
|---|
| 720 | + (lambda (m)
|
|---|
| 721 | + (let* ((mod (cdr m))
|
|---|
| 722 | + (mname (##sys#module-name mod))
|
|---|
| 723 | + (mpath (##sys#module-path mod)))
|
|---|
| 724 | + (cond ((string=? mpath path)
|
|---|
| 725 | + (print* " " mname)
|
|---|
| 726 | + (let-values (((_ ve se) (##sys#module-exports mod)))
|
|---|
| 727 | + (append
|
|---|
| 728 | + (map (lambda (se) (list (car se) 'syntax mname)) se)
|
|---|
| 729 | + (map (lambda (ve) (list (car ve) 'value mname)) ve))))
|
|---|
| 730 | + (else '()))))
|
|---|
| 731 | + ##sys#module-table)
|
|---|
| 732 | + (lambda (e1 e2)
|
|---|
| 733 | + (string<? (symbol->string (car e1)) (symbol->string (car e2)))))))
|
|---|
| 734 | + (newline)
|
|---|
| 735 | + (with-output-to-file dbfile
|
|---|
| 736 | + (lambda ()
|
|---|
| 737 | + (for-each (lambda (x) (write x) (newline)) db)))
|
|---|
| 738 | + (copy-file dbfile (make-pathname path +module-db+) #t ".") ;; repos are relative to CWD
|
|---|
| 739 | + (remove-directory tmpdir))))
|
|---|
| 740 | +
|
|---|
| 741 | + (define (update-db-all)
|
|---|
| 742 | + (for-each update-db (repository-pathspec)))
|
|---|
| 743 |
|
|---|
| 744 | (define (apply-mappings eggs)
|
|---|
| 745 | (define (canonical x)
|
|---|
| 746 | @@ -647,7 +658,7 @@ EOF
|
|---|
| 747 | (cond ((and *deploy* (not *prefix*))
|
|---|
| 748 | (error
|
|---|
| 749 | "`-deploy' only makes sense in combination with `-prefix DIRECTORY`"))
|
|---|
| 750 | - (update (update-db))
|
|---|
| 751 | + (update (update-db-all))
|
|---|
| 752 | (else
|
|---|
| 753 | (let ((defaults (load-defaults)))
|
|---|
| 754 | (when (null? eggs)
|
|---|
| 755 | --
|
|---|
| 756 | 2.2.1
|
|---|
| 757 |
|
|---|
| 758 |
|
|---|
| 759 | From b281bc3fe0c543c1358d29398647709e00f6c0ec Mon Sep 17 00:00:00 2001
|
|---|
| 760 | From: Jim Ursetto <zbigniewsz@gmail.com>
|
|---|
| 761 | Date: Wed, 24 Jul 2013 11:03:39 -0500
|
|---|
| 762 | Subject: [PATCH 13/13] chicken-install: Print every entry in repository
|
|---|
| 763 | pathspec
|
|---|
| 764 |
|
|---|
| 765 | ---
|
|---|
| 766 | chicken-install.scm | 2 +-
|
|---|
| 767 | 1 file changed, 1 insertion(+), 1 deletion(-)
|
|---|
| 768 |
|
|---|
| 769 | diff --git a/chicken-install.scm b/chicken-install.scm
|
|---|
| 770 | index a8d0861..6250d0f 100644
|
|---|
| 771 | --- a/chicken-install.scm
|
|---|
| 772 | +++ b/chicken-install.scm
|
|---|
| 773 | @@ -688,7 +688,7 @@ EOF
|
|---|
| 774 | (string=? arg "--help"))
|
|---|
| 775 | (usage 0))
|
|---|
| 776 | ((string=? arg "-repository")
|
|---|
| 777 | - (print (repository-path))
|
|---|
| 778 | + (print (string-intersperse (repository-pathspec) ";"))
|
|---|
| 779 | (exit 0))
|
|---|
| 780 | ((string=? arg "-force")
|
|---|
| 781 | (set! *force* #t)
|
|---|
| 782 | --
|
|---|
| 783 | 2.2.1
|
|---|
| 784 |
|
|---|
