~ chicken-core (chicken-5) c63f9db3dc9abf38f78ca59c0441cab8f50b3dbd
commit c63f9db3dc9abf38f78ca59c0441cab8f50b3dbd
Author: felix <felix@call-with-current-continuation.org>
AuthorDate: Thu Jun 10 00:56:34 2010 +0200
Commit: felix <felix@call-with-current-continuation.org>
CommitDate: Thu Jun 10 00:56:34 2010 +0200
several fixes to host/target specific egg tool processing
diff --git a/chicken-status.scm b/chicken-status.scm
index 6ff31bbf..a245252f 100644
--- a/chicken-status.scm
+++ b/chicken-status.scm
@@ -74,7 +74,7 @@
(let ((w (quotient (- (get-terminal-width) 2) 2)))
(for-each
(lambda (egg)
- (let ((version (assq 'version (read-info egg))))
+ (let ((version (assq 'version (read-info egg (repo-path)))))
(if version
(print
(format-string (string-append egg " ") w #f #\.)
@@ -90,7 +90,7 @@
(sort
(append-map
(lambda (egg)
- (let ((files (assq 'files (read-info egg))))
+ (let ((files (assq 'files (read-info egg (repo-path)))))
(if files
(cdr files)
'())))
@@ -116,19 +116,19 @@ EOF
(let ((files #f))
(let loop ((args args) (pats '()))
(if (null? args)
- (let* ((patterns (if (null? pats) '(".*") pats))
- (eggs1 (gather-eggs patterns))
- (eggs
- (if (and *host-extensions* *target-extensions*)
- (append
- eggs1
- (fluid-let ((*host-extensions* #f))
- (gather-eggs patterns)))
- eggs1)))
- (if (null? eggs)
- (print "(none)")
- ((if files list-installed-files list-installed-eggs)
- eggs)))
+ (let ((status
+ (lambda ()
+ (let* ((patterns (if (null? pats) '(".*") pats))
+ (eggs (gather-eggs patterns)))
+ (if (null? eggs)
+ (print "(none)")
+ ((if files list-installed-files list-installed-eggs)
+ eggs))))))
+ (cond ((and *host-extensions* *target-extensions*)
+ (status)
+ (fluid-let ((*host-extensions* #f))
+ (status)))
+ (else (status))))
(let ((arg (car args)))
(cond ((or (string=? arg "-help")
(string=? arg "-h")
diff --git a/chicken-uninstall.scm b/chicken-uninstall.scm
index 268ff9c3..fb232b13 100644
--- a/chicken-uninstall.scm
+++ b/chicken-uninstall.scm
@@ -82,11 +82,11 @@
(for-each
(lambda (e)
(print "removing " e)
- (when *host-extensions*
- (remove-extension e))
- (when *target-extensions*
- (fluid-let ((*host-extensions* #f))
- (remove-extension e (repo-path)) )))
+ (cond ((and *host-extensions* *target-extensions*)
+ (remove-extension e)
+ (fluid-let ((*host-extensions* #f))
+ (remove-extension e (repo-path)) ))
+ (else (remove-extension e (repo-path)))))
eggs)))))
(define (usage code)
diff --git a/setup-api.scm b/setup-api.scm
index 1fb8e744..9f2cb310 100644
--- a/setup-api.scm
+++ b/setup-api.scm
@@ -562,7 +562,7 @@
(equal? (cadr static) from)
(equal? (pathname-extension to) "a"))
(run (,*ranlib-command* ,(shellpath to)) ) ))
- (make-dest-pathname rpath f)))
+ to))
files) ) )
(write-info id dests info) ) ) )
@@ -746,9 +746,9 @@
(and defver (->string defver))
ver ) ) )
-(define (read-info egg)
+(define (read-info egg #!optional (repo (repository-path)))
(with-input-from-file
- (make-pathname (repository-path) egg ".setup-info")
+ (make-pathname repo egg setup-file-extension)
read))
(define (remove-directory dir #!optional (strict #t))
@@ -772,9 +772,9 @@
(delete-directory dir)))) ))
(define (remove-extension egg #!optional (repo (repository-path)))
- (and-let* ((files (assq 'files (read-info egg))))
+ (and-let* ((files (assq 'files (read-info egg repo))))
(for-each remove-file* (cdr files)))
- (remove-file* (make-pathname repo egg "setup-info")))
+ (remove-file* (make-pathname repo egg setup-file-extension)))
(define ($system str)
(let ((r (system
Trap