~ chicken-core (chicken-5) a023effefa9a8edaad97e5082ba6d0696cede46a

commit a023effefa9a8edaad97e5082ba6d0696cede46a
Author:     felix <felix@call-with-current-continuation.org>
AuthorDate: Sun Jul 17 14:10:55 2016 +0200
Commit:     felix <felix@call-with-current-continuation.org>
CommitDate: Sun Jul 17 14:11:46 2016 +0200

    more options, more complete rec. retrieval

diff --git a/egg-compile.scm b/egg-compile.scm
index 5ed02841..d6bc8831 100644
--- a/egg-compile.scm
+++ b/egg-compile.scm
@@ -49,9 +49,13 @@
 
 ;;; load egg-info from file and perform validation
 
-(define (load-egg-info fname)
+(define (load-egg-info fname #!optional (validate #t))
   (with-input-from-file fname
-    (lambda () (validate-egg-info (read)))))
+    (lambda () 
+      (let ((info (read)))
+        (if validate
+            (validate-egg-info info)
+            info)))))
 
 
 ;;; lookup specific entries in egg-information
diff --git a/new-install.scm b/new-install.scm
index a7469199..2430a6c5 100644
--- a/new-install.scm
+++ b/new-install.scm
@@ -24,6 +24,7 @@
 (define +timestamp-file+ "TIMESTAMP")
 (define +status-file+ "STATUS")
 (define +egg-extension+ "egg")
+(define +egg-info-extension+ "egg.info")
 
 (include "mini-srfi-1.scm")
 (include "egg-environment.scm")
@@ -48,6 +49,8 @@
 (define checked-eggs '())
 (define run-tests #f)
 (define force-install #f)
+(define host-extension cross-chicken)
+(define target-extension cross-chicken)
   
 (define platform
   (if (eq? 'mingw (build-platform))
@@ -69,7 +72,13 @@
                      (probe-dir "/Temp")
                      ".")
                  ".chicken-install.cache"))
-  
+
+(define (repo-path)
+  (destination-repository
+    (if (and cross-chicken (not host-extension))
+        'target
+        'host)))
+
   
 ;; usage information
   
@@ -438,6 +447,20 @@
                    dep)
           (values #f #f))))
 
+(define (ext-version x)
+  (cond ((or (eq? x 'chicken) (equal? x "chicken"))
+         (chicken-version))
+        ((let* ((ep (##sys#canonicalize-extension-path x 'ext-version))
+                (sf (make-pathname (repo-path) ep +egg-info-extension+)))
+           (and (file-exists? sf)
+                (load-egg-info sf #f))) =>
+         (lambda (info)
+           (let ((a (assq 'version info)))
+             (if a
+                 (->string (cadr a))
+                 "0.0.0"))))
+        (else #f)))
+
 (define (check-platform name info)
   (define (fail)
     (error "extension is not targeted for this system" name))
@@ -565,6 +588,12 @@
                   ((equal? arg "-force")
                    (set! force-install #t)
                    (loop (cdr args)))
+                  ((equal? arg "-host")
+                   (set! target-extension #f)
+                   (loop (cdr args)))
+                  ((equal? arg "-target")
+                   (set! host-extension #f)
+                   (loop (cdr args)))
 
                   ;;XXX