~ chicken-core (chicken-5) e07470995153c8aead1daaab42f9f69bb2312432

commit e07470995153c8aead1daaab42f9f69bb2312432
Author:     felix <felix@call-with-current-continuation.org>
AuthorDate: Tue Feb 23 23:15:23 2010 +0100
Commit:     felix <felix@call-with-current-continuation.org>
CommitDate: Tue Feb 23 23:15:23 2010 +0100

    fixes and enhancements for mini-salmonella; -prefix for chicken-install may be relative; platform meta prop.

diff --git a/chicken-install.scm b/chicken-install.scm
index 933a44e2..cbe90004 100644
--- a/chicken-install.scm
+++ b/chicken-install.scm
@@ -283,6 +283,8 @@
            (let ([mfile (make-pathname (cadr e+d+v) (car e+d+v) "meta")])
              (cond [(file-exists? mfile)
                     (let ([meta (with-input-from-file mfile read)])
+		      (print "checking platform for `" (car e+d+v) "' ...")
+		      (check-platform (car e+d+v) meta)
                       (print "checking dependencies for `" (car e+d+v) "' ...")
                       (let-values ([(missing upgrade) (outdated-dependencies meta)])
 			(set! missing (apply-mappings missing)) ;XXX only missing - wrong?
@@ -318,6 +320,24 @@
                       "- assuming it has no dependencies")) ] ) ) ) )
        *eggs+dirs+vers*) ) )
 
+  (define (check-platform name meta)
+    (define (fail)
+      (error "extension is not targeted for this system" name))
+    (unless (feature? #:cross-chicken)
+      (and-let* ((platform (assq 'platform meta)))
+	(let loop ((p (cadr platform)))
+	  (cond ((symbol? p) 
+		 (or (feature? p) (fail)))
+		((not (list? p))
+		 (error "invalid `platform' property" name (cadr platform)))
+		((and (eq? 'not (car p)) (pair? (cdr p)))
+		 (and (not (loop (cadr p))) (fail)))
+		((eq? 'and (car p))
+		 (and (every loop (cdr p)) (fail)))
+		((eq? 'or (car p))
+		 (and (not (any? loop (cdr p))) (fail)))
+		(else (error "invalid `platform' property" name (cadr platform))))))))
+
   (define (make-install-command e+d+v dep?)
     (conc
      *csi*
@@ -531,7 +551,12 @@ EOF
                         (loop (cddr args) eggs))
                        ((or (string=? arg "-p") (string=? arg "-prefix"))
                         (unless (pair? (cdr args)) (usage 1))
-                        (set! *prefix* (cadr args))
+                        (set! *prefix* 
+			  (let ((p (cadr args)))
+			    (if (absolute-pathname? p)
+				p
+				(normalize-pathname 
+				 (make-pathname (current-directory) p) ) ) ) )
                         (loop (cddr args) eggs))
                        ((or (string=? arg "-n") (string=? arg "-no-install"))
                         (set! *keep* #t)
diff --git a/files.scm b/files.scm
index ea9adec6..b87df181 100644
--- a/files.scm
+++ b/files.scm
@@ -172,6 +172,7 @@
 (define absolute-pathname-root)
 (define root-origin)
 (define root-directory)
+
 (let ((string-match string-match))
   (if ##sys#windows-platform
       (let ((rx (regexp "([A-Za-z]:)?([\\/\\\\]).*")))
diff --git a/scripts/mini-salmonella.scm b/scripts/mini-salmonella.scm
index 486c5e12..568bd5f6 100644
--- a/scripts/mini-salmonella.scm
+++ b/scripts/mini-salmonella.scm
@@ -7,22 +7,26 @@
 (use posix files extras data-structures srfi-1 setup-api srfi-13 utils)
 
 (define (usage code)
-  (print "usage: mini-salmonella [-h] [-t] [-d] [-f] EGGDIR [PREFIX]")
+  (print "usage: mini-salmonella [-h] [-test] [-debug] [-download] [-trunk] EGGDIR [PREFIX]")
   (exit code) )
 
 (define *eggdir* #f)
 (define *debug* #f)
-(define *prefix* (pathname-directory (pathname-directory (repository-path))))
 (define *run-tests* #f)
 (define *download* #f)
+(define *trunk* #f)
+
+(define *prefix* 
+  (pathname-directory (pathname-directory (pathname-directory (repository-path)))))
 
 (let loop ((args (command-line-arguments)))
   (when (pair? args)
     (let ((arg (car args)))
       (cond ((string=? "-h" arg) (usage 0))
-	    ((string=? "-t" arg) (set! *run-tests* #t))
-	    ((string=? "-d" arg) (set! *debug* #t))
-	    ((string=? "-f" arg) (set! *download* #t))
+	    ((string=? "-test" arg) (set! *run-tests* #t))
+	    ((string=? "-debug" arg) (set! *debug* #t))
+	    ((string=? "-download" arg) (set! *download* #t))
+	    ((string=? "-trunk" arg) (set! *trunk* #t))
 	    (*eggdir* (set! *prefix* arg))
 	    (else (set! *eggdir* arg)))
       (loop (cdr args)))))
@@ -51,12 +55,13 @@
   (let* ((ed (make-pathname *eggdir* egg))
 	 (tagsdir (directory-exists? (make-pathname ed "tags")))
 	 (trunkdir (directory-exists? (make-pathname ed "trunk"))))
-    (if tagsdir
-	(let ((tags (sort (directory tagsdir) version>=?)))
-	  (if (null? tags)
-	      (or trunkdir ed)
-	      (make-pathname ed (string-append "tags/" (first tags)))))
-	(or trunkdir ed))))
+    (cond ((and *trunk* trunkdir) trunkdir)
+	  (tagsdir
+	   (let ((tags (sort (directory tagsdir) version>=?)))
+	     (if (null? tags)
+		 (or trunkdir ed)
+		 (make-pathname ed (string-append "tags/" (first tags))))))
+	  (else ed))))
 
 (define (report egg msg . args)
   (printf "~a..~?~%" (make-string (max 2 (- 32 (string-length egg))) #\.)
@@ -86,7 +91,7 @@
 		  (if *run-tests* "-test" "")
 		  (if *download* 
 		      ""
-		      (string-append "-l " (normalize-pathname *eggdir*)))
+		      (string-append "-t local -l " (normalize-pathname *eggdir*)))
 		  egg
 		  (if (not *debug*)
 		      (sprintf "2>~a >>~a.out" *tmplogfile* *logfile*)