Changeset 35657 in project

Timestamp:

06/21/18 11:49:51 (20 months ago)

Author:

Kooda

Message:

Port the regex egg to CHICKEN 5

Location:

release/5

Files:

• egg-locations (modified) (1 diff)
• regex (copied) (copied from release/4/regex)
• regex/tags/1.0 (deleted)
• regex/tags/2.0 (copied) (copied from release/4/regex/trunk)
• regex/tags/2.0/regex.egg (added)
• regex/tags/2.0/regex.meta (deleted)
• regex/tags/2.0/regex.scm (modified) (2 diffs)
• regex/tags/2.0/regex.setup (deleted)
• regex/trunk/regex.egg (added)
• regex/trunk/regex.meta (deleted)
• regex/trunk/regex.scm (modified) (2 diffs)
• regex/trunk/regex.setup (deleted)

release/5/egg-locations

@@ -20 +20 @@
 (r7rs "http://code.call-cc.org/release-info?egg={egg-name};release={chicken-release}")
 (record-variants "http://code.call-cc.org/release-info?egg={egg-name};release={chicken-release}")
+(regex "http://code.call-cc.org/release-info?egg={egg-name};release={chicken-release}")
 (silex "http://code.call-cc.org/release-info?egg={egg-name};release={chicken-release}")
 (sql-null "http://code.call-cc.org/release-info?egg={egg-name};release={chicken-release}")

release/5/regex/tags/2.0/regex.scm

@@ -41 +41 @@
                string-substitute*)
 
-(import scheme chicken)
-(use irregex)
+(import scheme (chicken base) (chicken irregex) (chicken fixnum))
 
 
@@ -212 +211 @@
 ;;; Glob support:
 
-(define glob->regexp ##sys#glob->regexp)
-
+(define glob->regexp
+  (let ((list->string list->string)
+        (string->list string->list))
+    (lambda (s #!optional sre?)
+      (##sys#check-string s 'glob->regexp)
+      (let ((sre
+             (cons 
+              ':
+              (let loop ((cs (string->list s)) (dir #t))
+                (if (null? cs)
+                    '()
+                    (let ((c (car cs))
+                          (rest (cdr cs)) )
+                      (cond ((char=? c #\*) 
+                             (if dir
+                                 `((or (: (~ ("./\\"))
+                                          (* (~ ("/\\"))))
+                                       (* (~ ("./\\"))))
+                                   ,@(loop rest #f))
+                                 `((* (~ ("/\\"))) ,@(loop rest #f))))
+                            ((char=? c #\?)  (cons 'any (loop rest #f)))
+                            ((char=? c #\[)
+                             (let loop2 ((rest rest) (s '()))
+                               (cond ((not (pair? rest))
+                                      (error 'glob->regexp
+                                             "unexpected end of character class" s))
+                                     ((char=? #\] (car rest))
+                                      `(,(if (> (length s) 1)
+                                             `(or ,@s) 
+                                             (car s))
+                                        ,@(loop (cdr rest) #f)))
+                                     ((and (pair? (cdr rest))
+                                           (pair? (cddr rest))
+                                           (char=? #\- (cadr rest)) )
+                                      (loop2 (cdddr rest)
+                                             (cons `(/ ,(car rest) ,(caddr rest)) s)))
+                                     ((and (pair? (cdr rest))
+                                           (char=? #\- (car rest)))
+                                      (loop2 (cddr rest)
+                                             (cons `(~ ,(cadr rest)) s)))
+                                     (else
+                                      (loop2 (cdr rest) (cons (car rest) s))))))
+                            (else (cons c (loop rest (memq c '(#\\ #\/))))))))))))
+        (if sre? sre (irregex sre))))))
 
 ;;; Grep-like function on list:

release/5/regex/trunk/regex.scm

@@ -41 +41 @@
                string-substitute*)
 
-(import scheme chicken)
-(use irregex)
+(import scheme (chicken base) (chicken irregex) (chicken fixnum))
 
 
@@ -212 +211 @@
 ;;; Glob support:
 
-(define glob->regexp ##sys#glob->regexp)
-
+(define glob->regexp
+  (let ((list->string list->string)
+        (string->list string->list))
+    (lambda (s #!optional sre?)
+      (##sys#check-string s 'glob->regexp)
+      (let ((sre
+             (cons 
+              ':
+              (let loop ((cs (string->list s)) (dir #t))
+                (if (null? cs)
+                    '()
+                    (let ((c (car cs))
+                          (rest (cdr cs)) )
+                      (cond ((char=? c #\*) 
+                             (if dir
+                                 `((or (: (~ ("./\\"))
+                                          (* (~ ("/\\"))))
+                                       (* (~ ("./\\"))))
+                                   ,@(loop rest #f))
+                                 `((* (~ ("/\\"))) ,@(loop rest #f))))
+                            ((char=? c #\?)  (cons 'any (loop rest #f)))
+                            ((char=? c #\[)
+                             (let loop2 ((rest rest) (s '()))
+                               (cond ((not (pair? rest))
+                                      (error 'glob->regexp
+                                             "unexpected end of character class" s))
+                                     ((char=? #\] (car rest))
+                                      `(,(if (> (length s) 1)
+                                             `(or ,@s) 
+                                             (car s))
+                                        ,@(loop (cdr rest) #f)))
+                                     ((and (pair? (cdr rest))
+                                           (pair? (cddr rest))
+                                           (char=? #\- (cadr rest)) )
+                                      (loop2 (cdddr rest)
+                                             (cons `(/ ,(car rest) ,(caddr rest)) s)))
+                                     ((and (pair? (cdr rest))
+                                           (char=? #\- (car rest)))
+                                      (loop2 (cddr rest)
+                                             (cons `(~ ,(cadr rest)) s)))
+                                     (else
+                                      (loop2 (cdr rest) (cons (car rest) s))))))
+                            (else (cons c (loop rest (memq c '(#\\ #\/))))))))))))
+        (if sre? sre (irregex sre))))))
 
 ;;; Grep-like function on list: