| 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 | |
|---|
