source: project/release/5/chicken-belt/trunk/chicken-select.scm @ 35758

Last change on this file since 35758 was 35758, checked in by evhan, 2 years ago

chicken-belt: Add C5 port

  • Property svn:executable set to *
File size: 2.9 KB
Line 
1#!/bin/sh
2#| -*- mode: scheme -*-
3exec csi -s $0 "$@"
4|#
5
6(import (chicken format)
7        (chicken file posix)
8        (chicken io)
9        (chicken process)
10        (chicken pathname)
11        (chicken sort)
12        (srfi 1)
13        (srfi 13))
14
15(include "chicken-env.scm")
16
17(assert-chicken-coop-exists)
18
19(define verbose? #f)
20(define target-chicken #f)
21
22(define (available-chickens)
23  (filter (lambda (p) (not (equal? chicken-link p)))
24          (directory chicken-coop)))
25
26(for-each
27  (lambda (arg)
28    (cond ((equal? "-v" arg)
29           (set! verbose? #t))
30          ((member arg (available-chickens))
31           (set! target-chicken arg))
32          (else
33           (fail "Invalid argument: ~S" arg))))
34  (command-line-arguments))
35
36(define (current-chicken path link)
37  (let ((p (make-pathname path link)))
38    (and (symbolic-link? p)
39         (read-symbolic-link p))))
40
41(define (set-current-chicken chicken link)
42  (let ((symlink (make-pathname chicken-coop link)))
43    (when (file-exists? symlink)
44      (delete-file symlink))
45    (create-symbolic-link chicken symlink)))
46
47(define (print-chicken-version chicken)
48  (let* ((csi (make-pathname chicken-coop chicken))
49         (csi (make-pathname csi "bin"))
50         (csi (make-pathname csi "csi")))
51    (with-input-from-pipe
52        (string-concatenate (list csi " -n -p " "'(chicken-version #t)'"))
53      (lambda () (printf "\t~a~%" (read-line))))))
54
55(if target-chicken
56  (set-current-chicken target-chicken chicken-link)
57  (let* ((all-chicks (sort (available-chickens) string<?))
58         (current (list-index (cut equal? (current-chicken chicken-coop chicken-link) <>) all-chicks)))
59    (let select ((abort #f))
60      (if (equal? abort #\return)
61          (begin
62            (print "Aborted.")
63            (exit 0))
64          (begin
65            (for-each (lambda (c n)
66                        (printf "~a [~a]: ~a~%"
67                                (if (equal? n current) "->" "  ")
68                                n c)
69                        (when verbose?
70                          (print-chicken-version c)))
71                      all-chicks
72                      (iota (length all-chicks)))
73            (newline)
74            (print* "Select a new Chicken, press ENTER to abort: ")
75            (let ((choice-raw (read-line)))
76              (if (equal? choice-raw "")
77                  (exit)
78                  (let ((num (string->number choice-raw)))
79                    (if (and
80                         num
81                         (<= 0 num)
82                         (< num (length all-chicks)))
83                        (begin
84                          (print "Setting current Chicken to " (list-ref all-chicks num))
85                          (set-current-chicken (list-ref all-chicks
86                                                         num)
87                                               chicken-link))
88                        (select choice-raw))))))))))
Note: See TracBrowser for help on using the repository browser.