Ticket #736: chicken-repo-multispec.patch.txt

File chicken-repo-multispec.patch.txt, 25.3 KB (added by Jim Ursetto, 8 years ago)

Chicken repository multispec implementation

Line 
1From 520c6d44dbe916555e3b8b3ad3d50d82b3ac2aec Mon Sep 17 00:00:00 2001
2From: Jim Ursetto <jim@3e8.org>
3Date: Sun, 1 Jan 2012 02:22:19 -0600
4Subject: [PATCH 01/13] Add initial repository pathspec code
5
6Add repository-pathspec list which splits CHICKEN_REPOSITORY on :,
7and have repository-path return the car.  Empty path elements are
8replaced with the default repository path (i.e. the path if
9the env var is not set).  However, if a private repository is
10active, 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
16diff --git a/chicken.import.scm b/chicken.import.scm
17index 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
28diff --git a/eval.scm b/eval.scm
29index 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--
932.2.1
94
95
96From a80847ffa4b259547c0b6b3e1c8999bc4e38aed8 Mon Sep 17 00:00:00 2001
97From: Jim Ursetto <jim@3e8.org>
98Date: Sun, 1 Jan 2012 02:55:14 -0600
99Subject: [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
106diff --git a/eval.scm b/eval.scm
107index 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--
1202.2.1
121
122
123From e7eb8d318cc49ae5843456b847e2fb008cbfbf50 Mon Sep 17 00:00:00 2001
124From: Jim Ursetto <zbigniewsz@gmail.com>
125Date: Mon, 2 Jan 2012 00:41:14 -0600
126Subject: [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
133diff --git a/chicken-status.scm b/chicken-status.scm
134index 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--
2272.2.1
228
229
230From 9dfae2f7d7b803e0bcc83c8dda75f3b0ff556c4b Mon Sep 17 00:00:00 2001
231From: Jim Ursetto <zbigniewsz@gmail.com>
232Date: Mon, 2 Jan 2012 01:22:56 -0600
233Subject: [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
240diff --git a/eval.scm b/eval.scm
241index 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--
2662.2.1
267
268
269From 71d904f7e1f5adfa08488865a394459398f6829e Mon Sep 17 00:00:00 2001
270From: Jim Ursetto <zbigniewsz@gmail.com>
271Date: Mon, 2 Jan 2012 01:37:45 -0600
272Subject: [PATCH 05/13] Update ##sys#find-extension to search
273 repository-pathspec.
274
275We 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
277when CHICKEN_REPOSITORY is explicitly set and require the user to add it to
278the path, but that may also break things.
279---
280 eval.scm | 6 +++---
281 1 file changed, 3 insertions(+), 3 deletions(-)
282
283diff --git a/eval.scm b/eval.scm
284index 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--
3102.2.1
311
312
313From c8b69f40088f7b9db8843e9a02b9dde269308f3f Mon Sep 17 00:00:00 2001
314From: Jim Ursetto <zbigniewsz@gmail.com>
315Date: Mon, 2 Jan 2012 17:40:32 -0600
316Subject: [PATCH 06/13] Update resolve-include-filename to follow repository
317 pathspec (when searching repository)
318
319Retains the current behavior of always searching CWD first.  Only relevant
320when 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
326diff --git a/eval.scm b/eval.scm
327index 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--
3452.2.1
346
347
348From 3b1dcad69662021b78e79111e2d4ef7da6e13737 Mon Sep 17 00:00:00 2001
349From: Jim Ursetto <zbigniewsz@gmail.com>
350Date: Mon, 2 Jan 2012 17:48:54 -0600
351Subject: [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
357diff --git a/csi.scm b/csi.scm
358index 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--
3712.2.1
372
373
374From 0ddd9371d566bbebe564d21f29ae4bfd667fb34b Mon Sep 17 00:00:00 2001
375From: Jim Ursetto <zbigniewsz@gmail.com>
376Date: Tue, 3 Jan 2012 01:17:35 -0600
377Subject: [PATCH 08/13] Update load-identifier-database to load the database
378 from all repository paths
379
380Paths are traversed in order and all identifiers from shadowed modules are
381ignored.  Here, a shadowed module is simply one whose name appears in an
382earlier identifier database; the installed module files are not considered.
383---
384 support.scm | 37 ++++++++++++++++++++++++++-----------
385 1 file changed, 26 insertions(+), 11 deletions(-)
386
387diff --git a/support.scm b/support.scm
388index 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--
4382.2.1
439
440
441From c041bc25d68255fbba7e37338996226c1ed67ab2 Mon Sep 17 00:00:00 2001
442From: Jim Ursetto <zbigniewsz@gmail.com>
443Date: Tue, 3 Jan 2012 01:38:31 -0600
444Subject: [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
450diff --git a/support.scm b/support.scm
451index 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--
4772.2.1
478
479
480From 81f3f79bb80124134f868813cc3c35243cb4339c Mon Sep 17 00:00:00 2001
481From: Jim Ursetto <zbigniewsz@gmail.com>
482Date: Fri, 6 Jan 2012 23:06:45 -0600
483Subject: [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
490diff --git a/expand.scm b/expand.scm
491index 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--
5272.2.1
528
529
530From 263b8249bf3374ab3bb9692b23587c43f5931098 Mon Sep 17 00:00:00 2001
531From: Jim Ursetto <zbigniewsz@gmail.com>
532Date: Fri, 6 Jan 2012 23:07:17 -0600
533Subject: [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
540diff --git a/eval.scm b/eval.scm
541index 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--
6452.2.1
646
647
648From b0f10e8bbe195ba46f749d152211ef7f5ace431f Mon Sep 17 00:00:00 2001
649From: Jim Ursetto <zbigniewsz@gmail.com>
650Date: Sat, 7 Jan 2012 00:32:06 -0600
651Subject: [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
658diff --git a/chicken-install.scm b/chicken-install.scm
659index 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--
7562.2.1
757
758
759From b281bc3fe0c543c1358d29398647709e00f6c0ec Mon Sep 17 00:00:00 2001
760From: Jim Ursetto <zbigniewsz@gmail.com>
761Date: Wed, 24 Jul 2013 11:03:39 -0500
762Subject: [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
769diff --git a/chicken-install.scm b/chicken-install.scm
770index 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--
7832.2.1
784