Gecko [ lostrivercommunitycenter.com ]

Name	Size	Permission	Date
and-let-star.scm	2.53 KB	-rw-r--r--	2019-10-13 01:10
binary-ports.scm	1.88 KB	-rw-r--r--	2019-10-13 01:10
boot-9.scm	151.09 KB	-rw-r--r--	2019-10-13 01:10
buffered-input.scm	4.82 KB	-rw-r--r--	2019-10-13 01:10
calling.scm	10.54 KB	-rw-r--r--	2019-10-13 01:10
channel.scm	5.19 KB	-rw-r--r--	2019-10-13 01:10
command-line.scm	18.22 KB	-rw-r--r--	2019-10-13 01:10
common-list.scm	8.95 KB	-rw-r--r--	2019-10-13 01:10
control.scm	3.94 KB	-rw-r--r--	2019-10-13 01:10
curried-definitions.scm	1.79 KB	-rw-r--r--	2019-10-13 01:10
debug.scm	1.09 KB	-rw-r--r--	2019-10-13 01:10
deprecated.scm	31.24 KB	-rw-r--r--	2019-10-13 01:10
documentation.scm	7.26 KB	-rw-r--r--	2019-10-13 01:10
eval-string.scm	2.93 KB	-rw-r--r--	2019-10-13 01:10
eval.scm	20.85 KB	-rw-r--r--	2019-10-13 01:10
expect.scm	5.5 KB	-rw-r--r--	2019-10-13 01:10
format.scm	74.5 KB	-rw-r--r--	2019-10-13 01:10
ftw.scm	24.17 KB	-rw-r--r--	2019-10-13 01:10
futures.scm	10.92 KB	-rw-r--r--	2019-10-13 01:10
gap-buffer.scm	10.14 KB	-rw-r--r--	2019-10-13 01:10
getopt-long.scm	16.49 KB	-rw-r--r--	2019-10-13 01:10
hash-table.scm	1.77 KB	-rw-r--r--	2019-10-13 01:10
hcons.scm	2.55 KB	-rw-r--r--	2019-10-13 01:10
history.scm	2.29 KB	-rw-r--r--	2019-10-13 01:10
i18n.scm	17.36 KB	-rw-r--r--	2019-10-13 01:10
iconv.scm	3.65 KB	-rw-r--r--	2019-10-13 01:10
lineio.scm	3.85 KB	-rw-r--r--	2019-10-13 01:10
list.scm	1.29 KB	-rw-r--r--	2019-10-13 01:10
local-eval.scm	9.71 KB	-rw-r--r--	2019-10-13 01:10
ls.scm	3.2 KB	-rw-r--r--	2019-10-13 01:10
mapping.scm	4.84 KB	-rw-r--r--	2019-10-13 01:10
match.scm	2 KB	-rw-r--r--	2019-10-13 01:10
match.upstream.scm	35.6 KB	-rw-r--r--	2019-10-13 01:10
networking.scm	3.33 KB	-rw-r--r--	2019-10-13 01:10
null.scm	1.13 KB	-rw-r--r--	2019-10-13 01:10
occam-channel.scm	7.26 KB	-rw-r--r--	2019-10-13 01:10
optargs.scm	15.75 KB	-rw-r--r--	2019-10-13 01:10
poe.scm	3.3 KB	-rw-r--r--	2019-10-13 01:10
poll.scm	6.02 KB	-rw-r--r--	2019-10-13 01:10
popen.scm	5.67 KB	-rw-r--r--	2019-10-13 01:10
posix.scm	2.73 KB	-rw-r--r--	2019-10-13 01:10
pretty-print.scm	15.83 KB	-rw-r--r--	2019-10-13 01:10
psyntax-pp.scm	162.87 KB	-rw-r--r--	2019-10-13 01:10
psyntax.scm	143.67 KB	-rw-r--r--	2019-10-13 01:10
q.scm	4.2 KB	-rw-r--r--	2019-10-13 01:10
quasisyntax.scm	5.22 KB	-rw-r--r--	2019-10-13 01:10
r4rs.scm	9.42 KB	-rw-r--r--	2019-10-13 01:10
r5rs.scm	1.56 KB	-rw-r--r--	2019-10-13 01:10
r6rs-libraries.scm	8.95 KB	-rw-r--r--	2019-10-13 01:10
rdelim.scm	7.47 KB	-rw-r--r--	2019-10-13 01:10
readline.scm	9.56 KB	-rw-r--r--	2019-10-13 01:10
receive.scm	1.06 KB	-rw-r--r--	2019-10-13 01:10
regex.scm	8.87 KB	-rw-r--r--	2019-10-13 01:10
runq.scm	8.18 KB	-rw-r--r--	2019-10-13 01:10
rw.scm	1.02 KB	-rw-r--r--	2019-10-13 01:10
safe-r5rs.scm	3.72 KB	-rw-r--r--	2019-10-13 01:10
safe.scm	1.25 KB	-rw-r--r--	2019-10-13 01:10
save-stack.scm	2.15 KB	-rw-r--r--	2019-10-13 01:10
scm-style-repl.scm	11.71 KB	-rw-r--r--	2019-10-13 01:10
serialize.scm	3.77 KB	-rw-r--r--	2019-10-13 01:10
session.scm	17.72 KB	-rw-r--r--	2019-10-13 01:10
slib.scm	1.55 KB	-rw-r--r--	2019-10-13 01:10
stack-catch.scm	1.94 KB	-rw-r--r--	2019-10-13 01:10
streams.scm	7.31 KB	-rw-r--r--	2019-10-13 01:10
string-fun.scm	8.59 KB	-rw-r--r--	2019-10-13 01:10
syncase.scm	1.52 KB	-rw-r--r--	2019-10-13 01:10
threads.scm	6.24 KB	-rw-r--r--	2019-10-13 01:10
time.scm	2.04 KB	-rw-r--r--	2019-10-13 01:10
top-repl.scm	2.75 KB	-rw-r--r--	2019-10-13 01:10
unicode.scm	1005 B	-rw-r--r--	2019-10-13 01:10
vlist.scm	21.56 KB	-rw-r--r--	2019-10-13 01:10
weak-vector.scm	1.26 KB	-rw-r--r--	2019-10-13 01:10

