Changeset 10375 in project


Ignore:
Timestamp:
04/07/08 14:00:59 (11 years ago)
Author:
felix
Message:

removed uses of match

Location:
chicken/branches/beyond-hope
Files:
5 edited

Legend:

Unmodified
Added
Removed
  • chicken/branches/beyond-hope/batch-driver.scm

    r8361 r10375  
    235235    (when (memq 'optimize-leaf-routines options) (set! optimize-leaf-routines #t))
    236236    (when (memq 'unsafe options)
    237       (set! unsafe #t)
    238       (##match#set-error-control #:fail) )
     237      (set! unsafe #t) )
    239238    (when (and dynamic (memq 'unsafe-libraries options))
    240239      (set! emit-unsafe-marker #t) )
     
    292291
    293292    (set! ##sys#features (cons '#:compiling ##sys#features))
    294     (set! ##sys#features (cons #:match ##sys#features))
    295     (##sys#provide 'match)
    296293    (set! upap (user-post-analysis-pass))
    297294
  • chicken/branches/beyond-hope/chicken-bug.scm

    r8361 r10375  
    144144      (set! msg (string-append msg "\n\n" (user-input))))
    145145    (newline)
    146     (match-let ((#(_ _ _ day mon yr _ _ _ _) (seconds->local-time (current-seconds))))
    147         (if stdout
    148             (begin
    149                 (print msg)
    150                 (collect-info))
    151             (try-mail
    152                 +mxservers+
    153                 (sprintf +bug-report-file+ (+ 1900 yr) (justify mon) (justify day))
    154                 (mail-headers)
    155                 (with-output-to-string
    156                     (lambda ()
    157                         (print msg)
    158                         (collect-info))))))))
     146    (let* ((lt (seconds->local-time (current-seconds)))
     147           (day (vector-ref lt 3))
     148           (mon (vector-ref lt 4))
     149           (yr (vector-ref lt 5)) )
     150      (if stdout
     151          (begin
     152            (print msg)
     153            (collect-info))
     154          (try-mail
     155           +mxservers+
     156           (sprintf +bug-report-file+ (+ 1900 yr) (justify mon) (justify day))
     157           (mail-headers)
     158           (with-output-to-string
     159             (lambda ()
     160               (print msg)
     161               (collect-info))))))))
    159162      ;(let* ((file (sprintf +bug-report-file+ (+ 1900 yr) (justify mon) (justify day)))
    160163        ;     (port (if stdout (current-output-port) (open-output-file file))))
  • chicken/branches/beyond-hope/chicken-profile.scm

    r8361 r10375  
    8989            (let ((n (string->number (next-arg))))
    9090              (if (and n (> n 0)) n (error "invalid argument to option" arg))))
    91           (match arg
    92             [(or "-h" "-help" "--help") (print-usage)]
    93             [(or "-v" "-version")
    94              (print "chicken-profile - Version " (chicken-version))
    95              (exit) ]
    96             ["-release"
    97              (print (chicken-version))
    98              (exit) ]
    99             ["-no-unused" (set! no-unused #t)]
    100             ["-top" (set! top (next-number))]
    101             ["-sort-by-calls" (set! sort-by sort-by-calls)]
    102             ["-sort-by-time" (set! sort-by sort-by-time)]
    103             ["-sort-by-avg" (set! sort-by sort-by-avg)]
    104             ["-sort-by-name" (set! sort-by sort-by-name)]
    105             ["-decimals" (set-decimals (next-arg))]
    106             [_ (cond [(and (> (string-length arg) 1) (char=? #\- (string-ref arg 0)))
    107                       (error "invalid option" arg) ]
    108                      [file (print-usage)]
    109                      [else (set! file arg)] ) ] )
     91          (cond
     92           [(member arg '("-h" "-help" "--help")) (print-usage)]
     93           [(member arg '("-v" "-version"))
     94            (print "chicken-profile - Version " (chicken-version))
     95            (exit) ]
     96           [(string=? arg "-release")
     97            (print (chicken-version))
     98            (exit) ]
     99           [(string=? arg "-no-unused") (set! no-unused #t)]
     100           [(string=? arg "-top") (set! top (next-number))]
     101           [(string=? arg "-sort-by-calls") (set! sort-by sort-by-calls)]
     102           [(string=? arg "-sort-by-time") (set! sort-by sort-by-time)]
     103           [(string=? arg "-sort-by-avg") (set! sort-by sort-by-avg)]
     104           [(string=? arg "-sort-by-name") (set! sort-by sort-by-name)]
     105           [(string=? arg "-decimals") (set-decimals (next-arg))]
     106           [(and (> (string-length arg) 1) (char=? #\- (string-ref arg 0)))
     107            (error "invalid option" arg) ]
     108           [file (print-usage)]
     109           [else (set! file arg)] )
    110110          (loop rest) ) ) ) )
    111111
  • chicken/branches/beyond-hope/chicken-setup.scm

    r9533 r10375  
    2828(declare
    2929  (run-time-macros)
    30   (uses srfi-1 regex utils posix tcp match srfi-18 srfi-13)
     30  (uses srfi-1 regex utils posix tcp srfi-18 srfi-13)
    3131  (export move-file run:execute make/proc uninstall-extension
    3232          install-extension install-program install-script setup-verbose-flag
     
    158158(define chicken-prefix
    159159  (or (getenv "CHICKEN_PREFIX")
    160       (match (string-match "(.*)/bin/?" chicken-bin-path)
    161              ((_ p) p)
    162              (_ "/usr/local") ) ) )
     160      (let ((m (string-match "(.*)/bin/?" chicken-bin-path)))
     161        (if m
     162            (cadr m)
     163            "/usr/local") ) ) )
    163164
    164165(define example-path
     
    270271(define (patch which rx subst)
    271272  (when (setup-verbose-flag) (printf "patching ~A ...~%" which))
    272   (match which
    273     ((from to)
    274      (with-output-to-file to
     273  (if (list? which)
     274      (with-output-to-file (cadr which)
    275275       (lambda ()
    276          (with-input-from-file from
     276         (with-input-from-file (car which)
    277277           (lambda ()
    278278             (let loop ()
     
    280280                 (unless (eof-object? ln)
    281281                   (write-line (string-substitute rx subst ln #t))
    282                    (loop) ) ) ) ) ) ) ) )
    283     (both
    284      (let ((tmp (create-temporary-file)))
    285        (patch (list both tmp) rx subst)
    286        (system* "~A ~A ~A" *move-command* (quotewrap tmp) (quotewrap both) ) ) ) ) )
     282                   (loop) ) ) ) ) ) ) )
     283      (let ((tmp (create-temporary-file)))
     284        (patch (list both tmp) rx subst)
     285        (system* "~A ~A ~A" *move-command* (quotewrap tmp)
     286                 (quotewrap which)))))
    287287
    288288(define run-verbose (make-parameter #t))
     
    689689
    690690(define (make-dest-pathname path file)
    691   (match file
    692     ((from to) (make-dest-pathname path to))
    693     (_ (if (absolute-pathname? file)
    694            file
    695            (make-pathname path file) ) ) ) )
     691  (if (list? file)
     692      (make-dest-pathname path (cadr file))
     693      (if (absolute-pathname? file)
     694          file
     695          (make-pathname path file) ) ) )
    696696
    697697(define (check-filelist flist)
    698698  (map (lambda (f)
    699          (match f
    700            ((? string?) f)
    701            (((? string?) (? string?)) f)
    702            (((? string? h) . (? string? t)) (list h t))
    703            (_ (error "invalid file-specification" f)) ) )
     699         (cond ((string? f) f)
     700               ((and (list? f) (every string? f)) f)
     701               ((and (pair? f) (list (car f) (cdr f))))
     702               (else (error "invalid file-specification" f)) ) )
    704703       flist) )
    705704
    706705(define (translate-extension f #!optional default)
    707706  (pathname-replace-extension f
    708    (match (pathname-extension f)
    709      (#f default)
    710      ("so" ##sys#load-dynamic-extension)
    711      ("a" (if *windows-shell* "lib" "a"))
    712      (x x) ) ) )
     707   (let ((ext (pathname-extension f)))
     708     (cond ((not ext) default)
     709           ((equal? "so" ext) ##sys#load-dynamic-extension)
     710           ((equal? "a" ext) (if *windows-shell* "lib" "a"))
     711           (else ext)))))
    713712
    714713
     
    874873(define (required-extension-version . args)
    875874  (let loop ((args args))
    876     (match args
    877       (() #f)
    878       ((ext version . more)
    879        (let ((info (extension-information ext))
    880              (version (->string version)) )
    881          (if info
    882              (let ((ver (and (assq 'version info) (cadr (assq 'version info)))))
    883                (cond ((not ver) (upgrade-message ext "has no associated version information"))
    884                      ((string-ci<? (->string ver) version)
    885                       (upgrade-message
    886                        ext
    887                        (sprintf "is older than ~a, which is what this extension requires"
    888                                 version) ) )
    889                      (else (loop more)) ) )
    890              (upgrade-message ext "is not installed") ) ) )
    891       (_ (error 'required-extension-information "bad argument format" args)) ) ) )
     875    (cond ((null? args) #f)
     876          ((and (list? args) (>= (length args) 2))
     877           (let* ((ext (car args))
     878                  (version (cadr args))
     879                  (more (cddr args))
     880                  (info (extension-information ext))
     881                  (version (->string version)) )
     882             (if info
     883                 (let ((ver (and (assq 'version info) (cadr (assq 'version info)))))
     884                   (cond ((not ver) (upgrade-message ext "has no associated version information"))
     885                         ((string-ci<? (->string ver) version)
     886                          (upgrade-message
     887                           ext
     888                           (sprintf "is older than ~a, which is what this extension requires"
     889                                    version) ) )
     890                         (else (loop more)) ) )
     891                 (upgrade-message ext "is not installed") ) ) )
     892          (else
     893           (error 'required-extension-information "bad argument format" args)) ) ) )
    892894
    893895(define test-compile try-compile)
     
    930932      (if (null? hosts)
    931933          (error "unable to connect")
    932           (match hosts
    933             (((host path port) . more)
    934              (call/cc
    935               (lambda (return)
    936                 (or (handle-exceptions ex
    937                       (begin (printf "could not connect to ~A.~%" host) #f)
    938                       (when (setup-verbose-flag)
    939                         (printf "downloading catalog from ~A ...~%" host) )
    940                       (let-values (((i o) (setup-tcp-connect host port)))
    941                         (set! *last-decent-host* (car hosts))
    942                         (let ((req (http-get-request path remote-repository-name host)))
    943                           (when (setup-verbose-flag) (display req))
    944                           (display req o) )
    945                         (let ((ln (read-line i)))
    946                           (when (setup-verbose-flag) (print ln))
    947                           (when (string-match "HTTP.+ 404 .+" ln)
    948                             (print "no remote repository available")
    949                             (return #f) ) )
    950                         (let loop ()
    951                           (let ((ln (read-line i)))
    952                             (when (setup-verbose-flag) (print ln))
    953                             (if (string=? "" ln)
    954                                 (begin
    955                                   (set! *repository-tree* (read i))
    956                                   (when *debug*
    957                                     (print "catalog:")
    958                                     (pp *repository-tree*) )
    959                                   (close-input-port i)
    960                                   (close-output-port o)
    961                                   #t)
    962                                 (loop) ) ) ) ) )
    963                     (loop more) ) ) ) )
    964             ((x . _) (error "(internal) invalid host" x)) ) ) ) ) )
     934          (if (and (list? hosts) (= 3 (length hosts)))
     935              (let* ((hpp (car hosts))
     936                     (more (cdr hosts))
     937                     (host (car hpp))
     938                     (path (cadr hpp))
     939                     (port (caddr hpp)))
     940                (call/cc
     941                 (lambda (return)
     942                   (or (handle-exceptions ex
     943                           (begin (printf "could not connect to ~A.~%" host) #f)
     944                         (when (setup-verbose-flag)
     945                           (printf "downloading catalog from ~A ...~%" host) )
     946                         (let-values (((i o) (setup-tcp-connect host port)))
     947                           (set! *last-decent-host* (car hosts))
     948                           (let ((req (http-get-request path remote-repository-name host)))
     949                             (when (setup-verbose-flag) (display req))
     950                             (display req o) )
     951                           (let ((ln (read-line i)))
     952                             (when (setup-verbose-flag) (print ln))
     953                             (when (string-match "HTTP.+ 404 .+" ln)
     954                               (print "no remote repository available")
     955                               (return #f) ) )
     956                           (let loop ()
     957                             (let ((ln (read-line i)))
     958                               (when (setup-verbose-flag) (print ln))
     959                               (if (string=? "" ln)
     960                                   (begin
     961                                     (set! *repository-tree* (read i))
     962                                     (when *debug*
     963                                       (print "catalog:")
     964                                       (pp *repository-tree*) )
     965                                     (close-input-port i)
     966                                     (close-output-port o)
     967                                     #t)
     968                                   (loop) ) ) ) ) )
     969                       (loop more) ) ) ) )
     970              (else (error "(internal) invalid host" x)) ) ) ) ) )
    965971
    966972(define *progress-indicator*
     
    986992         (when (setup-verbose-flag) (printf "fetching from local directory ~a ...~%" *local-repository*))
    987993         (let* ((p  (->string item))
    988                (fpath  (make-pathname (setup-download-directory) p "egg-dir")))
     994                (fpath  (make-pathname (setup-download-directory) p "egg-dir")))
    989995           (copy-file (make-pathname *local-repository* p) fpath #t #f)))
    990996
     
    992998         (when (setup-verbose-flag) (printf "fetching from svn repository ~a ...~%" *svn-repository*))
    993999         (let* ((p (->string item))
    994                (fpath (make-pathname (setup-download-directory) p "egg-dir")))
     1000                (fpath (make-pathname (setup-download-directory) p "egg-dir")))
    9951001           (run (svn co ,(if *revision* (conc "--revision " *revision*) "")
    9961002                     ,(make-pathname *svn-repository* p) ,fpath))
    9971003           fpath))
    998 
    9991004        (else
    1000          (match hostdata
    1001            ((host path port)
    1002             (let ((fname (or filename (third (assq item *repository-tree*)))))
    1003               (printf "downloading ~A from ~A ~!" fname hostdata)
    1004               (let-values (((i o) (setup-tcp-connect host port)))
    1005                 (let ((req (http-get-request
    1006                             (if filename (pathname-directory filename) path)
    1007                             (if filename (pathname-strip-directory fname) fname)
    1008                             host) ) )
    1009                   (when *debug* (display req))
    1010                   (display req o) )
    1011                 (let loop ()
    1012                   (let ((ln (read-line i)))
    1013                     ;; check for 404 here...
    1014                     (if (string=? "" ln)
    1015                         (let ((data (with-progress-indicator (cut read-string #f i))))
    1016                           (close-input-port i)
    1017                           (close-output-port o)
    1018                           (if (not (file-exists? (setup-download-directory)))
    1019                               (create-directory (setup-download-directory)))
    1020                           (let ((fpath (make-pathname (setup-download-directory) (pathname-strip-directory fname))))
    1021                             (with-output-to-file fpath
    1022                               (cut display data)
    1023                               binary:)
    1024                             fpath))
    1025                         (loop) ) ) ) ) ) )
    1026            (x (error "(internal) invalid host" x)) ) ) ) )
     1005         (if (and (list? hostdata) (= 3 (length hostdata)))
     1006             (let ((host (car hostdata))
     1007                   (path (cadr hostdata))
     1008                   (port (caddr hostdata)))
     1009               (let ((fname (or filename (third (assq item *repository-tree*)))))
     1010                 (printf "downloading ~A from ~A ~!" fname hostdata)
     1011                 (let-values (((i o) (setup-tcp-connect host port)))
     1012                   (let ((req (http-get-request
     1013                               (if filename (pathname-directory filename) path)
     1014                               (if filename (pathname-strip-directory fname) fname)
     1015                               host) ) )
     1016                     (when *debug* (display req))
     1017                     (display req o) )
     1018                   (let loop ()
     1019                     (let ((ln (read-line i)))
     1020                       ;; check for 404 here...
     1021                       (if (string=? "" ln)
     1022                           (let ((data (with-progress-indicator (cut read-string #f i))))
     1023                             (close-input-port i)
     1024                             (close-output-port o)
     1025                             (if (not (file-exists? (setup-download-directory)))
     1026                                 (create-directory (setup-download-directory)))
     1027                             (let ((fpath (make-pathname (setup-download-directory) (pathname-strip-directory fname))))
     1028                               (with-output-to-file fpath
     1029                                 (cut display data)
     1030                                 binary:)
     1031                               fpath))
     1032                           (loop) ) ) ) ) ) )
     1033             (error "(internal) invalid host" x)) ) ) )
    10271034
    10281035(define (requirements reqs)
     
    12961303  (define (parse-host host eggdir)
    12971304    (set! *repository-hosts*
    1298       (cons (match (string-match "(.+)\\:([0-9]+)" host)
    1299               ((_ host port) (list host (if eggdir *default-eggdir* "") (string->number port)))
    1300               (_ (list host (if eggdir (conc *default-eggdir* "") 80)) ) )
     1305      (cons (let ((m (string-match "(.+)\\:([0-9]+)" host)))
     1306              (if m
     1307                  (list (car m)
     1308                        (if eggdir *default-eggdir* "")
     1309                        (string->number (caddr m)))
     1310                  (list host (if eggdir (conc *default-eggdir* "") 80)) ))
    13011311            *repository-hosts*) )  )
    13021312  (setup-root-directory *base-directory*)
     
    13041314        (anydone #f))
    13051315    (let loop ((args args))
    1306       (match args
    1307         (((or "-help" "--help") . _) (usage))
    1308         (("-uninstall" . more)
    1309          (set! uinst #t)
    1310          (loop more) )
    1311         (("-list" more ...)
    1312          (if (pair? more)
    1313              (for-each
    1314               (lambda (e)
    1315                 (let ((info (extension-information e)))
    1316                   (cond (info
    1317                          (print e ":\n")
    1318                          (pp info)
    1319                          (newline) )
    1320                         (else (print "Warning: No extension named `" e "' installed.\n")) ) ) )
    1321               more)
    1322              (list-installed) )
    1323          (exit) )
    1324         (("-run" fname . more)
    1325          (load fname)
    1326          (loop more) )
    1327         (("-repository")
    1328          (print (repository-path))
    1329          (exit) )
    1330         (("-repository" dir . more)
    1331          (repository-path dir)
    1332          (loop more) )
    1333         (("-tree" file . more)
    1334          (set! *repository-tree* (with-input-from-file file read))
    1335          (loop more) )
    1336         (("--" . more)
    1337          (exit) )
    1338         (("-program-path")
    1339          (print (program-path))
    1340          (exit) )
    1341         (("-install-prefix" path . more)
    1342          (installation-prefix path)
    1343          (loop more) )
    1344         (("-build-prefix" path . more)
    1345          (setup-build-prefix path)
    1346          (loop more) )
    1347         (("-download-path" path . more)
    1348          (setup-download-directory path)
    1349          (loop more) )
    1350         (("-program-path" dir . more)
    1351          (program-path dir)
    1352          (loop more) )
    1353         (("-version" . _)
    1354          (printf "chicken-setup - ~A~%" (chicken-version #t))
    1355          (exit) )
    1356         (("-release" . _)
    1357          (print (chicken-version))
    1358          (exit) )
    1359         (("-script" filename . args)
    1360          (command-line-arguments args)
    1361          (load filename)
    1362          (exit) )
    1363         (("-eval" expr . more)
    1364          (eval `(begin ,@(with-input-from-string expr read-file)))
    1365          (set! anydone #t)
    1366          (loop more) )
    1367         (("-fetch" . more)
    1368          (set! *fetch-only* #t)
    1369          (set! *keep-stuff* #t)
    1370          (loop more) )
    1371         (("-host" host . more)
    1372          (match (string-match "http://(.*)" host)
    1373            ((_ host) (parse-host host #t) )
    1374            (_ (parse-host host #t)) )
    1375          (loop more) )
    1376         (("-proxy" proxy . more)
    1377          (match (string-match "(.+)\\:([0-9]+)" proxy)
    1378            ((_ proxy port) (set! *proxy-host* proxy) (set! *proxy-port* (string->number port)))
    1379            (_ (set! *proxy-host* proxy) (set! *proxy-port* 80)) )
    1380          (loop more) )
    1381         (("-keep" . more)
    1382          (set! *keep-stuff* #t)
    1383          (set! *csc-options* (append *csc-options* (list "-k")))
    1384          (loop more) )
    1385         (("-verbose" . more)
    1386          (setup-verbose-flag #t)
    1387          (set! *csc-options* (append *csc-options* (list "-v")))
    1388          (loop more) )
    1389         (("-csc-option" opt . more)
    1390          (set! *csc-options* (append *csc-options* (list opt)))
    1391          (loop more) )
    1392         (("-ls" ext . more)
    1393          (and-let* ((info (extension-information ext))
    1394                     (files (assq 'files info)) )
    1395            (for-each print (cdr files) ) )
    1396          (exit) )
    1397         (("-dont-ask" . more)
    1398          (set! *dont-ask* #t)
    1399          (loop more) )
    1400         (("-no-install" . more)
    1401          (setup-install-flag #f)
    1402          (set! *keep-stuff* #t)
    1403          (loop more) )
    1404         (("-docindex" . more)
    1405          (let ((di (doc-index #t)))
    1406            (unless (file-exists? di)
    1407              (build-doc-index) )
    1408            (print di) ) )
    1409         (("-debug" . more)
    1410          (set! *debug* #t)
    1411          (loop more) )
    1412         (("-revision" rev . more)
    1413          (set! *revision* rev)
    1414          (loop more) )
    1415         (("-svn" url . more)
    1416          (set! *svn-repository* url)
    1417          (set! *dont-ask* #t)
    1418          (loop more) )
    1419         (("-test" . more)
    1420          (set! *run-tests* #t)
    1421          (loop more) )
    1422         (("-local" path . more)
    1423          (set! *local-repository* path)
    1424          (set! *dont-ask* #t)
    1425          (loop more) )
    1426         (("-create-tree" dir . more)
    1427          (create-repository-file dir)
    1428          (set! anydone #t)
    1429          (loop more) )
    1430         (("-fetch-tree" . more)
    1431          (set! *fetch-tree-only* #t)
    1432          (set! anydone #t)
    1433          (loop more) )
    1434         (("-host-extension" . more)
    1435          (host-extension #t)
    1436          (loop more) )
    1437         (((or "-run" "-script" "-proxy" "-host" "-csc-option" "-ls" "-install-prefix"
    1438               "-tree" "-local" "-svn" "-eval" "-create-tree" "-build-prefix" "-download-dir"))
    1439          (error "missing option argument" (car args)) )
    1440         ((filename . more)
    1441          (cond ((and (> (string-length filename) 0) (char=? #\- (string-ref filename 0)))
    1442                 (let ((os (string->list (substring filename 1))))
    1443                   (if (every (cut memq <> short-options) os)
    1444                       (loop
    1445                        (append
    1446                         (map (lambda (s) (list-ref long-options (list-index (cut eq? <> s) short-options))) os)
    1447                         more) )
    1448                       (error "invalid option" filename) ) ) )
    1449                (else
    1450                 (set! anydone #t)
    1451                 ((if uinst uninstall-extension install)
    1452                  (match (string-match "http://([^/]+)/(.+)" filename)
    1453                    ((_ host path)
    1454                     (parse-host host #f)
    1455                     (set! *dont-ask* #t)
    1456                     (conc "/" path) )
    1457                    (_ filename)) )
    1458                 (loop more) ) ) )
    1459         (()
    1460          (unless anydone
    1461            (let ((setups (glob "*.setup")))
    1462              (if (null? setups)
    1463                  (printf "No setup scripts to process~%")
    1464                  (for-each (if uinst uninstall-extension install) setups) ) ) )
    1465          (when *fetch-tree-only*
    1466            (download-repository-tree)
    1467            (pp *repository-tree*) )
    1468          (when *rebuild-doc-index*
    1469            (when (setup-verbose-flag) (printf "Rebuilding documentation index...\n"))
    1470            (build-doc-index) )
    1471          (unless *keep-stuff*
    1472            (for-each
    1473             (lambda (f)
    1474               (run (,*remove-command* ,(quotewrap f))) )
    1475             *fetched-eggs*))
    1476          #f) ) ) ) )
     1316      (cond ((null? args)
     1317             (unless anydone
     1318               (let ((setups (glob "*.setup")))
     1319                 (if (null? setups)
     1320                     (printf "No setup scripts to process~%")
     1321                     (for-each (if uinst uninstall-extension install) setups) ) ) )
     1322             (when *fetch-tree-only*
     1323               (download-repository-tree)
     1324               (pp *repository-tree*) )
     1325             (when *rebuild-doc-index*
     1326               (when (setup-verbose-flag) (printf "Rebuilding documentation index...\n"))
     1327               (build-doc-index) )
     1328             (unless *keep-stuff*
     1329               (for-each
     1330                (lambda (f)
     1331                  (run (,*remove-command* ,(quotewrap f))) )
     1332                *fetched-eggs*))
     1333             #f)
     1334            (else
     1335             (let ((arg (car args)))
     1336               (cond
     1337                ((member arg '("-help" "--help")) (usage))
     1338                ((string=? "-uninstall" arg)
     1339                 (set! uinst #t)
     1340                 (loop (cdr args)))
     1341                ((string=? arg "-list")
     1342                 (if (pair? (cdr args))
     1343                     (for-each
     1344                      (lambda (e)
     1345                        (let ((info (extension-information e)))
     1346                          (cond (info
     1347                                 (print e ":\n")
     1348                                 (pp info)
     1349                                 (newline) )
     1350                                (else (print "Warning: No extension named `" e "' installed.\n")) ) ) )
     1351                      (cdr args))
     1352                     (list-installed) )
     1353                 (exit) )
     1354                ((and (string=? arg "-run") (pair? (cdr args)))
     1355                 (load (cadr args))
     1356                 (loop (cddr args)))
     1357                ((string=? "-repository" arg)
     1358                 (print (repository-path))
     1359                 (exit) )
     1360                ((and (string=? arg "-repository") (pair? (cdr args)))
     1361                 (repository-path (cadr args))
     1362                 (loop (cddr args)))
     1363                ((and (string=? "-tree" arg) (pair? (cdr args)))
     1364                 (set! *repository-tree* (with-input-from-file (cadr args) read))
     1365                 (loop (cddr args)))
     1366                ((string=? arg "--")
     1367                 (exit) )
     1368                ((string=? arg "-program-path")
     1369                 (print (program-path))
     1370                 (exit) )
     1371                ((and (string=? arg "-install-prefix") (pair? (cdr args)))
     1372                 (installation-prefix (cadr args))
     1373                 (loop (cddr args)))
     1374                ((and (string=? arg "-build-prefix") (pair? (cdr args)))
     1375                 (setup-build-prefix (cadr args))
     1376                 (loop (cddr args)))
     1377                ((and (string=? arg "-download-path") (pair? (cdr args)))
     1378                 (setup-download-directory (cadr args))
     1379                 (loop (cddr args)))
     1380                ((and (string=? arg "-program-path") (pair? (cdr args)))
     1381                 (program-path (cadr args))
     1382                 (loop (cddr args)))
     1383                ((string=? arg "-version")
     1384                 (printf "chicken-setup - ~A~%" (chicken-version #t))
     1385                 (exit) )
     1386                ((string=? "-release" arg)
     1387                 (print (chicken-version))
     1388                 (exit) )
     1389                ((and (string=? arg "-script") (pair? (cdr args)))
     1390                 (command-line-arguments (cddr args))
     1391                 (load (cadr args))
     1392                 (exit) )
     1393                ((and (string=? arg "-eval") (pair? (cdr args)))
     1394                 (eval `(begin ,@(with-input-from-string (cadr args) read-file)))
     1395                 (set! anydone #t)
     1396                 (loop (cddr args)))
     1397                ((string=? arg "-fetch")
     1398                 (set! *fetch-only* #t)
     1399                 (set! *keep-stuff* #t)
     1400                 (loop (cdr args)))
     1401                ((and (string=? arg "-host") (pair? (cdr args)))
     1402                 (let ((m (string-match "http://(.*)" (cadr args))))
     1403                   (if m
     1404                       (parse-host (cadr m) #t)
     1405                       (parse-host host #t)) )
     1406                 (loop (cddr args)))
     1407                ((and (string=? arg "-proxy") (pair? (cdr args)))
     1408                 (let ((m (string-match "(.+)\\:([0-9]+)" (cadr args))))
     1409                   (cond (m (set! *proxy-host* (cadr m))
     1410                            (set! *proxy-port* (string->number (caddr m))))
     1411                         (else (set! *proxy-host* proxy) (set! *proxy-port* 80)) )
     1412                   (loop (cddr args))))
     1413                ((string=? arg "-keep")
     1414                 (set! *keep-stuff* #t)
     1415                 (set! *csc-options* (append *csc-options* (list "-k")))
     1416                 (loop (cdr args)))
     1417                ((string=? arg "-verbose")
     1418                 (setup-verbose-flag #t)
     1419                 (set! *csc-options* (append *csc-options* (list "-v")))
     1420                 (loop (cdr args)))
     1421                ((and (string=? arg "-csc-option") (pair? (cdr args)))
     1422                 (set! *csc-options* (append *csc-options* (list (cadr args))))
     1423                 (loop (cddr args)))
     1424                ((and (string=? arg "-ls") (pair? (cdr args)))
     1425                 (and-let* ((info (extension-information (cadr args)))
     1426                            (files (assq 'files info)) )
     1427                   (for-each print (cdr files) ) )
     1428                 (exit) )
     1429                ((string=? arg "-dont-ask")
     1430                 (set! *dont-ask* #t)
     1431                 (loop (cdr args)))
     1432                ((string=? arg "-no-install")
     1433                 (setup-install-flag #f)
     1434                 (set! *keep-stuff* #t)
     1435                 (loop (cdr args)))
     1436                ((string=? arg "-docindex")
     1437                 (let ((di (doc-index #t)))
     1438                   (unless (file-exists? di)
     1439                     (build-doc-index) )
     1440                   (print di) ) )
     1441                ((string=? arg "-debug")
     1442                 (set! *debug* #t)
     1443                 (loop (cdr args)))
     1444                ((and (string=? arg "-revision") (pair? (cdr args)))
     1445                 (set! *revision* (cadr args))
     1446                 (loop (cddr args)))
     1447                ((and (string=? arg "-svn") (pair? (cdr args)))
     1448                 (set! *svn-repository* (cadr args))
     1449                 (set! *dont-ask* #t)
     1450                 (loop (cddr args)))
     1451                ((string=? arg "-test")
     1452                 (set! *run-tests* #t)
     1453                 (loop (cdr args)))
     1454                ((and (string=? arg "-local") (pair? (cdr args)))
     1455                 (set! *local-repository* (cadr args))
     1456                 (set! *dont-ask* #t)
     1457                 (loop (cddr args)))
     1458                ((and (string=? arg "-create-tree") (pair? (cdr args)))
     1459                 (create-repository-file (cadr args))
     1460                 (set! anydone #t)
     1461                 (loop (cddr args)))
     1462                ((string=? arg "-fetch-tree")
     1463                 (set! *fetch-tree-only* #t)
     1464                 (set! anydone #t)
     1465                 (loop (cdr args)))
     1466                ((string=? arg "-host-extension")
     1467                 (host-extension #t)
     1468                 (loop (cdr args)))
     1469                ((member arg '("-run" "-script" "-proxy" "-host" "-csc-option" "-ls" "-install-prefix"
     1470                               "-tree" "-local" "-svn" "-eval" "-create-tree" "-build-prefix" "-download-dir"))
     1471                 (error "missing option argument" arg))
     1472                (else
     1473                 (let ((filename arg)
     1474                       (more (cdr args)))
     1475                   (cond ((and (> (string-length filename) 0)
     1476                               (char=? #\- (string-ref filename 0)))
     1477                          (let ((os (string->list (substring filename 1))))
     1478                            (if (every (cut memq <> short-options) os)
     1479                                (loop
     1480                                 (append
     1481                                  (map (lambda (s) (list-ref long-options (list-index (cut eq? <> s) short-options))) os)
     1482                                  more) )
     1483                                (error "invalid option" filename) ) ) )
     1484                         (else
     1485                          (set! anydone #t)
     1486                          ((if uinst uninstall-extension install)
     1487                           (let ((m (string-match "http://([^/]+)/(.+)" filename)))
     1488                             (cond (m
     1489                                    (parse-host (cadr m) #f)
     1490                                    (set! *dont-ask* #t)
     1491                                    (conc "/" (caddr m)))
     1492                                   (else filename)) ) )
     1493                          (loop more) ) ) ) ) ) ) ) ) ) ) )
    14771494
    14781495(handle-exceptions ex
  • chicken/branches/beyond-hope/chicken.scm

    r8361 r10375  
    2727
    2828(declare
    29   (uses srfi-1 match srfi-4 utils support compiler optimizer driver platform backend)
     29  (uses srfi-1 srfi-4 utils support compiler optimizer driver platform backend)
    3030  (run-time-macros) )
    3131
Note: See TracChangeset for help on using the changeset viewer.