~ chicken-core (chicken-5) fd1ac20d33c3527e9a1c348cb65dde0ae157bf8a
commit fd1ac20d33c3527e9a1c348cb65dde0ae157bf8a
Merge: 71cdec91 a0f0aec9
Author: felix <felix@call-with-current-continuation.org>
AuthorDate: Sat Jul 31 00:54:36 2010 +0200
Commit: felix <felix@call-with-current-continuation.org>
CommitDate: Sat Jul 31 00:54:36 2010 +0200
resolved conflicts
diff --cc chicken-uninstall.scm
index 844acf86,8a074b4d..bd6b35ee
--- a/chicken-uninstall.scm
+++ b/chicken-uninstall.scm
@@@ -109,38 -108,52 +111,52 @@@ EO
(define *short-options* '(#\h #\s))
(define (main args)
- (let loop ((args args) (pats '()))
- (if (null? args)
- (uninstall (if (null? pats) (usage 1) (reverse pats)))
- (let ((arg (car args)))
- (cond ((or (string=? arg "-help")
- (string=? arg "-h")
- (string=? arg "--help"))
- (usage 0))
- ((or (string=? arg "-v") (string=? arg "-version"))
- (print (chicken-version))
- (exit 0))
- ((string=? arg "-target")
- (set! *host-extensions* #f)
- (loop (cdr args) pats))
- ((string=? arg "-host")
- (set! *target-extensions* #f)
- (loop (cdr args) pats))
- ((string=? arg "-force")
- (set! *force* #t)
- (loop (cdr args) pats))
- ((or (string=? arg "-s") (string=? arg "-sudo"))
- (sudo-install #t)
- (loop (cdr args) pats))
- ((and (positive? (string-length arg))
- (char=? #\- (string-ref arg 0)))
- (if (> (string-length arg) 2)
- (let ((sos (string->list (substring arg 1))))
- (if (every (cut memq <> *short-options*) sos)
- (loop (append (map (cut string #\- <>) sos) (cdr args)) pats)
- (usage 1)))
- (usage 1)))
- (else (loop (cdr args) (cons (##sys#glob->regexp arg) pats))))))))
+ (let ((exact #f))
+ (let loop ((args args) (pats '()))
+ (cond ((null? args)
+ (when (null? pats) (usage 1))
+ (uninstall
+ (reverse
+ (map
+ (lambda (p)
+ (if exact
- (regexp (string-append "^" (regexp-escape p) "$"))
- (glob->regexp p)))
++ (irregex (string-append "^" (irregex-quote p) "$"))
++ (##sys#glob->regexp p)))
+ pats))))
+ (else
+ (let ((arg (car args)))
+ (cond ((or (string=? arg "-help")
+ (string=? arg "-h")
+ (string=? arg "--help"))
+ (usage 0))
+ ((or (string=? arg "-v") (string=? arg "-version"))
+ (print (chicken-version))
+ (exit 0))
+ ((string=? arg "-target")
+ (set! *host-extensions* #f)
+ (loop (cdr args) pats))
+ ((string=? arg "-host")
+ (set! *target-extensions* #f)
+ (loop (cdr args) pats))
+ ((string=? arg "-force")
+ (set! *force* #t)
+ (loop (cdr args) pats))
+ ((string=? arg "-exact")
+ (set! exact #t)
+ (loop (cdr args) pats))
+ ((or (string=? arg "-s") (string=? arg "-sudo"))
+ (sudo-install #t)
+ (loop (cdr args) pats))
+ ((and (positive? (string-length arg))
+ (char=? #\- (string-ref arg 0)))
+ (if (> (string-length arg) 2)
+ (let ((sos (string->list (substring arg 1))))
+ (if (every (cut memq <> *short-options*) sos)
+ (loop
+ (append (map (cut string #\- <>) sos) (cdr args)) pats)
+ (usage 1)))
+ (usage 1)))
+ (else (loop (cdr args) (cons arg pats))))))))))
(main (command-line-arguments))
diff --cc files.scm
index 902d5900,2c1c167f..1ef2eda2
--- a/files.scm
+++ b/files.scm
@@@ -258,36 -259,31 +258,36 @@@ EO
(if (absolute-pathname? dir)
dir
(##sys#string-append def-pds dir)) )
- file ext pds) ) ) )
+ file ext def-pds) ) ) )
(define decompose-pathname
- (let ((string-match string-match))
- (let* ([patt1 "^(.*[\\/\\\\])?([^\\/\\\\]+)(\\.([^\\/\\\\.]+))$"]
- [patt2 "^(.*[\\/\\\\])?((\\.)?[^\\/\\\\]+)$"]
- [rx1 (regexp patt1)]
- [rx2 (regexp patt2)]
- [strip-pds
- (lambda (dir)
- (and dir
- (if (member dir '("/" "\\"))
- dir
- (chop-pds dir #f) ) ) )] )
- (lambda (pn)
- (##sys#check-string pn 'decompose-pathname)
- (if (fx= 0 (##sys#size pn))
- (values #f #f #f)
- (let ([ms (string-match rx1 pn)])
- (if ms
- (values (strip-pds (cadr ms)) (caddr ms) (car (cddddr ms)))
- (let ([ms (string-match rx2 pn)])
- (if ms
- (values (strip-pds (cadr ms)) (caddr ms) #f)
- (values (strip-pds pn) #f #f) ) ) ) ) ) ) ) ) )
+ (let* ([patt1 "^(.*[\\/\\\\])?([^\\/\\\\]+)(\\.([^\\/\\\\.]+))$"]
+ [patt2 "^(.*[\\/\\\\])?((\\.)?[^\\/\\\\]+)$"]
+ [rx1 (irregex patt1)]
+ [rx2 (irregex patt2)]
+ [strip-pds
+ (lambda (dir)
+ (and dir
+ (if (member dir '("/" "\\"))
+ dir
+ (chop-pds dir #f) ) ) )] )
+ (lambda (pn)
+ (##sys#check-string pn 'decompose-pathname)
+ (if (fx= 0 (##sys#size pn))
+ (values #f #f #f)
+ (let ([ms (irregex-search rx1 pn)])
+ (if ms
+ (values
+ (strip-pds (irregex-match-substring ms 1))
+ (irregex-match-substring ms 2)
+ (irregex-match-substring ms 4))
+ (let ([ms (irregex-search rx2 pn)])
+ (if ms
+ (values
+ (strip-pds (irregex-match-substring ms 1))
+ (irregex-match-substring ms 2)
+ #f)
+ (values (strip-pds pn) #f #f) ) ) ) ) ) ) ) )
(define pathname-directory)
(define pathname-file)
Trap