Rename

;;;; string-fun.scm --- string manipulation functions
;;;;
;;;; 	Copyright (C) 1995, 1996, 1997, 1999, 2001, 2006 Free Software Foundation, Inc.
;;;; 
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 3 of the License, or (at your option) any later version.
;;;; 
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;;;; Lesser General Public License for more details.
;;;; 
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
;;;;

(define-module (ice-9 string-fun)
  :export (split-after-char split-before-char split-discarding-char
	   split-after-char-last split-before-char-last
	   split-discarding-char-last split-before-predicate
	   split-after-predicate split-discarding-predicate
	   separate-fields-discarding-char separate-fields-after-char
	   separate-fields-before-char string-prefix-predicate string-prefix=?
	   sans-surrounding-whitespace sans-trailing-whitespace
	   sans-leading-whitespace sans-final-newline has-trailing-newline?))

;;;;
;;;
;;; Various string funcitons, particularly those that take
;;; advantage of the "shared substring" capability.
;;;

;;; {String Fun: Dividing Strings Into Fields}
;;; 
;;; The names of these functions are very regular.
;;; Here is a grammar of a call to one of these:
;;;
;;;   <string-function-invocation>
;;;   := (<action>-<seperator-disposition>-<seperator-determination> <seperator-param> <str> <ret>)
;;;
;;; <str>    = the string
;;;
;;; <ret>    = The continuation.  String functions generally return
;;;	       multiple values by passing them to this procedure.
;;;
;;; <action> =    split
;;;		| separate-fields
;;;
;;;		"split" means to divide a string into two parts.
;;;			<ret> will be called with two arguments.
;;;
;;;		"separate-fields" means to divide a string into as many
;;;			parts as possible.  <ret> will be called with
;;;			however many fields are found.
;;;
;;; <seperator-disposition> = 	  before
;;;				| after
;;;				| discarding
;;;
;;;		"before" means to leave the seperator attached to
;;;			the beginning of the field to its right.
;;;		"after" means to leave the seperator attached to
;;;			the end of the field to its left.
;;;		"discarding" means to discard seperators.
;;;
;;;		Other dispositions might be handy.  For example, "isolate"
;;;		could mean to treat the separator as a field unto itself.
;;;
;;; <seperator-determination> =	  char
;;;				| predicate
;;;
;;;		"char" means to use a particular character as field seperator.
;;;		"predicate" means to check each character using a particular predicate.
;;;		
;;;		Other determinations might be handy.  For example, "character-set-member".
;;;
;;; <seperator-param> = A parameter that completes the meaning of the determinations.
;;;			For example, if the determination is "char", then this parameter
;;;			says which character.  If it is "predicate", the parameter is the
;;;			predicate.
;;;
;;;
;;; For example:
;;;
;;;		(separate-fields-discarding-char #\, "foo, bar, baz, , bat" list)
;;;		=> ("foo" " bar" " baz" " " " bat")
;;;
;;;		(split-after-char #\- 'an-example-of-split list)
;;;		=> ("an-" "example-of-split")
;;;
;;; As an alternative to using a determination "predicate", or to trying to do anything
;;; complicated with these functions, consider using regular expressions.
;;;

(define (split-after-char char str ret)
  (let ((end (cond
	      ((string-index str char) => 1+)
	      (else (string-length str)))))
    (ret (substring str 0 end)
	 (substring str end))))

(define (split-before-char char str ret)
  (let ((end (or (string-index str char)
		 (string-length str))))
    (ret (substring str 0 end)
	 (substring str end))))

(define (split-discarding-char char str ret)
  (let ((end (string-index str char)))
    (if (not end)
	(ret str "")
	(ret (substring str 0 end)
	     (substring str (1+ end))))))

(define (split-after-char-last char str ret)
  (let ((end (cond
	      ((string-rindex str char) => 1+)
	      (else 0))))
    (ret (substring str 0 end)
	 (substring str end))))

(define (split-before-char-last char str ret)
  (let ((end (or (string-rindex str char) 0)))
    (ret (substring str 0 end)
	 (substring str end))))

(define (split-discarding-char-last char str ret)
  (let ((end (string-rindex str char)))
    (if (not end)
	(ret str "")
	(ret (substring str 0 end)
	     (substring str (1+ end))))))

(define (split-before-predicate pred str ret)
  (let loop ((n 0))
    (cond
     ((= n (string-length str))		(ret str ""))
     ((not (pred (string-ref str n)))	(loop (1+ n)))
     (else				(ret (substring str 0 n)
					     (substring str n))))))
(define (split-after-predicate pred str ret)
  (let loop ((n 0))
    (cond
     ((= n (string-length str))		(ret str ""))
     ((not (pred (string-ref str n)))	(loop (1+ n)))
     (else				(ret (substring str 0 (1+ n))
					     (substring str (1+ n)))))))

(define (split-discarding-predicate pred str ret)
  (let loop ((n 0))
    (cond
     ((= n (string-length str))		(ret str ""))
     ((not (pred (string-ref str n)))	(loop (1+ n)))
     (else				(ret (substring str 0 n)
					     (substring str (1+ n)))))))

(define (separate-fields-discarding-char ch str ret)
  (let loop ((fields '())
	     (str str))
    (cond
     ((string-rindex str ch)
      => (lambda (w) (loop (cons (substring str (+ 1 w)) fields)
			   (substring str 0 w))))
     (else (apply ret str fields)))))

(define (separate-fields-after-char ch str ret)
  (reverse
   (let loop ((fields '())
             (str str))
     (cond
      ((string-index str ch)
       => (lambda (w) (loop (cons (substring str 0 (+ 1 w)) fields)
                           (substring str (+ 1 w)))))
      (else (apply ret str fields))))))

(define (separate-fields-before-char ch str ret)
  (let loop ((fields '())
	     (str str))
    (cond
     ((string-rindex str ch)
      => (lambda (w) (loop (cons (substring str w) fields)
			     (substring str 0 w))))
     (else (apply ret str fields)))))

;;; {String Fun: String Prefix Predicates}
;;;
;;; Very simple:
;;;
;;; (define-public ((string-prefix-predicate pred?) prefix str)
;;;  (and (<= (string-length prefix) (string-length str))
;;;	  (pred? prefix (substring str 0 (string-length prefix)))))
;;;
;;; (define-public string-prefix=? (string-prefix-predicate string=?))
;;;

(define (string-prefix-predicate pred?)
  (lambda (prefix str)
    (and (<= (string-length prefix) (string-length str))
         (pred? prefix (substring str 0 (string-length prefix))))))

(define string-prefix=? (string-prefix-predicate string=?))

;;; {String Fun: Strippers}
;;;
;;; <stripper> = sans-<removable-part>
;;;
;;; <removable-part> = 	  surrounding-whitespace
;;;			| trailing-whitespace
;;;			| leading-whitespace
;;;			| final-newline
;;;

(define (sans-surrounding-whitespace s)
  (let ((st 0)
	(end (string-length s)))
    (while (and (< st (string-length s))
		(char-whitespace? (string-ref s st)))
	   (set! st (1+ st)))
    (while (and (< 0 end)
		(char-whitespace? (string-ref s (1- end))))
	   (set! end (1- end)))
    (if (< end st)
	""
	(substring s st end))))

(define (sans-trailing-whitespace s)
  (let ((st 0)
	(end (string-length s)))
    (while (and (< 0 end)
		(char-whitespace? (string-ref s (1- end))))
	   (set! end (1- end)))
    (if (< end st)
	""
	(substring s st end))))

(define (sans-leading-whitespace s)
  (let ((st 0)
	(end (string-length s)))
    (while (and (< st (string-length s))
		(char-whitespace? (string-ref s st)))
	   (set! st (1+ st)))
    (if (< end st)
	""
	(substring s st end))))

(define (sans-final-newline str)
  (cond
   ((= 0 (string-length str))
    str)

((char=? #\nl (string-ref str (1- (string-length str))))
    (substring str 0 (1- (string-length str))))

(else str)))

;;; {String Fun: has-trailing-newline?}
;;;

(define (has-trailing-newline? str)
  (and (< 0 (string-length str))
       (char=? #\nl (string-ref str (1- (string-length str))))))

;;; {String Fun: with-regexp-parts}

;;; This relies on the older, hairier regexp interface, which we don't
;;; particularly want to implement, and it's not used anywhere, so
;;; we're just going to drop it for now.
;;; (define-public (with-regexp-parts regexp fields str return fail)
;;;   (let ((parts (regexec regexp str fields)))
;;;     (if (number? parts)
;;;         (fail parts)
;;;         (apply return parts))))