~ chicken-core (chicken-5) 9acd98d4386fa1373bfef766a2881efe19dfeee6

commit 9acd98d4386fa1373bfef766a2881efe19dfeee6
Author:     felix <felix@call-with-current-continuation.org>
AuthorDate: Sun Jun 6 13:19:09 2010 +0200
Commit:     felix <felix@call-with-current-continuation.org>
CommitDate: Sun Jun 6 13:19:09 2010 +0200

    added aliases to setup.defaults

diff --git a/chicken-install.scm b/chicken-install.scm
index 59254487..5d4ab735 100644
--- a/chicken-install.scm
+++ b/chicken-install.scm
@@ -87,6 +87,7 @@
   (define *trunk* #f)
   (define *csc-features* '())
   (define *prefix* #f)
+  (define *aliases* '())
 
   (define (get-prefix)
     (cond ((and (feature? #:cross-chicken)
@@ -122,10 +123,27 @@
 			       (let-values (((from to) (split-at m p)))
 				 (cons from (cdr to)))))
 			   (cdr x)))))
+		  ((alias)
+		   (set! *aliases*
+		     (append 
+		      *aliases*
+		      (map (lambda (a)
+			     (if (and (list? a) (= 2 (length a)) (every string? a))
+				 (cons (car a) (cadr a))
+				 (broken x)))
+			   (cdr x)))))
 		  (else (broken x))))
 	      (read-file deff))))
       (pair? *default-sources*) ))
 
+  (define (resolve-location name)
+    (cond ((assoc name *aliases*) => 
+	   (lambda (a)
+	     (let ((new (cdr a)))
+	       (print "resolving alias " name " to: " new)
+	       (resolve-location new))))
+	  (else name)))
+
   (define (known-default-sources)
     (if (and *default-location* *default-transport*)
         `(((location 
@@ -248,8 +266,9 @@
       (if (null? defs)
           (values #f "")
           (let* ([def (car defs)]
-                 [locn (cadr (or (assq 'location def)
-                                 (error "missing location entry" def)))]
+                 [locn (resolve-location
+			(cadr (or (assq 'location def)
+				  (error "missing location entry" def))))]
                  [trans (cadr (or (assq 'transport def)
                                   (error "missing transport entry" def)))])
             (let-values ([(dir ver) (try-extension name version trans locn)])
diff --git a/setup.defaults b/setup.defaults
index 779a4cbe..cac61eb1 100644
--- a/setup.defaults
+++ b/setup.defaults
@@ -1,16 +1,35 @@
 ;;;; setup.defaults - defaults for chicken-install -*- Scheme -*-
 
+
+;; list of servers in the order in which they will be processed
+;
+; (server (location URL) (transport TRANSPORT))
+
 (server
- (location "http://chicken.kitten-technologies.co.uk/henrietta.cgi")
+ (location "kitten-technologies")
  (transport http))
 
 (server
- (location "http://galinha.ucpel.tche.br/cgi-bin/henrietta")
+ (location "galinha")
  (transport http))
 
+
+;; extensions-mappings
+;
+; (map (EXTENSIONNAME ... -> OTHEREXTENSIONNAME ...))
+
 (map
  (data-structures 
   extras files foreign irregex lolevel ports tcp utils
   posix regex setup-api setup-download
   srfi-1 srfi-4 srfi-13 srfi-14 srfi-18 srfi-69 
   ->) )
+
+
+;; aliases for locations
+;
+; (alias (NAME REALNAME) ...)
+
+(alias 
+ ("galinha" "http://galinha.ucpel.tche.br/cgi-bin/henrietta")
+ ("kitten-technologies" "http://chicken.kitten-technologies.co.uk/henrietta.cgi"))