removed streams and pregexp libraries from lib directory
This commit is contained in:
Abdulaziz Ghuloum
parent
0ec9c9536e
commit
a59aede042
|
|
@ -1,12 +1,10 @@
|
||||||
libstreamsdir=$(pkglibdir)/streams
|
|
||||||
dist_libstreams_DATA=streams/primitive.ss streams/derived.ss
|
|
||||||
libikarusdir=$(pkglibdir)/ikarus
|
libikarusdir=$(pkglibdir)/ikarus
|
||||||
dist_libikarus_DATA=ikarus/foreign.ss ikarus/ipc.ss
|
dist_libikarus_DATA=ikarus/foreign.ss ikarus/ipc.ss
|
||||||
libCocoadir=$(pkglibdir)/Cocoa
|
libCocoadir=$(pkglibdir)/Cocoa
|
||||||
dist_libCocoa_DATA=Cocoa/helpers.ss
|
dist_libCocoa_DATA=Cocoa/helpers.ss
|
||||||
|
|
||||||
|
|
||||||
dist_pkglib_DATA= streams.ss match.ss pregexp.ss gl.ss glut.ss \
|
dist_pkglib_DATA= match.ss gl.ss glut.ss \
|
||||||
ypsilon-compat.ikarus.ss ypsilon-compat.ypsilon.ss \
|
ypsilon-compat.ikarus.ss ypsilon-compat.ypsilon.ss \
|
||||||
objc.ss Cocoa.ss
|
objc.ss Cocoa.ss
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -35,8 +35,8 @@ host_triplet = @host@
|
||||||
target_triplet = @target@
|
target_triplet = @target@
|
||||||
subdir = lib
|
subdir = lib
|
||||||
DIST_COMMON = $(dist_libCocoa_DATA) $(dist_libikarus_DATA) \
|
DIST_COMMON = $(dist_libCocoa_DATA) $(dist_libikarus_DATA) \
|
||||||
$(dist_libstreams_DATA) $(dist_pkglib_DATA) \
|
$(dist_pkglib_DATA) $(srcdir)/Makefile.am \
|
||||||
$(srcdir)/Makefile.am $(srcdir)/Makefile.in
|
$(srcdir)/Makefile.in
|
||||||
ACLOCAL_M4 = $(top_srcdir)/aclocal.m4
|
ACLOCAL_M4 = $(top_srcdir)/aclocal.m4
|
||||||
am__aclocal_m4_deps = $(top_srcdir)/configure.ac
|
am__aclocal_m4_deps = $(top_srcdir)/configure.ac
|
||||||
am__configure_deps = $(am__aclocal_m4_deps) $(CONFIGURE_DEPENDENCIES) \
|
am__configure_deps = $(am__aclocal_m4_deps) $(CONFIGURE_DEPENDENCIES) \
|
||||||
|
|
@ -53,14 +53,12 @@ am__vpath_adj = case $$p in \
|
||||||
esac;
|
esac;
|
||||||
am__strip_dir = `echo $$p | sed -e 's|^.*/||'`;
|
am__strip_dir = `echo $$p | sed -e 's|^.*/||'`;
|
||||||
am__installdirs = "$(DESTDIR)$(libCocoadir)" \
|
am__installdirs = "$(DESTDIR)$(libCocoadir)" \
|
||||||
"$(DESTDIR)$(libikarusdir)" "$(DESTDIR)$(libstreamsdir)" \
|
"$(DESTDIR)$(libikarusdir)" "$(DESTDIR)$(pkglibdir)"
|
||||||
"$(DESTDIR)$(pkglibdir)"
|
|
||||||
dist_libCocoaDATA_INSTALL = $(INSTALL_DATA)
|
dist_libCocoaDATA_INSTALL = $(INSTALL_DATA)
|
||||||
dist_libikarusDATA_INSTALL = $(INSTALL_DATA)
|
dist_libikarusDATA_INSTALL = $(INSTALL_DATA)
|
||||||
dist_libstreamsDATA_INSTALL = $(INSTALL_DATA)
|
|
||||||
dist_pkglibDATA_INSTALL = $(INSTALL_DATA)
|
dist_pkglibDATA_INSTALL = $(INSTALL_DATA)
|
||||||
DATA = $(dist_libCocoa_DATA) $(dist_libikarus_DATA) \
|
DATA = $(dist_libCocoa_DATA) $(dist_libikarus_DATA) \
|
||||||
$(dist_libstreams_DATA) $(dist_pkglib_DATA)
|
$(dist_pkglib_DATA)
|
||||||
DISTFILES = $(DIST_COMMON) $(DIST_SOURCES) $(TEXINFOS) $(EXTRA_DIST)
|
DISTFILES = $(DIST_COMMON) $(DIST_SOURCES) $(TEXINFOS) $(EXTRA_DIST)
|
||||||
ACLOCAL = @ACLOCAL@
|
ACLOCAL = @ACLOCAL@
|
||||||
AMTAR = @AMTAR@
|
AMTAR = @AMTAR@
|
||||||
|
|
@ -163,13 +161,11 @@ target_vendor = @target_vendor@
|
||||||
top_build_prefix = @top_build_prefix@
|
top_build_prefix = @top_build_prefix@
|
||||||
top_builddir = @top_builddir@
|
top_builddir = @top_builddir@
|
||||||
top_srcdir = @top_srcdir@
|
top_srcdir = @top_srcdir@
|
||||||
libstreamsdir = $(pkglibdir)/streams
|
|
||||||
dist_libstreams_DATA = streams/primitive.ss streams/derived.ss
|
|
||||||
libikarusdir = $(pkglibdir)/ikarus
|
libikarusdir = $(pkglibdir)/ikarus
|
||||||
dist_libikarus_DATA = ikarus/foreign.ss ikarus/ipc.ss
|
dist_libikarus_DATA = ikarus/foreign.ss ikarus/ipc.ss
|
||||||
libCocoadir = $(pkglibdir)/Cocoa
|
libCocoadir = $(pkglibdir)/Cocoa
|
||||||
dist_libCocoa_DATA = Cocoa/helpers.ss
|
dist_libCocoa_DATA = Cocoa/helpers.ss
|
||||||
dist_pkglib_DATA = streams.ss match.ss pregexp.ss gl.ss glut.ss \
|
dist_pkglib_DATA = match.ss gl.ss glut.ss \
|
||||||
ypsilon-compat.ikarus.ss ypsilon-compat.ypsilon.ss \
|
ypsilon-compat.ikarus.ss ypsilon-compat.ypsilon.ss \
|
||||||
objc.ss Cocoa.ss
|
objc.ss Cocoa.ss
|
||||||
|
|
||||||
|
|
@ -239,23 +235,6 @@ uninstall-dist_libikarusDATA:
|
||||||
echo " rm -f '$(DESTDIR)$(libikarusdir)/$$f'"; \
|
echo " rm -f '$(DESTDIR)$(libikarusdir)/$$f'"; \
|
||||||
rm -f "$(DESTDIR)$(libikarusdir)/$$f"; \
|
rm -f "$(DESTDIR)$(libikarusdir)/$$f"; \
|
||||||
done
|
done
|
||||||
install-dist_libstreamsDATA: $(dist_libstreams_DATA)
|
|
||||||
@$(NORMAL_INSTALL)
|
|
||||||
test -z "$(libstreamsdir)" || $(MKDIR_P) "$(DESTDIR)$(libstreamsdir)"
|
|
||||||
@list='$(dist_libstreams_DATA)'; for p in $$list; do \
|
|
||||||
if test -f "$$p"; then d=; else d="$(srcdir)/"; fi; \
|
|
||||||
f=$(am__strip_dir) \
|
|
||||||
echo " $(dist_libstreamsDATA_INSTALL) '$$d$$p' '$(DESTDIR)$(libstreamsdir)/$$f'"; \
|
|
||||||
$(dist_libstreamsDATA_INSTALL) "$$d$$p" "$(DESTDIR)$(libstreamsdir)/$$f"; \
|
|
||||||
done
|
|
||||||
|
|
||||||
uninstall-dist_libstreamsDATA:
|
|
||||||
@$(NORMAL_UNINSTALL)
|
|
||||||
@list='$(dist_libstreams_DATA)'; for p in $$list; do \
|
|
||||||
f=$(am__strip_dir) \
|
|
||||||
echo " rm -f '$(DESTDIR)$(libstreamsdir)/$$f'"; \
|
|
||||||
rm -f "$(DESTDIR)$(libstreamsdir)/$$f"; \
|
|
||||||
done
|
|
||||||
install-dist_pkglibDATA: $(dist_pkglib_DATA)
|
install-dist_pkglibDATA: $(dist_pkglib_DATA)
|
||||||
@$(NORMAL_INSTALL)
|
@$(NORMAL_INSTALL)
|
||||||
test -z "$(pkglibdir)" || $(MKDIR_P) "$(DESTDIR)$(pkglibdir)"
|
test -z "$(pkglibdir)" || $(MKDIR_P) "$(DESTDIR)$(pkglibdir)"
|
||||||
|
|
@ -310,7 +289,7 @@ check-am: all-am
|
||||||
check: check-am
|
check: check-am
|
||||||
all-am: Makefile $(DATA)
|
all-am: Makefile $(DATA)
|
||||||
installdirs:
|
installdirs:
|
||||||
for dir in "$(DESTDIR)$(libCocoadir)" "$(DESTDIR)$(libikarusdir)" "$(DESTDIR)$(libstreamsdir)" "$(DESTDIR)$(pkglibdir)"; do \
|
for dir in "$(DESTDIR)$(libCocoadir)" "$(DESTDIR)$(libikarusdir)" "$(DESTDIR)$(pkglibdir)"; do \
|
||||||
test -z "$$dir" || $(MKDIR_P) "$$dir"; \
|
test -z "$$dir" || $(MKDIR_P) "$$dir"; \
|
||||||
done
|
done
|
||||||
install: install-am
|
install: install-am
|
||||||
|
|
@ -355,8 +334,7 @@ info: info-am
|
||||||
|
|
||||||
info-am:
|
info-am:
|
||||||
|
|
||||||
install-data-am: install-dist_libCocoaDATA install-dist_libikarusDATA \
|
install-data-am: install-dist_libCocoaDATA install-dist_libikarusDATA
|
||||||
install-dist_libstreamsDATA
|
|
||||||
|
|
||||||
install-dvi: install-dvi-am
|
install-dvi: install-dvi-am
|
||||||
|
|
||||||
|
|
@ -391,7 +369,7 @@ ps: ps-am
|
||||||
ps-am:
|
ps-am:
|
||||||
|
|
||||||
uninstall-am: uninstall-dist_libCocoaDATA uninstall-dist_libikarusDATA \
|
uninstall-am: uninstall-dist_libCocoaDATA uninstall-dist_libikarusDATA \
|
||||||
uninstall-dist_libstreamsDATA uninstall-dist_pkglibDATA
|
uninstall-dist_pkglibDATA
|
||||||
|
|
||||||
.MAKE: install-am install-strip
|
.MAKE: install-am install-strip
|
||||||
|
|
||||||
|
|
@ -399,15 +377,14 @@ uninstall-am: uninstall-dist_libCocoaDATA uninstall-dist_libikarusDATA \
|
||||||
distclean-generic distdir dvi dvi-am html html-am info info-am \
|
distclean-generic distdir dvi dvi-am html html-am info info-am \
|
||||||
install install-am install-data install-data-am \
|
install install-am install-data install-data-am \
|
||||||
install-dist_libCocoaDATA install-dist_libikarusDATA \
|
install-dist_libCocoaDATA install-dist_libikarusDATA \
|
||||||
install-dist_libstreamsDATA install-dist_pkglibDATA \
|
install-dist_pkglibDATA install-dvi install-dvi-am \
|
||||||
install-dvi install-dvi-am install-exec install-exec-am \
|
install-exec install-exec-am install-html install-html-am \
|
||||||
install-html install-html-am install-info install-info-am \
|
install-info install-info-am install-man install-pdf \
|
||||||
install-man install-pdf install-pdf-am install-ps \
|
install-pdf-am install-ps install-ps-am install-strip \
|
||||||
install-ps-am install-strip installcheck installcheck-am \
|
installcheck installcheck-am installdirs maintainer-clean \
|
||||||
installdirs maintainer-clean maintainer-clean-generic \
|
maintainer-clean-generic mostlyclean mostlyclean-generic pdf \
|
||||||
mostlyclean mostlyclean-generic pdf pdf-am ps ps-am uninstall \
|
pdf-am ps ps-am uninstall uninstall-am \
|
||||||
uninstall-am uninstall-dist_libCocoaDATA \
|
uninstall-dist_libCocoaDATA uninstall-dist_libikarusDATA \
|
||||||
uninstall-dist_libikarusDATA uninstall-dist_libstreamsDATA \
|
|
||||||
uninstall-dist_pkglibDATA
|
uninstall-dist_pkglibDATA
|
||||||
|
|
||||||
# Tell versions [3.59,3.63) of GNU make to not export all variables.
|
# Tell versions [3.59,3.63) of GNU make to not export all variables.
|
||||||
|
|
|
||||||
794
lib/pregexp.ss
794
lib/pregexp.ss
|
|
@ -1,794 +0,0 @@
|
||||||
;pregexp.scm
|
|
||||||
;Portable regular expressions for Scheme
|
|
||||||
;Dorai Sitaram
|
|
||||||
;http://www.ccs.neu.edu/~dorai
|
|
||||||
;dorai AT ccs DOT neu DOT edu
|
|
||||||
;Oct 2, 1999
|
|
||||||
|
|
||||||
;;; ported to ikarus by Abdulaziz Ghuloum on Dec 19, 2007.
|
|
||||||
;;; also added special cases for when the first argument to
|
|
||||||
;;; any of these procedures is a known string at macro
|
|
||||||
;;; expansion time.
|
|
||||||
|
|
||||||
(library (pregexp)
|
|
||||||
(export pregexp pregexp-match-positions pregexp-match
|
|
||||||
pregexp-split pregexp-replace pregexp-replace*)
|
|
||||||
(import (ikarus))
|
|
||||||
|
|
||||||
(define *pregexp-version* 20071219) ;last change
|
|
||||||
|
|
||||||
(define *pregexp-comment-char* #\;)
|
|
||||||
|
|
||||||
(define *pregexp-nul-char-int* #\x0)
|
|
||||||
|
|
||||||
(define *pregexp-return-char* #\return)
|
|
||||||
|
|
||||||
(define *pregexp-tab-char* #\tab)
|
|
||||||
|
|
||||||
(define *pregexp-space-sensitive?* #t)
|
|
||||||
|
|
||||||
(define pregexp-reverse!
|
|
||||||
;the useful reverse! isn't R5RS
|
|
||||||
(lambda (s)
|
|
||||||
(let loop ((s s) (r '()))
|
|
||||||
(if (null? s) r
|
|
||||||
(let ((d (cdr s)))
|
|
||||||
(set-cdr! s r)
|
|
||||||
(loop d s))))))
|
|
||||||
|
|
||||||
(define pregexp-error
|
|
||||||
;R5RS won't give me a portable error procedure.
|
|
||||||
;modify this as needed
|
|
||||||
(case-lambda
|
|
||||||
[(who) (error who "an error occurred")]
|
|
||||||
[(who msg . args) (apply error who (format "~a" msg) args)]))
|
|
||||||
|
|
||||||
(define pregexp-read-pattern
|
|
||||||
(lambda (s i n)
|
|
||||||
(if (>= i n)
|
|
||||||
(list
|
|
||||||
(list ':or (list ':seq)) i)
|
|
||||||
(let loop ((branches '()) (i i))
|
|
||||||
(if (or (>= i n)
|
|
||||||
(char=? (string-ref s i) #\)))
|
|
||||||
(list (cons ':or (pregexp-reverse! branches)) i)
|
|
||||||
(let ((vv (pregexp-read-branch
|
|
||||||
s
|
|
||||||
(if (char=? (string-ref s i) #\|) (+ i 1) i) n)))
|
|
||||||
(loop (cons (car vv) branches) (cadr vv))))))))
|
|
||||||
|
|
||||||
(define pregexp-read-branch
|
|
||||||
(lambda (s i n)
|
|
||||||
(let loop ((pieces '()) (i i))
|
|
||||||
(cond ((>= i n)
|
|
||||||
(list (cons ':seq (pregexp-reverse! pieces)) i))
|
|
||||||
((let ((c (string-ref s i)))
|
|
||||||
(or (char=? c #\|)
|
|
||||||
(char=? c #\))))
|
|
||||||
(list (cons ':seq (pregexp-reverse! pieces)) i))
|
|
||||||
(else (let ((vv (pregexp-read-piece s i n)))
|
|
||||||
(loop (cons (car vv) pieces) (cadr vv))))))))
|
|
||||||
|
|
||||||
(define pregexp-read-piece
|
|
||||||
(lambda (s i n)
|
|
||||||
(let ((c (string-ref s i)))
|
|
||||||
(case c
|
|
||||||
((#\^) (list ':bos (+ i 1)))
|
|
||||||
((#\$) (list ':eos (+ i 1)))
|
|
||||||
((#\.) (pregexp-wrap-quantifier-if-any
|
|
||||||
(list ':any (+ i 1)) s n))
|
|
||||||
((#\[) (let ((i+1 (+ i 1)))
|
|
||||||
(pregexp-wrap-quantifier-if-any
|
|
||||||
(case (and (< i+1 n) (string-ref s i+1))
|
|
||||||
((#\^)
|
|
||||||
(let ((vv (pregexp-read-char-list s (+ i 2) n)))
|
|
||||||
(list (list ':neg-char (car vv)) (cadr vv))))
|
|
||||||
(else (pregexp-read-char-list s i+1 n)))
|
|
||||||
s n)))
|
|
||||||
((#\()
|
|
||||||
(pregexp-wrap-quantifier-if-any
|
|
||||||
(pregexp-read-subpattern s (+ i 1) n) s n))
|
|
||||||
((#\\ )
|
|
||||||
(pregexp-wrap-quantifier-if-any
|
|
||||||
(cond ((pregexp-read-escaped-number s i n) =>
|
|
||||||
(lambda (num-i)
|
|
||||||
(list (list ':backref (car num-i)) (cadr num-i))))
|
|
||||||
((pregexp-read-escaped-char s i n) =>
|
|
||||||
(lambda (char-i)
|
|
||||||
(list (car char-i) (cadr char-i))))
|
|
||||||
(else (pregexp-error 'pregexp-read-piece 'backslash)))
|
|
||||||
s n))
|
|
||||||
(else
|
|
||||||
(if (or *pregexp-space-sensitive?*
|
|
||||||
(and (not (char-whitespace? c))
|
|
||||||
(not (char=? c *pregexp-comment-char*))))
|
|
||||||
(pregexp-wrap-quantifier-if-any
|
|
||||||
(list c (+ i 1)) s n)
|
|
||||||
(let loop ((i i) (in-comment? #f))
|
|
||||||
(if (>= i n) (list ':empty i)
|
|
||||||
(let ((c (string-ref s i)))
|
|
||||||
(cond (in-comment?
|
|
||||||
(loop (+ i 1)
|
|
||||||
(not (char=? c #\newline))))
|
|
||||||
((char-whitespace? c)
|
|
||||||
(loop (+ i 1) #f))
|
|
||||||
((char=? c *pregexp-comment-char*)
|
|
||||||
(loop (+ i 1) #t))
|
|
||||||
(else (list ':empty i))))))))))))
|
|
||||||
|
|
||||||
(define pregexp-read-escaped-number
|
|
||||||
(lambda (s i n)
|
|
||||||
; s[i] = \
|
|
||||||
(and (< (+ i 1) n) ;must have at least something following \
|
|
||||||
(let ((c (string-ref s (+ i 1))))
|
|
||||||
(and (char-numeric? c)
|
|
||||||
(let loop ((i (+ i 2)) (r (list c)))
|
|
||||||
(if (>= i n)
|
|
||||||
(list (string->number
|
|
||||||
(list->string (pregexp-reverse! r))) i)
|
|
||||||
(let ((c (string-ref s i)))
|
|
||||||
(if (char-numeric? c)
|
|
||||||
(loop (+ i 1) (cons c r))
|
|
||||||
(list (string->number
|
|
||||||
(list->string (pregexp-reverse! r)))
|
|
||||||
i))))))))))
|
|
||||||
|
|
||||||
(define pregexp-read-escaped-char
|
|
||||||
(lambda (s i n)
|
|
||||||
; s[i] = \
|
|
||||||
(and (< (+ i 1) n)
|
|
||||||
(let ((c (string-ref s (+ i 1))))
|
|
||||||
(case c
|
|
||||||
((#\b) (list ':wbdry (+ i 2)))
|
|
||||||
((#\B) (list ':not-wbdry (+ i 2)))
|
|
||||||
((#\d) (list ':digit (+ i 2)))
|
|
||||||
((#\D) (list '(:neg-char :digit) (+ i 2)))
|
|
||||||
((#\n) (list #\newline (+ i 2)))
|
|
||||||
((#\r) (list *pregexp-return-char* (+ i 2)))
|
|
||||||
((#\s) (list ':space (+ i 2)))
|
|
||||||
((#\S) (list '(:neg-char :space) (+ i 2)))
|
|
||||||
((#\t) (list *pregexp-tab-char* (+ i 2)))
|
|
||||||
((#\w) (list ':word (+ i 2)))
|
|
||||||
((#\W) (list '(:neg-char :word) (+ i 2)))
|
|
||||||
(else (list c (+ i 2))))))))
|
|
||||||
|
|
||||||
(define pregexp-read-posix-char-class
|
|
||||||
(lambda (s i n)
|
|
||||||
; lbrack, colon already read
|
|
||||||
(let ((neg? #f))
|
|
||||||
(let loop ((i i) (r (list #\:)))
|
|
||||||
(if (>= i n)
|
|
||||||
(pregexp-error 'pregexp-read-posix-char-class)
|
|
||||||
(let ((c (string-ref s i)))
|
|
||||||
(cond ((char=? c #\^)
|
|
||||||
(set! neg? #t)
|
|
||||||
(loop (+ i 1) r))
|
|
||||||
((char-alphabetic? c)
|
|
||||||
(loop (+ i 1) (cons c r)))
|
|
||||||
((char=? c #\:)
|
|
||||||
(if (or (>= (+ i 1) n)
|
|
||||||
(not (char=? (string-ref s (+ i 1)) #\])))
|
|
||||||
(pregexp-error 'pregexp-read-posix-char-class)
|
|
||||||
(let ((posix-class
|
|
||||||
(string->symbol
|
|
||||||
(list->string (pregexp-reverse! r)))))
|
|
||||||
(list (if neg? (list ':neg-char posix-class)
|
|
||||||
posix-class)
|
|
||||||
(+ i 2)))))
|
|
||||||
(else
|
|
||||||
(pregexp-error 'pregexp-read-posix-char-class)))))))))
|
|
||||||
|
|
||||||
(define pregexp-read-cluster-type
|
|
||||||
(lambda (s i n)
|
|
||||||
; s[i-1] = left-paren
|
|
||||||
(let ((c (string-ref s i)))
|
|
||||||
(case c
|
|
||||||
((#\?)
|
|
||||||
(let ((i (+ i 1)))
|
|
||||||
(case (string-ref s i)
|
|
||||||
((#\:) (list '() (+ i 1)))
|
|
||||||
((#\=) (list '(:lookahead) (+ i 1)))
|
|
||||||
((#\!) (list '(:neg-lookahead) (+ i 1)))
|
|
||||||
((#\>) (list '(:no-backtrack) (+ i 1)))
|
|
||||||
((#\<)
|
|
||||||
(list (case (string-ref s (+ i 1))
|
|
||||||
((#\=) '(:lookbehind))
|
|
||||||
((#\!) '(:neg-lookbehind))
|
|
||||||
(else (pregexp-error 'pregexp-read-cluster-type)))
|
|
||||||
(+ i 2)))
|
|
||||||
(else (let loop ((i i) (r '()) (inv? #f))
|
|
||||||
(let ((c (string-ref s i)))
|
|
||||||
(case c
|
|
||||||
((#\-) (loop (+ i 1) r #t))
|
|
||||||
((#\i) (loop (+ i 1)
|
|
||||||
(cons (if inv? ':case-sensitive
|
|
||||||
':case-insensitive) r) #f))
|
|
||||||
((#\x)
|
|
||||||
(set! *pregexp-space-sensitive?* inv?)
|
|
||||||
(loop (+ i 1) r #f))
|
|
||||||
((#\:) (list r (+ i 1)))
|
|
||||||
(else (pregexp-error
|
|
||||||
'pregexp-read-cluster-type)))))))))
|
|
||||||
(else (list '(:sub) i))))))
|
|
||||||
|
|
||||||
(define pregexp-read-subpattern
|
|
||||||
(lambda (s i n)
|
|
||||||
(let* ((remember-space-sensitive? *pregexp-space-sensitive?*)
|
|
||||||
(ctyp-i (pregexp-read-cluster-type s i n))
|
|
||||||
(ctyp (car ctyp-i))
|
|
||||||
(i (cadr ctyp-i))
|
|
||||||
(vv (pregexp-read-pattern s i n)))
|
|
||||||
(set! *pregexp-space-sensitive?* remember-space-sensitive?)
|
|
||||||
(let ((vv-re (car vv))
|
|
||||||
(vv-i (cadr vv)))
|
|
||||||
(if (and (< vv-i n)
|
|
||||||
(char=? (string-ref s vv-i)
|
|
||||||
#\)))
|
|
||||||
(list
|
|
||||||
(let loop ((ctyp ctyp) (re vv-re))
|
|
||||||
(if (null? ctyp) re
|
|
||||||
(loop (cdr ctyp)
|
|
||||||
(list (car ctyp) re))))
|
|
||||||
(+ vv-i 1))
|
|
||||||
(pregexp-error 'pregexp-read-subpattern))))))
|
|
||||||
|
|
||||||
(define pregexp-wrap-quantifier-if-any
|
|
||||||
(lambda (vv s n)
|
|
||||||
(let ((re (car vv)))
|
|
||||||
(let loop ((i (cadr vv)))
|
|
||||||
(if (>= i n) vv
|
|
||||||
(let ((c (string-ref s i)))
|
|
||||||
(if (and (char-whitespace? c) (not *pregexp-space-sensitive?*))
|
|
||||||
(loop (+ i 1))
|
|
||||||
(case c
|
|
||||||
((#\* #\+ #\? #\{)
|
|
||||||
(let* ((new-re (list ':between 'minimal?
|
|
||||||
'at-least 'at-most re))
|
|
||||||
(new-vv (list new-re 'next-i)))
|
|
||||||
(case c
|
|
||||||
((#\*) (set-car! (cddr new-re) 0)
|
|
||||||
(set-car! (cdddr new-re) #f))
|
|
||||||
((#\+) (set-car! (cddr new-re) 1)
|
|
||||||
(set-car! (cdddr new-re) #f))
|
|
||||||
((#\?) (set-car! (cddr new-re) 0)
|
|
||||||
(set-car! (cdddr new-re) 1))
|
|
||||||
((#\{) (let ((pq (pregexp-read-nums s (+ i 1) n)))
|
|
||||||
(if (not pq)
|
|
||||||
(pregexp-error
|
|
||||||
'pregexp-wrap-quantifier-if-any
|
|
||||||
'left-brace-must-be-followed-by-number))
|
|
||||||
(set-car! (cddr new-re) (car pq))
|
|
||||||
(set-car! (cdddr new-re) (cadr pq))
|
|
||||||
(set! i (caddr pq)))))
|
|
||||||
(let loop ((i (+ i 1)))
|
|
||||||
(if (>= i n)
|
|
||||||
(begin (set-car! (cdr new-re) #f)
|
|
||||||
(set-car! (cdr new-vv) i))
|
|
||||||
(let ((c (string-ref s i)))
|
|
||||||
(cond ((and (char-whitespace? c)
|
|
||||||
(not *pregexp-space-sensitive?*))
|
|
||||||
(loop (+ i 1)))
|
|
||||||
((char=? c #\?)
|
|
||||||
(set-car! (cdr new-re) #t)
|
|
||||||
(set-car! (cdr new-vv) (+ i 1)))
|
|
||||||
(else (set-car! (cdr new-re) #f)
|
|
||||||
(set-car! (cdr new-vv) i))))))
|
|
||||||
new-vv))
|
|
||||||
(else vv)))))))))
|
|
||||||
|
|
||||||
;
|
|
||||||
|
|
||||||
(define pregexp-read-nums
|
|
||||||
(lambda (s i n)
|
|
||||||
; s[i-1] = {
|
|
||||||
; returns (p q k) where s[k] = }
|
|
||||||
(let loop ((p '()) (q '()) (k i) (reading 1))
|
|
||||||
(if (>= k n) (pregexp-error 'pregexp-read-nums))
|
|
||||||
(let ((c (string-ref s k)))
|
|
||||||
(cond ((char-numeric? c)
|
|
||||||
(if (= reading 1)
|
|
||||||
(loop (cons c p) q (+ k 1) 1)
|
|
||||||
(loop p (cons c q) (+ k 1) 2)))
|
|
||||||
((and (char-whitespace? c) (not *pregexp-space-sensitive?*))
|
|
||||||
(loop p q (+ k 1) reading))
|
|
||||||
((and (char=? c #\,) (= reading 1))
|
|
||||||
(loop p q (+ k 1) 2))
|
|
||||||
((char=? c #\})
|
|
||||||
(let ((p (string->number (list->string (pregexp-reverse! p))))
|
|
||||||
(q (string->number (list->string (pregexp-reverse! q)))))
|
|
||||||
(cond ((and (not p) (= reading 1)) (list 0 #f k))
|
|
||||||
((= reading 1) (list p p k))
|
|
||||||
(else (list p q k)))))
|
|
||||||
(else #f))))))
|
|
||||||
|
|
||||||
(define pregexp-invert-char-list
|
|
||||||
(lambda (vv)
|
|
||||||
(set-car! (car vv) ':none-of-chars)
|
|
||||||
vv))
|
|
||||||
|
|
||||||
;
|
|
||||||
|
|
||||||
(define pregexp-read-char-list
|
|
||||||
(lambda (s i n)
|
|
||||||
(let loop ((r '()) (i i))
|
|
||||||
(if (>= i n)
|
|
||||||
(pregexp-error 'pregexp-read-char-list
|
|
||||||
'character-class-ended-too-soon)
|
|
||||||
(let ((c (string-ref s i)))
|
|
||||||
(case c
|
|
||||||
((#\]) (if (null? r)
|
|
||||||
(loop (cons c r) (+ i 1))
|
|
||||||
(list (cons ':one-of-chars (pregexp-reverse! r))
|
|
||||||
(+ i 1))))
|
|
||||||
((#\\ )
|
|
||||||
(let ((char-i (pregexp-read-escaped-char s i n)))
|
|
||||||
(if char-i (loop (cons (car char-i) r) (cadr char-i))
|
|
||||||
(pregexp-error 'pregexp-read-char-list 'backslash))))
|
|
||||||
((#\-) (if (or (null? r)
|
|
||||||
(let ((i+1 (+ i 1)))
|
|
||||||
(and (< i+1 n)
|
|
||||||
(char=? (string-ref s i+1) #\]))))
|
|
||||||
(loop (cons c r) (+ i 1))
|
|
||||||
(let ((c-prev (car r)))
|
|
||||||
(if (char? c-prev)
|
|
||||||
(loop (cons (list ':char-range c-prev
|
|
||||||
(string-ref s (+ i 1))) (cdr r))
|
|
||||||
(+ i 2))
|
|
||||||
(loop (cons c r) (+ i 1))))))
|
|
||||||
((#\[) (if (char=? (string-ref s (+ i 1)) #\:)
|
|
||||||
(let ((posix-char-class-i
|
|
||||||
(pregexp-read-posix-char-class s (+ i 2) n)))
|
|
||||||
(loop (cons (car posix-char-class-i) r)
|
|
||||||
(cadr posix-char-class-i)))
|
|
||||||
(loop (cons c r) (+ i 1))))
|
|
||||||
(else (loop (cons c r) (+ i 1)))))))))
|
|
||||||
|
|
||||||
|
|
||||||
;
|
|
||||||
|
|
||||||
(define pregexp-string-match
|
|
||||||
(lambda (s1 s i n sk fk)
|
|
||||||
(let ((n1 (string-length s1)))
|
|
||||||
(if (> n1 n) (fk)
|
|
||||||
(let loop ((j 0) (k i))
|
|
||||||
(cond ((>= j n1) (sk k))
|
|
||||||
((>= k n) (fk))
|
|
||||||
((char=? (string-ref s1 j) (string-ref s k))
|
|
||||||
(loop (+ j 1) (+ k 1)))
|
|
||||||
(else (fk))))))))
|
|
||||||
|
|
||||||
(define pregexp-char-word?
|
|
||||||
(lambda (c)
|
|
||||||
;too restrictive for Scheme but this
|
|
||||||
;is what \w is in most regexp notations
|
|
||||||
(or (char-alphabetic? c)
|
|
||||||
(char-numeric? c)
|
|
||||||
(char=? c #\_))))
|
|
||||||
|
|
||||||
(define pregexp-at-word-boundary?
|
|
||||||
(lambda (s i n)
|
|
||||||
(or (= i 0) (>= i n)
|
|
||||||
(let ((c/i (string-ref s i))
|
|
||||||
(c/i-1 (string-ref s (- i 1))))
|
|
||||||
(let ((c/i/w? (pregexp-check-if-in-char-class?
|
|
||||||
c/i ':word))
|
|
||||||
(c/i-1/w? (pregexp-check-if-in-char-class?
|
|
||||||
c/i-1 ':word)))
|
|
||||||
(or (and c/i/w? (not c/i-1/w?))
|
|
||||||
(and (not c/i/w?) c/i-1/w?)))))))
|
|
||||||
|
|
||||||
(define pregexp-check-if-in-char-class?
|
|
||||||
(lambda (c char-class)
|
|
||||||
(case char-class
|
|
||||||
((:any) (not (char=? c #\newline)))
|
|
||||||
;
|
|
||||||
((:alnum) (or (char-alphabetic? c) (char-numeric? c)))
|
|
||||||
((:alpha) (char-alphabetic? c))
|
|
||||||
((:ascii) (< (char->integer c) 128))
|
|
||||||
((:blank) (or (char=? c #\space) (char=? c *pregexp-tab-char*)))
|
|
||||||
((:cntrl) (< (char->integer c) 32))
|
|
||||||
((:digit) (char-numeric? c))
|
|
||||||
((:graph) (and (>= (char->integer c) 32)
|
|
||||||
(not (char-whitespace? c))))
|
|
||||||
((:lower) (char-lower-case? c))
|
|
||||||
((:print) (>= (char->integer c) 32))
|
|
||||||
((:punct) (and (>= (char->integer c) 32)
|
|
||||||
(not (char-whitespace? c))
|
|
||||||
(not (char-alphabetic? c))
|
|
||||||
(not (char-numeric? c))))
|
|
||||||
((:space) (char-whitespace? c))
|
|
||||||
((:upper) (char-upper-case? c))
|
|
||||||
((:word) (or (char-alphabetic? c)
|
|
||||||
(char-numeric? c)
|
|
||||||
(char=? c #\_)))
|
|
||||||
((:xdigit) (or (char-numeric? c)
|
|
||||||
(char-ci=? c #\a) (char-ci=? c #\b)
|
|
||||||
(char-ci=? c #\c) (char-ci=? c #\d)
|
|
||||||
(char-ci=? c #\e) (char-ci=? c #\f)))
|
|
||||||
(else (pregexp-error 'pregexp-check-if-in-char-class?)))))
|
|
||||||
|
|
||||||
(define pregexp-list-ref
|
|
||||||
(lambda (s i)
|
|
||||||
;like list-ref but returns #f if index is
|
|
||||||
;out of bounds
|
|
||||||
(let loop ((s s) (k 0))
|
|
||||||
(cond ((null? s) #f)
|
|
||||||
((= k i) (car s))
|
|
||||||
(else (loop (cdr s) (+ k 1)))))))
|
|
||||||
|
|
||||||
;re is a compiled regexp. It's a list that can't be
|
|
||||||
;nil. pregexp-match-positions-aux returns a 2-elt list whose
|
|
||||||
;car is the string-index following the matched
|
|
||||||
;portion and whose cadr contains the submatches.
|
|
||||||
;The proc returns false if there's no match.
|
|
||||||
|
|
||||||
;Am spelling loop- as loup- because these shouldn't
|
|
||||||
;be translated into CL loops by scm2cl (although
|
|
||||||
;they are tail-recursive in Scheme)
|
|
||||||
|
|
||||||
(define pregexp-make-backref-list
|
|
||||||
(lambda (re)
|
|
||||||
(let sub ((re re))
|
|
||||||
(if (pair? re)
|
|
||||||
(let ((car-re (car re))
|
|
||||||
(sub-cdr-re (sub (cdr re))))
|
|
||||||
(if (eqv? car-re ':sub)
|
|
||||||
(cons (cons re #f) sub-cdr-re)
|
|
||||||
(append (sub car-re) sub-cdr-re)))
|
|
||||||
'()))))
|
|
||||||
|
|
||||||
(define pregexp-match-positions-aux
|
|
||||||
(lambda (re s sn start n i)
|
|
||||||
(let ((identity (lambda (x) x))
|
|
||||||
(backrefs (pregexp-make-backref-list re))
|
|
||||||
(case-sensitive? #t))
|
|
||||||
(let sub ((re re) (i i) (sk identity) (fk (lambda () #f)))
|
|
||||||
;(printf "sub ~s ~s\n" i re)
|
|
||||||
(cond ((eqv? re ':bos)
|
|
||||||
;(if (= i 0) (sk i) (fk))
|
|
||||||
(if (= i start) (sk i) (fk))
|
|
||||||
)
|
|
||||||
((eqv? re ':eos)
|
|
||||||
;(if (>= i sn) (sk i) (fk))
|
|
||||||
(if (>= i n) (sk i) (fk))
|
|
||||||
)
|
|
||||||
((eqv? re ':empty)
|
|
||||||
(sk i))
|
|
||||||
((eqv? re ':wbdry)
|
|
||||||
(if (pregexp-at-word-boundary? s i n)
|
|
||||||
(sk i)
|
|
||||||
(fk)))
|
|
||||||
((eqv? re ':not-wbdry)
|
|
||||||
(if (pregexp-at-word-boundary? s i n)
|
|
||||||
(fk)
|
|
||||||
(sk i)))
|
|
||||||
((and (char? re) (< i n))
|
|
||||||
;(printf "bingo\n")
|
|
||||||
(if ((if case-sensitive? char=? char-ci=?)
|
|
||||||
(string-ref s i) re)
|
|
||||||
(sk (+ i 1)) (fk)))
|
|
||||||
((and (not (pair? re)) (< i n))
|
|
||||||
(if (pregexp-check-if-in-char-class?
|
|
||||||
(string-ref s i) re)
|
|
||||||
(sk (+ i 1)) (fk)))
|
|
||||||
((and (pair? re) (eqv? (car re) ':char-range) (< i n))
|
|
||||||
(let ((c (string-ref s i)))
|
|
||||||
(if (let ((c< (if case-sensitive? char<=? char-ci<=?)))
|
|
||||||
(and (c< (cadr re) c)
|
|
||||||
(c< c (caddr re))))
|
|
||||||
(sk (+ i 1)) (fk))))
|
|
||||||
((pair? re)
|
|
||||||
(case (car re)
|
|
||||||
((:char-range)
|
|
||||||
(if (>= i n) (fk)
|
|
||||||
(pregexp-error 'pregexp-match-positions-aux)))
|
|
||||||
((:one-of-chars)
|
|
||||||
(if (>= i n) (fk)
|
|
||||||
(let loup-one-of-chars ((chars (cdr re)))
|
|
||||||
(if (null? chars) (fk)
|
|
||||||
(sub (car chars) i sk
|
|
||||||
(lambda ()
|
|
||||||
(loup-one-of-chars (cdr chars))))))))
|
|
||||||
((:neg-char)
|
|
||||||
(if (>= i n) (fk)
|
|
||||||
(sub (cadr re) i
|
|
||||||
(lambda (i1) (fk))
|
|
||||||
(lambda () (sk (+ i 1))))))
|
|
||||||
((:seq)
|
|
||||||
(let loup-seq ((res (cdr re)) (i i))
|
|
||||||
(if (null? res) (sk i )
|
|
||||||
(sub (car res) i
|
|
||||||
(lambda (i1 )
|
|
||||||
(loup-seq (cdr res) i1 ))
|
|
||||||
fk))))
|
|
||||||
((:or)
|
|
||||||
(let loup-or ((res (cdr re)))
|
|
||||||
(if (null? res) (fk)
|
|
||||||
(sub (car res) i
|
|
||||||
(lambda (i1 )
|
|
||||||
(or (sk i1 )
|
|
||||||
(loup-or (cdr res))))
|
|
||||||
(lambda () (loup-or (cdr res)))))))
|
|
||||||
((:backref)
|
|
||||||
(let* ((c (pregexp-list-ref backrefs (cadr re)))
|
|
||||||
(backref
|
|
||||||
(cond (c => cdr)
|
|
||||||
(else
|
|
||||||
(pregexp-error 'pregexp-match-positions-aux
|
|
||||||
'non-existent-backref re)
|
|
||||||
#f))))
|
|
||||||
(if backref
|
|
||||||
(pregexp-string-match
|
|
||||||
(substring s (car backref) (cdr backref))
|
|
||||||
s i n (lambda (i) (sk i)) fk)
|
|
||||||
(sk i))))
|
|
||||||
((:sub)
|
|
||||||
(sub (cadr re) i
|
|
||||||
(lambda (i1)
|
|
||||||
(set-cdr! (assv re backrefs) (cons i i1))
|
|
||||||
(sk i1)) fk))
|
|
||||||
((:lookahead)
|
|
||||||
(let ((found-it?
|
|
||||||
(sub (cadr re) i
|
|
||||||
identity (lambda () #f))))
|
|
||||||
(if found-it? (sk i) (fk))))
|
|
||||||
((:neg-lookahead)
|
|
||||||
(let ((found-it?
|
|
||||||
(sub (cadr re) i
|
|
||||||
identity (lambda () #f))))
|
|
||||||
(if found-it? (fk) (sk i))))
|
|
||||||
((:lookbehind)
|
|
||||||
(let ((n-actual n) (sn-actual sn))
|
|
||||||
(set! n i) (set! sn i)
|
|
||||||
(let ((found-it?
|
|
||||||
(sub (list ':seq '(:between #f 0 #f :any)
|
|
||||||
(cadr re) ':eos) 0
|
|
||||||
identity (lambda () #f))))
|
|
||||||
(set! n n-actual) (set! sn sn-actual)
|
|
||||||
(if found-it? (sk i) (fk)))))
|
|
||||||
((:neg-lookbehind)
|
|
||||||
(let ((n-actual n) (sn-actual sn))
|
|
||||||
(set! n i) (set! sn i)
|
|
||||||
(let ((found-it?
|
|
||||||
(sub (list ':seq '(:between #f 0 #f :any)
|
|
||||||
(cadr re) ':eos) 0
|
|
||||||
identity (lambda () #f))))
|
|
||||||
(set! n n-actual) (set! sn sn-actual)
|
|
||||||
(if found-it? (fk) (sk i)))))
|
|
||||||
((:no-backtrack)
|
|
||||||
(let ((found-it? (sub (cadr re) i
|
|
||||||
identity (lambda () #f))))
|
|
||||||
(if found-it?
|
|
||||||
(sk found-it?)
|
|
||||||
(fk))))
|
|
||||||
((:case-sensitive :case-insensitive)
|
|
||||||
(let ((old case-sensitive?))
|
|
||||||
(set! case-sensitive?
|
|
||||||
(eqv? (car re) ':case-sensitive))
|
|
||||||
(sub (cadr re) i
|
|
||||||
(lambda (i1)
|
|
||||||
(set! case-sensitive? old)
|
|
||||||
(sk i1))
|
|
||||||
(lambda ()
|
|
||||||
(set! case-sensitive? old)
|
|
||||||
(fk)))))
|
|
||||||
((:between)
|
|
||||||
(let* ((maximal? (not (cadr re)))
|
|
||||||
(p (caddr re))
|
|
||||||
(q (cadddr re))
|
|
||||||
(could-loop-infinitely? (and maximal? (not q)))
|
|
||||||
(re (car (cddddr re))))
|
|
||||||
(let loup-p ((k 0) (i i) )
|
|
||||||
(if (< k p)
|
|
||||||
(sub re i
|
|
||||||
(lambda (i1 )
|
|
||||||
(if (and could-loop-infinitely?
|
|
||||||
(= i1 i))
|
|
||||||
(pregexp-error
|
|
||||||
'pregexp-match-positions-aux
|
|
||||||
'greedy-quantifier-operand-could-be-empty))
|
|
||||||
(loup-p (+ k 1) i1 ))
|
|
||||||
fk)
|
|
||||||
(let ((q (and q (- q p))))
|
|
||||||
(let loup-q ((k 0) (i i))
|
|
||||||
(let ((fk (lambda ()
|
|
||||||
(sk i ))))
|
|
||||||
(if (and q (>= k q)) (fk)
|
|
||||||
(if maximal?
|
|
||||||
(sub re i
|
|
||||||
(lambda (i1)
|
|
||||||
(if (and could-loop-infinitely?
|
|
||||||
(= i1 i))
|
|
||||||
(pregexp-error
|
|
||||||
'pregexp-match-positions-aux
|
|
||||||
'greedy-quantifier-operand-could-be-empty))
|
|
||||||
(or (loup-q (+ k 1) i1)
|
|
||||||
(fk)))
|
|
||||||
fk)
|
|
||||||
(or (fk)
|
|
||||||
(sub re i
|
|
||||||
(lambda (i1)
|
|
||||||
(loup-q (+ k 1) i1))
|
|
||||||
fk)))))))))))
|
|
||||||
(else (pregexp-error 'pregexp-match-positions-aux))))
|
|
||||||
((>= i n) (fk))
|
|
||||||
(else (pregexp-error 'pregexp-match-positions-aux))))
|
|
||||||
;(printf "done\n")
|
|
||||||
(let ((backrefs (map cdr backrefs)))
|
|
||||||
(and (car backrefs) backrefs)))))
|
|
||||||
|
|
||||||
(define pregexp-replace-aux
|
|
||||||
(lambda (str ins n backrefs)
|
|
||||||
(let loop ((i 0) (r ""))
|
|
||||||
(if (>= i n) r
|
|
||||||
(let ((c (string-ref ins i)))
|
|
||||||
(if (char=? c #\\ )
|
|
||||||
(let* ((br-i (pregexp-read-escaped-number ins i n))
|
|
||||||
(br (if br-i (car br-i)
|
|
||||||
(if (char=? (string-ref ins (+ i 1)) #\&) 0
|
|
||||||
#f)))
|
|
||||||
(i (if br-i (cadr br-i)
|
|
||||||
(if br (+ i 2)
|
|
||||||
(+ i 1)))))
|
|
||||||
(if (not br)
|
|
||||||
(let ((c2 (string-ref ins i)))
|
|
||||||
(loop (+ i 1)
|
|
||||||
(if (char=? c2 #\$) r
|
|
||||||
(string-append r (string c2)))))
|
|
||||||
(loop i
|
|
||||||
(let ((backref (pregexp-list-ref backrefs br)))
|
|
||||||
(if backref
|
|
||||||
(string-append r
|
|
||||||
(substring str (car backref) (cdr backref)))
|
|
||||||
r)))))
|
|
||||||
(loop (+ i 1) (string-append r (string c)))))))))
|
|
||||||
|
|
||||||
(define pregexp-proc
|
|
||||||
(let ([pregexp
|
|
||||||
(lambda (s)
|
|
||||||
(set! *pregexp-space-sensitive?* #t) ;in case it got corrupted
|
|
||||||
(list ':sub (car (pregexp-read-pattern s 0 (string-length s)))))])
|
|
||||||
pregexp))
|
|
||||||
|
|
||||||
(define-syntax pregexp
|
|
||||||
(lambda (x) ;;; aziz's touch
|
|
||||||
(syntax-case x ()
|
|
||||||
[(_ str)
|
|
||||||
(string? (syntax->datum #'str))
|
|
||||||
#'(let-syntax ([foo
|
|
||||||
(lambda (t)
|
|
||||||
(with-syntax ([c (datum->syntax #'_
|
|
||||||
(pregexp-proc str))])
|
|
||||||
#'(quote c)))])
|
|
||||||
foo)]
|
|
||||||
[(_ args ...) #'(pregexp-proc args ...)]
|
|
||||||
[id (identifier? #'id) #'pregexp-proc])))
|
|
||||||
|
|
||||||
|
|
||||||
(define-syntax define-regexp-proc
|
|
||||||
(lambda (stx)
|
|
||||||
(syntax-case stx ()
|
|
||||||
[(_ name expr)
|
|
||||||
(with-syntax ([(name^) (generate-temporaries (list #'name))])
|
|
||||||
#'(begin
|
|
||||||
(define name^ expr)
|
|
||||||
(define-syntax name
|
|
||||||
(lambda (x)
|
|
||||||
(syntax-case x ()
|
|
||||||
[(_ str args (... ...)) (string? #'str)
|
|
||||||
#'(name^ (pregexp str) args (... ...))]
|
|
||||||
[(_ args (... ...))
|
|
||||||
#'(name^ args (... ...))]
|
|
||||||
[id (identifier? #'id) #'name^])))))])))
|
|
||||||
|
|
||||||
|
|
||||||
(define-regexp-proc pregexp-match-positions
|
|
||||||
(lambda (pat str . opt-args)
|
|
||||||
(cond ((string? pat) (set! pat (pregexp pat)))
|
|
||||||
((pair? pat) #t)
|
|
||||||
(else (pregexp-error 'pregexp-match-positions
|
|
||||||
'pattern-must-be-compiled-or-string-regexp
|
|
||||||
pat)))
|
|
||||||
(let* ((str-len (string-length str))
|
|
||||||
(start (if (null? opt-args) 0
|
|
||||||
(let ((start (car opt-args)))
|
|
||||||
(set! opt-args (cdr opt-args))
|
|
||||||
start)))
|
|
||||||
(end (if (null? opt-args) str-len
|
|
||||||
(car opt-args))))
|
|
||||||
(let loop ((i start))
|
|
||||||
(and (<= i end)
|
|
||||||
(or (pregexp-match-positions-aux
|
|
||||||
pat str str-len start end i)
|
|
||||||
(loop (+ i 1))))))))
|
|
||||||
|
|
||||||
|
|
||||||
(define-regexp-proc pregexp-match
|
|
||||||
(lambda (pat str . opt-args)
|
|
||||||
(let ((ix-prs (apply pregexp-match-positions pat str opt-args)))
|
|
||||||
(and ix-prs
|
|
||||||
(map
|
|
||||||
(lambda (ix-pr)
|
|
||||||
(and ix-pr
|
|
||||||
(substring str (car ix-pr) (cdr ix-pr))))
|
|
||||||
ix-prs)))))
|
|
||||||
|
|
||||||
(define-regexp-proc pregexp-split
|
|
||||||
(lambda (pat str)
|
|
||||||
;split str into substrings, using pat as delimiter
|
|
||||||
(let ((n (string-length str))
|
|
||||||
;;; aziz
|
|
||||||
(pat (if (string? pat) (pregexp pat) pat)))
|
|
||||||
(let loop ((i 0) (r '()) (picked-up-one-undelimited-char? #f))
|
|
||||||
(cond ((>= i n) (pregexp-reverse! r))
|
|
||||||
((pregexp-match-positions pat str i n)
|
|
||||||
=>
|
|
||||||
(lambda (y)
|
|
||||||
(let ((jk (car y)))
|
|
||||||
(let ((j (car jk)) (k (cdr jk)))
|
|
||||||
;(printf "j = ~a; k = ~a; i = ~a~n" j k i)
|
|
||||||
(cond ((= j k)
|
|
||||||
;(printf "producing ~s~n" (substring str i (+ j 1)))
|
|
||||||
(loop (+ k 1)
|
|
||||||
(cons (substring str i (+ j 1)) r) #t))
|
|
||||||
((and (= j i) picked-up-one-undelimited-char?)
|
|
||||||
(loop k r #f))
|
|
||||||
(else
|
|
||||||
;(printf "producing ~s~n" (substring str i j))
|
|
||||||
(loop k (cons (substring str i j) r) #f)))))))
|
|
||||||
(else (loop n (cons (substring str i n) r) #f)))))))
|
|
||||||
|
|
||||||
|
|
||||||
(define-regexp-proc pregexp-replace
|
|
||||||
(lambda (pat str ins)
|
|
||||||
(let* ((n (string-length str))
|
|
||||||
(pp (pregexp-match-positions pat str 0 n)))
|
|
||||||
(if (not pp) str
|
|
||||||
(let ((ins-len (string-length ins))
|
|
||||||
(m-i (caar pp))
|
|
||||||
(m-n (cdar pp)))
|
|
||||||
(string-append
|
|
||||||
(substring str 0 m-i)
|
|
||||||
(pregexp-replace-aux str ins ins-len pp)
|
|
||||||
(substring str m-n n)))))))
|
|
||||||
|
|
||||||
(define-regexp-proc pregexp-replace*
|
|
||||||
(lambda (pat str ins)
|
|
||||||
;return str with every occurrence of pat
|
|
||||||
;replaced by ins
|
|
||||||
(let ((pat (if (string? pat) (pregexp pat) pat))
|
|
||||||
(n (string-length str))
|
|
||||||
(ins-len (string-length ins)))
|
|
||||||
(let loop ((i 0) (r ""))
|
|
||||||
;i = index in str to start replacing from
|
|
||||||
;r = already calculated prefix of answer
|
|
||||||
(if (>= i n) r
|
|
||||||
(let ((pp (pregexp-match-positions pat str i n)))
|
|
||||||
(if (not pp)
|
|
||||||
(if (= i 0)
|
|
||||||
;this implies pat didn't match str at
|
|
||||||
;all, so let's return original str
|
|
||||||
str
|
|
||||||
;else: all matches already found and
|
|
||||||
;replaced in r, so let's just
|
|
||||||
;append the rest of str
|
|
||||||
(string-append
|
|
||||||
r (substring str i n)))
|
|
||||||
(loop (cdar pp)
|
|
||||||
(string-append
|
|
||||||
r
|
|
||||||
(substring str i (caar pp))
|
|
||||||
(pregexp-replace-aux str ins ins-len pp))))))))))
|
|
||||||
|
|
||||||
(define pregexp-quote
|
|
||||||
(lambda (s)
|
|
||||||
(let loop ((i (- (string-length s) 1)) (r '()))
|
|
||||||
(if (< i 0) (list->string r)
|
|
||||||
(loop (- i 1)
|
|
||||||
(let ((c (string-ref s i)))
|
|
||||||
(if (memv c '(#\\ #\. #\? #\* #\+ #\| #\^ #\$
|
|
||||||
#\[ #\] #\{ #\} #\( #\)))
|
|
||||||
(cons #\\ (cons c r))
|
|
||||||
(cons c r))))))))
|
|
||||||
|
|
||||||
)
|
|
||||||
|
|
@ -1,38 +0,0 @@
|
||||||
#!r6rs
|
|
||||||
;;; This file is part of SRFI-41: streams
|
|
||||||
;;; It is included in Ikarus for your convenience.
|
|
||||||
;;; Refer to http://srfi.schemers.org/srfi-41/srfi-41.html for
|
|
||||||
;;; details.
|
|
||||||
;;;
|
|
||||||
;;; Copyright (C) Philip L. Bewig (2007). All Rights Reserved.
|
|
||||||
;;; Permission is hereby granted, free of charge, to any person
|
|
||||||
;;; obtaining a copy of this software and associated documentation files
|
|
||||||
;;; (the "Software"), to deal in the Software without restriction,
|
|
||||||
;;; including without limitation the rights to use, copy, modify, merge,
|
|
||||||
;;; publish, distribute, sublicense, and/or sell copies of the Software,
|
|
||||||
;;; and to permit persons to whom the Software is furnished to do so,
|
|
||||||
;;; subject to the following conditions:
|
|
||||||
;;;
|
|
||||||
;;; The above copyright notice and this permission notice shall be
|
|
||||||
;;; included in all copies or substantial portions of the Software.
|
|
||||||
;;;
|
|
||||||
;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
|
|
||||||
;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
|
|
||||||
;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
|
|
||||||
;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS
|
|
||||||
;;; BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN
|
|
||||||
;;; ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN
|
|
||||||
;;; CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
|
|
||||||
;;; SOFTWARE.
|
|
||||||
|
|
||||||
(library (streams)
|
|
||||||
|
|
||||||
(export stream-null stream-cons stream? stream-null? stream-pair? stream-car
|
|
||||||
stream-cdr stream-lambda define-stream list->stream port->stream stream
|
|
||||||
stream->list stream-append stream-concat stream-constant stream-drop
|
|
||||||
stream-drop-while stream-filter stream-fold stream-for-each stream-from
|
|
||||||
stream-iterate stream-length stream-let stream-map stream-match
|
|
||||||
stream-of stream-range stream-ref stream-reverse stream-scan stream-take
|
|
||||||
stream-take-while stream-unfold stream-unfolds stream-zip)
|
|
||||||
|
|
||||||
(import (streams primitive) (streams derived)))
|
|
||||||
|
|
@ -1,387 +0,0 @@
|
||||||
#!r6rs
|
|
||||||
;;; This file is part of SRFI-41: streams
|
|
||||||
;;; It is included in Ikarus for your convenience.
|
|
||||||
;;; Refer to http://srfi.schemers.org/srfi-41/srfi-41.html for
|
|
||||||
;;; details.
|
|
||||||
;;;
|
|
||||||
;;; Copyright (C) Philip L. Bewig (2007). All Rights Reserved.
|
|
||||||
;;; Permission is hereby granted, free of charge, to any person
|
|
||||||
;;; obtaining a copy of this software and associated documentation files
|
|
||||||
;;; (the "Software"), to deal in the Software without restriction,
|
|
||||||
;;; including without limitation the rights to use, copy, modify, merge,
|
|
||||||
;;; publish, distribute, sublicense, and/or sell copies of the Software,
|
|
||||||
;;; and to permit persons to whom the Software is furnished to do so,
|
|
||||||
;;; subject to the following conditions:
|
|
||||||
;;;
|
|
||||||
;;; The above copyright notice and this permission notice shall be
|
|
||||||
;;; included in all copies or substantial portions of the Software.
|
|
||||||
;;;
|
|
||||||
;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
|
|
||||||
;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
|
|
||||||
;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
|
|
||||||
;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS
|
|
||||||
;;; BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN
|
|
||||||
;;; ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN
|
|
||||||
;;; CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
|
|
||||||
;;; SOFTWARE.
|
|
||||||
|
|
||||||
(library (streams derived)
|
|
||||||
|
|
||||||
(export stream-null stream-cons stream? stream-null? stream-pair? stream-car
|
|
||||||
stream-cdr stream-lambda define-stream list->stream port->stream stream
|
|
||||||
stream->list stream-append stream-concat stream-constant stream-drop
|
|
||||||
stream-drop-while stream-filter stream-fold stream-for-each stream-from
|
|
||||||
stream-iterate stream-length stream-let stream-map stream-match
|
|
||||||
stream-of stream-range stream-ref stream-reverse stream-scan stream-take
|
|
||||||
stream-take-while stream-unfold stream-unfolds stream-zip)
|
|
||||||
|
|
||||||
(import (rnrs) (streams primitive))
|
|
||||||
|
|
||||||
(define-syntax define-stream
|
|
||||||
(syntax-rules ()
|
|
||||||
((define-stream (name . formal) body0 body1 ...)
|
|
||||||
(define name (stream-lambda formal body0 body1 ...)))))
|
|
||||||
|
|
||||||
(define (list->stream objs)
|
|
||||||
(define list->stream
|
|
||||||
(stream-lambda (objs)
|
|
||||||
(if (null? objs)
|
|
||||||
stream-null
|
|
||||||
(stream-cons (car objs) (list->stream (cdr objs))))))
|
|
||||||
(if (not (list? objs))
|
|
||||||
(error 'list->stream "non-list argument")
|
|
||||||
(list->stream objs)))
|
|
||||||
|
|
||||||
(define (port->stream . port)
|
|
||||||
(define port->stream
|
|
||||||
(stream-lambda (p)
|
|
||||||
(let ((c (read-char p)))
|
|
||||||
(if (eof-object? c)
|
|
||||||
stream-null
|
|
||||||
(stream-cons c (port->stream p))))))
|
|
||||||
(let ((p (if (null? port) (current-input-port) (car port))))
|
|
||||||
(if (not (input-port? p))
|
|
||||||
(error 'port->stream "non-input-port argument")
|
|
||||||
(port->stream p))))
|
|
||||||
|
|
||||||
(define-syntax stream
|
|
||||||
(syntax-rules ()
|
|
||||||
((stream) stream-null)
|
|
||||||
((stream x y ...) (stream-cons x (stream y ...)))))
|
|
||||||
|
|
||||||
(define (stream->list . args)
|
|
||||||
(let ((n (if (= 1 (length args)) #f (car args)))
|
|
||||||
(strm (if (= 1 (length args)) (car args) (cadr args))))
|
|
||||||
(cond ((not (stream? strm)) (error 'stream->list "non-stream argument"))
|
|
||||||
((and n (not (integer? n))) (error 'stream->list "non-integer count"))
|
|
||||||
((and n (negative? n)) (error 'stream->list "negative count"))
|
|
||||||
(else (let loop ((n (if n n -1)) (strm strm))
|
|
||||||
(if (or (zero? n) (stream-null? strm))
|
|
||||||
'()
|
|
||||||
(cons (stream-car strm) (loop (- n 1) (stream-cdr strm)))))))))
|
|
||||||
|
|
||||||
(define (stream-append . strms)
|
|
||||||
(define stream-append
|
|
||||||
(stream-lambda (strms)
|
|
||||||
(cond ((null? (cdr strms)) (car strms))
|
|
||||||
((stream-null? (car strms)) (stream-append (cdr strms)))
|
|
||||||
(else (stream-cons (stream-car (car strms))
|
|
||||||
(stream-append (cons (stream-cdr (car strms)) (cdr strms))))))))
|
|
||||||
(cond ((null? strms) stream-null)
|
|
||||||
((exists (lambda (x) (not (stream? x))) strms)
|
|
||||||
(error 'stream-append "non-stream argument"))
|
|
||||||
(else (stream-append strms))))
|
|
||||||
|
|
||||||
(define (stream-concat strms)
|
|
||||||
(define stream-concat
|
|
||||||
(stream-lambda (strms)
|
|
||||||
(cond ((stream-null? strms) stream-null)
|
|
||||||
((not (stream? (stream-car strms)))
|
|
||||||
(error 'stream-concat "non-stream object in input stream"))
|
|
||||||
((stream-null? (stream-car strms))
|
|
||||||
(stream-concat (stream-cdr strms)))
|
|
||||||
(else (stream-cons
|
|
||||||
(stream-car (stream-car strms))
|
|
||||||
(stream-concat
|
|
||||||
(stream-cons (stream-cdr (stream-car strms)) (stream-cdr strms))))))))
|
|
||||||
(if (not (stream? strms))
|
|
||||||
(error 'stream-concat "non-stream argument")
|
|
||||||
(stream-concat strms)))
|
|
||||||
|
|
||||||
(define stream-constant
|
|
||||||
(stream-lambda objs
|
|
||||||
(cond ((null? objs) stream-null)
|
|
||||||
((null? (cdr objs)) (stream-cons (car objs) (stream-constant (car objs))))
|
|
||||||
(else (stream-cons (car objs)
|
|
||||||
(apply stream-constant (append (cdr objs) (list (car objs)))))))))
|
|
||||||
|
|
||||||
(define (stream-drop n strm)
|
|
||||||
(define stream-drop
|
|
||||||
(stream-lambda (n strm)
|
|
||||||
(if (or (zero? n) (stream-null? strm))
|
|
||||||
strm
|
|
||||||
(stream-drop (- n 1) (stream-cdr strm)))))
|
|
||||||
(cond ((not (integer? n)) (error 'stream-drop "non-integer argument"))
|
|
||||||
((negative? n) (error 'stream-drop "negative argument"))
|
|
||||||
((not (stream? strm)) (error 'stream-drop "non-stream argument"))
|
|
||||||
(else (stream-drop n strm))))
|
|
||||||
|
|
||||||
(define (stream-drop-while pred? strm)
|
|
||||||
(define stream-drop-while
|
|
||||||
(stream-lambda (strm)
|
|
||||||
(if (and (stream-pair? strm) (pred? (stream-car strm)))
|
|
||||||
(stream-drop-while (stream-cdr strm))
|
|
||||||
strm)))
|
|
||||||
(cond ((not (procedure? pred?)) (error 'stream-drop-while "non-procedural argument"))
|
|
||||||
((not (stream? strm)) (error 'stream-drop-while "non-stream argument"))
|
|
||||||
(else (stream-drop-while strm))))
|
|
||||||
|
|
||||||
(define (stream-filter pred? strm)
|
|
||||||
(define stream-filter
|
|
||||||
(stream-lambda (strm)
|
|
||||||
(cond ((stream-null? strm) stream-null)
|
|
||||||
((pred? (stream-car strm))
|
|
||||||
(stream-cons (stream-car strm) (stream-filter (stream-cdr strm))))
|
|
||||||
(else (stream-filter (stream-cdr strm))))))
|
|
||||||
(cond ((not (procedure? pred?)) (error 'stream-filter "non-procedural argument"))
|
|
||||||
((not (stream? strm)) (error 'stream-filter "non-stream argument"))
|
|
||||||
(else (stream-filter strm))))
|
|
||||||
|
|
||||||
(define (stream-fold proc base strm)
|
|
||||||
(cond ((not (procedure? proc)) (error 'stream-fold "non-procedural argument"))
|
|
||||||
((not (stream? strm)) (error 'stream-fold "non-stream argument"))
|
|
||||||
(else (let loop ((base base) (strm strm))
|
|
||||||
(if (stream-null? strm)
|
|
||||||
base
|
|
||||||
(loop (proc base (stream-car strm)) (stream-cdr strm)))))))
|
|
||||||
|
|
||||||
(define (stream-for-each proc . strms)
|
|
||||||
(define (stream-for-each strms)
|
|
||||||
(if (not (exists stream-null? strms))
|
|
||||||
(begin (apply proc (map stream-car strms))
|
|
||||||
(stream-for-each (map stream-cdr strms)))))
|
|
||||||
(cond ((not (procedure? proc)) (error 'stream-for-each "non-procedural argument"))
|
|
||||||
((null? strms) (error 'stream-for-each "no stream arguments"))
|
|
||||||
((exists (lambda (x) (not (stream? x))) strms)
|
|
||||||
(error 'stream-for-each "non-stream argument"))
|
|
||||||
(else (stream-for-each strms))))
|
|
||||||
|
|
||||||
(define (stream-from first . step)
|
|
||||||
(define stream-from
|
|
||||||
(stream-lambda (first delta)
|
|
||||||
(stream-cons first (stream-from (+ first delta) delta))))
|
|
||||||
(let ((delta (if (null? step) 1 (car step))))
|
|
||||||
(cond ((not (number? first)) (error 'stream-from "non-numeric starting number"))
|
|
||||||
((not (number? delta)) (error 'stream-from "non-numeric step size"))
|
|
||||||
(else (stream-from first delta)))))
|
|
||||||
|
|
||||||
(define (stream-iterate proc base)
|
|
||||||
(define stream-iterate
|
|
||||||
(stream-lambda (base)
|
|
||||||
(stream-cons base (stream-iterate (proc base)))))
|
|
||||||
(if (not (procedure? proc))
|
|
||||||
(error 'stream-iterate "non-procedural argument")
|
|
||||||
(stream-iterate base)))
|
|
||||||
|
|
||||||
(define (stream-length strm)
|
|
||||||
(if (not (stream? strm))
|
|
||||||
(error 'stream-length "non-stream argument")
|
|
||||||
(let loop ((len 0) (strm strm))
|
|
||||||
(if (stream-null? strm)
|
|
||||||
len
|
|
||||||
(loop (+ len 1) (stream-cdr strm))))))
|
|
||||||
|
|
||||||
(define-syntax stream-let
|
|
||||||
(syntax-rules ()
|
|
||||||
((stream-let tag ((name val) ...) body1 body2 ...)
|
|
||||||
((letrec ((tag (stream-lambda (name ...) body1 body2 ...))) tag) val ...))))
|
|
||||||
|
|
||||||
(define (stream-map proc . strms)
|
|
||||||
(define stream-map
|
|
||||||
(stream-lambda (strms)
|
|
||||||
(if (exists stream-null? strms)
|
|
||||||
stream-null
|
|
||||||
(stream-cons (apply proc (map stream-car strms))
|
|
||||||
(stream-map (map stream-cdr strms))))))
|
|
||||||
(cond ((not (procedure? proc)) (error 'stream-map "non-procedural argument"))
|
|
||||||
((null? strms) (error 'stream-map "no stream arguments"))
|
|
||||||
((exists (lambda (x) (not (stream? x))) strms)
|
|
||||||
(error 'stream-map "non-stream argument"))
|
|
||||||
(else (stream-map strms))))
|
|
||||||
|
|
||||||
(define-syntax stream-match
|
|
||||||
(syntax-rules ()
|
|
||||||
((stream-match strm-expr clause ...)
|
|
||||||
(let ((strm strm-expr))
|
|
||||||
(cond
|
|
||||||
((not (stream? strm)) (error 'stream-match "non-stream argument"))
|
|
||||||
((stream-match-test strm clause) => car) ...
|
|
||||||
(else (error 'stream-match "pattern failure")))))))
|
|
||||||
|
|
||||||
(define-syntax stream-match-test
|
|
||||||
(syntax-rules ()
|
|
||||||
((stream-match-test strm (pattern fender expr))
|
|
||||||
(stream-match-pattern strm pattern () (and fender (list expr))))
|
|
||||||
((stream-match-test strm (pattern expr))
|
|
||||||
(stream-match-pattern strm pattern () (list expr)))))
|
|
||||||
|
|
||||||
(define-syntax stream-match-pattern
|
|
||||||
(lambda (x)
|
|
||||||
(define (wildcard? x)
|
|
||||||
(and (identifier? x)
|
|
||||||
(free-identifier=? x (syntax _))))
|
|
||||||
(syntax-case x ()
|
|
||||||
((stream-match-pattern strm () (binding ...) body)
|
|
||||||
(syntax (and (stream-null? strm) (let (binding ...) body))))
|
|
||||||
((stream-match-pattern strm (w? . rest) (binding ...) body)
|
|
||||||
(wildcard? #'w?)
|
|
||||||
(syntax (and (stream-pair? strm)
|
|
||||||
(let ((strm (stream-cdr strm)))
|
|
||||||
(stream-match-pattern strm rest (binding ...) body)))))
|
|
||||||
((stream-match-pattern strm (var . rest) (binding ...) body)
|
|
||||||
(syntax (and (stream-pair? strm)
|
|
||||||
(let ((temp (stream-car strm)) (strm (stream-cdr strm)))
|
|
||||||
(stream-match-pattern strm rest ((var temp) binding ...) body)))))
|
|
||||||
((stream-match-pattern strm w? (binding ...) body)
|
|
||||||
(wildcard? #'w?)
|
|
||||||
(syntax (let (binding ...) body)))
|
|
||||||
((stream-match-pattern strm var (binding ...) body)
|
|
||||||
(syntax (let ((var strm) binding ...) body))))))
|
|
||||||
|
|
||||||
(define-syntax stream-of
|
|
||||||
(syntax-rules ()
|
|
||||||
((_ expr rest ...)
|
|
||||||
(stream-of-aux expr stream-null rest ...))))
|
|
||||||
|
|
||||||
(define-syntax stream-of-aux
|
|
||||||
(syntax-rules (in is)
|
|
||||||
((stream-of-aux expr base)
|
|
||||||
(stream-cons expr base))
|
|
||||||
((stream-of-aux expr base (var in stream) rest ...)
|
|
||||||
(stream-let loop ((strm stream))
|
|
||||||
(if (stream-null? strm)
|
|
||||||
base
|
|
||||||
(let ((var (stream-car strm)))
|
|
||||||
(stream-of-aux expr (loop (stream-cdr strm)) rest ...)))))
|
|
||||||
((stream-of-aux expr base (var is exp) rest ...)
|
|
||||||
(let ((var exp)) (stream-of-aux expr base rest ...)))
|
|
||||||
((stream-of-aux expr base pred? rest ...)
|
|
||||||
(if pred? (stream-of-aux expr base rest ...) base))))
|
|
||||||
|
|
||||||
(define (stream-range first past . step)
|
|
||||||
(define stream-range
|
|
||||||
(stream-lambda (first past delta lt?)
|
|
||||||
(if (lt? first past)
|
|
||||||
(stream-cons first (stream-range (+ first delta) past delta lt?))
|
|
||||||
stream-null)))
|
|
||||||
(cond ((not (number? first)) (error 'stream-range "non-numeric starting number"))
|
|
||||||
((not (number? past)) (error 'stream-range "non-numeric ending number"))
|
|
||||||
(else (let ((delta (cond ((pair? step) (car step)) ((< first past) 1) (else -1))))
|
|
||||||
(if (not (number? delta))
|
|
||||||
(error 'stream-range "non-numeric step size")
|
|
||||||
(let ((lt? (if (< 0 delta) < >)))
|
|
||||||
(stream-range first past delta lt?)))))))
|
|
||||||
|
|
||||||
(define (stream-ref strm n)
|
|
||||||
(cond ((not (stream? strm)) (error 'stream-ref "non-stream argument"))
|
|
||||||
((not (integer? n)) (error 'stream-ref "non-integer argument"))
|
|
||||||
((negative? n) (error 'stream-ref "negative argument"))
|
|
||||||
(else (let loop ((strm strm) (n n))
|
|
||||||
(cond ((stream-null? strm) (error 'stream-ref "beyond end of stream"))
|
|
||||||
((zero? n) (stream-car strm))
|
|
||||||
(else (loop (stream-cdr strm) (- n 1))))))))
|
|
||||||
|
|
||||||
(define (stream-reverse strm)
|
|
||||||
(define stream-reverse
|
|
||||||
(stream-lambda (strm rev)
|
|
||||||
(if (stream-null? strm)
|
|
||||||
rev
|
|
||||||
(stream-reverse (stream-cdr strm) (stream-cons (stream-car strm) rev)))))
|
|
||||||
(if (not (stream? strm))
|
|
||||||
(error 'stream-reverse "non-stream argument")
|
|
||||||
(stream-reverse strm stream-null)))
|
|
||||||
|
|
||||||
(define (stream-scan proc base strm)
|
|
||||||
(define stream-scan
|
|
||||||
(stream-lambda (base strm)
|
|
||||||
(if (stream-null? strm)
|
|
||||||
(stream base)
|
|
||||||
(stream-cons base (stream-scan (proc base (stream-car strm)) (stream-cdr strm))))))
|
|
||||||
(cond ((not (procedure? proc)) (error 'stream-scan "non-procedural argument"))
|
|
||||||
((not (stream? strm)) (error 'stream-scan "non-stream argument"))
|
|
||||||
(else (stream-scan base strm))))
|
|
||||||
|
|
||||||
(define (stream-take n strm)
|
|
||||||
(define stream-take
|
|
||||||
(stream-lambda (n strm)
|
|
||||||
(if (or (stream-null? strm) (zero? n))
|
|
||||||
stream-null
|
|
||||||
(stream-cons (stream-car strm) (stream-take (- n 1) (stream-cdr strm))))))
|
|
||||||
(cond ((not (stream? strm)) (error 'stream-take "non-stream argument"))
|
|
||||||
((not (integer? n)) (error 'stream-take "non-integer argument"))
|
|
||||||
((negative? n) (error 'stream-take "negative argument"))
|
|
||||||
(else (stream-take n strm))))
|
|
||||||
|
|
||||||
(define (stream-take-while pred? strm)
|
|
||||||
(define stream-take-while
|
|
||||||
(stream-lambda (strm)
|
|
||||||
(cond ((stream-null? strm) stream-null)
|
|
||||||
((pred? (stream-car strm))
|
|
||||||
(stream-cons (stream-car strm) (stream-take-while (stream-cdr strm))))
|
|
||||||
(else stream-null))))
|
|
||||||
(cond ((not (stream? strm)) (error 'stream-take-while "non-stream argument"))
|
|
||||||
((not (procedure? pred?)) (error 'stream-take-while "non-procedural argument"))
|
|
||||||
(else (stream-take-while strm))))
|
|
||||||
|
|
||||||
(define (stream-unfold mapper pred? generator base)
|
|
||||||
(define stream-unfold
|
|
||||||
(stream-lambda (base)
|
|
||||||
(if (pred? base)
|
|
||||||
(stream-cons (mapper base) (stream-unfold (generator base)))
|
|
||||||
stream-null)))
|
|
||||||
(cond ((not (procedure? mapper)) (error 'stream-unfold "non-procedural mapper"))
|
|
||||||
((not (procedure? pred?)) (error 'stream-unfold "non-procedural pred?"))
|
|
||||||
((not (procedure? generator)) (error 'stream-unfold "non-procedural generator"))
|
|
||||||
(else (stream-unfold base))))
|
|
||||||
|
|
||||||
(define (stream-unfolds gen seed)
|
|
||||||
(define (len-values gen seed)
|
|
||||||
(call-with-values
|
|
||||||
(lambda () (gen seed))
|
|
||||||
(lambda vs (- (length vs) 1))))
|
|
||||||
(define unfold-result-stream
|
|
||||||
(stream-lambda (gen seed)
|
|
||||||
(call-with-values
|
|
||||||
(lambda () (gen seed))
|
|
||||||
(lambda (next . results)
|
|
||||||
(stream-cons results (unfold-result-stream gen next))))))
|
|
||||||
(define result-stream->output-stream
|
|
||||||
(stream-lambda (result-stream i)
|
|
||||||
(let ((result (list-ref (stream-car result-stream) (- i 1))))
|
|
||||||
(cond ((pair? result)
|
|
||||||
(stream-cons
|
|
||||||
(car result)
|
|
||||||
(result-stream->output-stream (stream-cdr result-stream) i)))
|
|
||||||
((not result)
|
|
||||||
(result-stream->output-stream (stream-cdr result-stream) i))
|
|
||||||
((null? result) stream-null)
|
|
||||||
(else (error 'stream-unfolds "can't happen"))))))
|
|
||||||
(define (result-stream->output-streams result-stream)
|
|
||||||
(let loop ((i (len-values gen seed)) (outputs '()))
|
|
||||||
(if (zero? i)
|
|
||||||
(apply values outputs)
|
|
||||||
(loop (- i 1) (cons (result-stream->output-stream result-stream i) outputs)))))
|
|
||||||
(if (not (procedure? gen))
|
|
||||||
(error 'stream-unfolds "non-procedural argument")
|
|
||||||
(result-stream->output-streams (unfold-result-stream gen seed))))
|
|
||||||
|
|
||||||
(define (stream-zip . strms)
|
|
||||||
(define stream-zip
|
|
||||||
(stream-lambda (strms)
|
|
||||||
(if (exists stream-null? strms)
|
|
||||||
stream-null
|
|
||||||
(stream-cons (map stream-car strms) (stream-zip (map stream-cdr strms))))))
|
|
||||||
(cond ((null? strms) (error 'stream-zip "no stream arguments"))
|
|
||||||
((exists (lambda (x) (not (stream? x))) strms)
|
|
||||||
(error 'stream-zip "non-stream argument"))
|
|
||||||
(else (stream-zip strms)))))
|
|
||||||
|
|
@ -1,96 +0,0 @@
|
||||||
#!r6rs
|
|
||||||
;;; This file is part of SRFI-41: streams
|
|
||||||
;;; It is included in Ikarus for your convenience.
|
|
||||||
;;; Refer to http://srfi.schemers.org/srfi-41/srfi-41.html for
|
|
||||||
;;; details.
|
|
||||||
;;;
|
|
||||||
;;; Copyright (C) Philip L. Bewig (2007). All Rights Reserved.
|
|
||||||
;;; Permission is hereby granted, free of charge, to any person
|
|
||||||
;;; obtaining a copy of this software and associated documentation files
|
|
||||||
;;; (the "Software"), to deal in the Software without restriction,
|
|
||||||
;;; including without limitation the rights to use, copy, modify, merge,
|
|
||||||
;;; publish, distribute, sublicense, and/or sell copies of the Software,
|
|
||||||
;;; and to permit persons to whom the Software is furnished to do so,
|
|
||||||
;;; subject to the following conditions:
|
|
||||||
;;;
|
|
||||||
;;; The above copyright notice and this permission notice shall be
|
|
||||||
;;; included in all copies or substantial portions of the Software.
|
|
||||||
;;;
|
|
||||||
;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
|
|
||||||
;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
|
|
||||||
;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
|
|
||||||
;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS
|
|
||||||
;;; BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN
|
|
||||||
;;; ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN
|
|
||||||
;;; CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
|
|
||||||
;;; SOFTWARE.
|
|
||||||
|
|
||||||
(library (streams primitive)
|
|
||||||
|
|
||||||
(export stream-null stream-cons stream? stream-null? stream-pair?
|
|
||||||
stream-car stream-cdr stream-lambda)
|
|
||||||
|
|
||||||
(import (rnrs) (rnrs mutable-pairs))
|
|
||||||
|
|
||||||
(define-record-type (stream-type make-stream stream?)
|
|
||||||
(fields (mutable box stream-promise stream-promise!)))
|
|
||||||
|
|
||||||
(define-syntax stream-lazy
|
|
||||||
(syntax-rules ()
|
|
||||||
((lazy expr)
|
|
||||||
(make-stream
|
|
||||||
(cons 'lazy (lambda () expr))))))
|
|
||||||
|
|
||||||
(define (stream-eager expr)
|
|
||||||
(make-stream
|
|
||||||
(cons 'eager expr)))
|
|
||||||
|
|
||||||
(define-syntax stream-delay
|
|
||||||
(syntax-rules ()
|
|
||||||
((stream-delay expr)
|
|
||||||
(stream-lazy (stream-eager expr)))))
|
|
||||||
|
|
||||||
(define (stream-force promise)
|
|
||||||
(let ((content (stream-promise promise)))
|
|
||||||
(case (car content)
|
|
||||||
((eager) (cdr content))
|
|
||||||
((lazy) (let* ((promise* ((cdr content)))
|
|
||||||
(content (stream-promise promise)))
|
|
||||||
(if (not (eqv? (car content) 'eager))
|
|
||||||
(begin (set-car! content (car (stream-promise promise*)))
|
|
||||||
(set-cdr! content (cdr (stream-promise promise*)))
|
|
||||||
(stream-promise! promise* content)))
|
|
||||||
(stream-force promise))))))
|
|
||||||
|
|
||||||
(define stream-null (stream-delay (cons 'stream 'null)))
|
|
||||||
|
|
||||||
(define-record-type (stream-pare-type make-stream-pare stream-pare?)
|
|
||||||
(fields (immutable kar stream-kar) (immutable kdr stream-kdr)))
|
|
||||||
|
|
||||||
(define (stream-pair? obj)
|
|
||||||
(and (stream? obj) (stream-pare? (stream-force obj))))
|
|
||||||
|
|
||||||
(define (stream-null? obj)
|
|
||||||
(and (stream? obj)
|
|
||||||
(eqv? (stream-force obj)
|
|
||||||
(stream-force stream-null))))
|
|
||||||
|
|
||||||
(define-syntax stream-cons
|
|
||||||
(syntax-rules ()
|
|
||||||
((stream-cons obj strm)
|
|
||||||
(stream-delay (make-stream-pare (stream-delay obj) (stream-lazy strm))))))
|
|
||||||
|
|
||||||
(define (stream-car strm)
|
|
||||||
(cond ((not (stream? strm)) (error 'stream-car "non-stream"))
|
|
||||||
((stream-null? strm) (error 'stream-car "null stream"))
|
|
||||||
(else (stream-force (stream-kar (stream-force strm))))))
|
|
||||||
|
|
||||||
(define (stream-cdr strm)
|
|
||||||
(cond ((not (stream? strm)) (error 'stream-cdr "non-stream"))
|
|
||||||
((stream-null? strm) (error 'stream-cdr "null stream"))
|
|
||||||
(else (stream-kdr (stream-force strm)))))
|
|
||||||
|
|
||||||
(define-syntax stream-lambda
|
|
||||||
(syntax-rules ()
|
|
||||||
((stream-lambda formals body0 body1 ...)
|
|
||||||
(lambda formals (stream-lazy (let () body0 body1 ...)))))))
|
|
||||||
|
|
@ -1 +1 @@
|
||||||
1744
|
1745
|
||||||
|
|
|
||||||
Loading…
Reference in New Issue