mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-05-31 09:20:23 +02:00
Suggestion and script from Maciej Stachowiak:
* boot-9.scm: Split off modules into separate, autoloadable files. This reduces startup time from 10.5s to 5.5s (user cpu). * calling.scm, common-list.scm, ls.scm, q.scm, runq.scm, string-fun.scm: New files, containing stuff that used to be in boot-9.scm. * Makefile.am (ice9_sources): List new files here, for distribution and installation. * Makefile.in: Regenerated.
This commit is contained in:
Jim Blandy
parent
cb0a5b3957
commit
a6401ee0f2
9 changed files with 1181 additions and 1186 deletions
|
|
@ -3,9 +3,10 @@
|
|||
AUTOMAKE_OPTIONS = foreign
|
||||
|
||||
# These should be installed and distributed.
|
||||
ice9_sources = boot-9.scm debug.scm expect.scm hcons.scm lineio.scm \
|
||||
mapping.scm poe.scm regex.scm slib.scm tags.scm threads.scm r4rs.scm \
|
||||
session.scm syncase.scm psyntax.pp psyntax.ss
|
||||
ice9_sources = boot-9.scm calling.scm common-list.scm debug.scm expect.scm \
|
||||
hcons.scm lineio.scm ls.scm mapping.scm poe.scm q.scm regex.scm runq.scm \
|
||||
slib.scm string-fun.scm tags.scm threads.scm r4rs.scm session.scm \
|
||||
syncase.scm psyntax.pp psyntax.ss
|
||||
|
||||
# These should be installed, but not distributed.
|
||||
ice9_generated = version.scm
|
||||
|
|
|
|||
|
|
@ -86,9 +86,10 @@ target_libs = @target_libs@
|
|||
AUTOMAKE_OPTIONS = foreign
|
||||
|
||||
# These should be installed and distributed.
|
||||
ice9_sources = boot-9.scm debug.scm expect.scm hcons.scm lineio.scm \
|
||||
mapping.scm poe.scm regex.scm slib.scm tags.scm threads.scm r4rs.scm \
|
||||
session.scm syncase.scm psyntax.pp psyntax.ss
|
||||
ice9_sources = boot-9.scm calling.scm common-list.scm debug.scm expect.scm \
|
||||
hcons.scm lineio.scm ls.scm mapping.scm poe.scm q.scm regex.scm runq.scm \
|
||||
slib.scm string-fun.scm tags.scm threads.scm r4rs.scm session.scm \
|
||||
syncase.scm psyntax.pp psyntax.ss
|
||||
|
||||
# These should be installed, but not distributed.
|
||||
ice9_generated = version.scm
|
||||
|
|
|
|||
1180
ice-9/boot-9.scm
1180
ice-9/boot-9.scm
File diff suppressed because it is too large
Load diff
300
ice-9/calling.scm
Normal file
300
ice-9/calling.scm
Normal file
|
|
@ -0,0 +1,300 @@
|
|||
;;; {Calling Conventions}
|
||||
(define-module (ice-9 calling))
|
||||
|
||||
;;;;
|
||||
;;;
|
||||
;;; This file contains a number of macros that support
|
||||
;;; common calling conventions.
|
||||
|
||||
;;;
|
||||
;;; with-excursion-function <vars> proc
|
||||
;;; <vars> is an unevaluated list of names that are bound in the caller.
|
||||
;;; proc is a procedure, called:
|
||||
;;; (proc excursion)
|
||||
;;;
|
||||
;;; excursion is a procedure isolates all changes to <vars>
|
||||
;;; in the dynamic scope of the call to proc. In other words,
|
||||
;;; the values of <vars> are saved when proc is entered, and when
|
||||
;;; proc returns, those values are restored. Values are also restored
|
||||
;;; entering and leaving the call to proc non-locally, such as using
|
||||
;;; call-with-current-continuation, error, or throw.
|
||||
;;;
|
||||
(defmacro-public with-excursion-function (vars proc)
|
||||
`(,proc ,(excursion-function-syntax vars)))
|
||||
|
||||
|
||||
|
||||
;;; with-getter-and-setter <vars> proc
|
||||
;;; <vars> is an unevaluated list of names that are bound in the caller.
|
||||
;;; proc is a procedure, called:
|
||||
;;; (proc getter setter)
|
||||
;;;
|
||||
;;; getter and setter are procedures used to access
|
||||
;;; or modify <vars>.
|
||||
;;;
|
||||
;;; setter, called with keywords arguments, modifies the named
|
||||
;;; values. If "foo" and "bar" are among <vars>, then:
|
||||
;;;
|
||||
;;; (setter :foo 1 :bar 2)
|
||||
;;; == (set! foo 1 bar 2)
|
||||
;;;
|
||||
;;; getter, called with just keywords, returns
|
||||
;;; a list of the corresponding values. For example,
|
||||
;;; if "foo" and "bar" are among the <vars>, then
|
||||
;;;
|
||||
;;; (getter :foo :bar)
|
||||
;;; => (<value-of-foo> <value-of-bar>)
|
||||
;;;
|
||||
;;; getter, called with no arguments, returns a list of all accepted
|
||||
;;; keywords and the corresponding values. If "foo" and "bar" are
|
||||
;;; the *only* <vars>, then:
|
||||
;;;
|
||||
;;; (getter)
|
||||
;;; => (:foo <value-of-bar> :bar <value-of-foo>)
|
||||
;;;
|
||||
;;; The unusual calling sequence of a getter supports too handy
|
||||
;;; idioms:
|
||||
;;;
|
||||
;;; (apply setter (getter)) ;; save and restore
|
||||
;;;
|
||||
;;; (apply-to-args (getter :foo :bar) ;; fetch and bind
|
||||
;;; (lambda (foo bar) ....))
|
||||
;;;
|
||||
;;; ;; [ "apply-to-args" is just like two-argument "apply" except that it
|
||||
;;; ;; takes its arguments in a different order.
|
||||
;;;
|
||||
;;;
|
||||
(defmacro-public with-getter-and-setter (vars proc)
|
||||
`(,proc ,@ (getter-and-setter-syntax vars)))
|
||||
|
||||
;;; with-getter vars proc
|
||||
;;; A short-hand for a call to with-getter-and-setter.
|
||||
;;; The procedure is called:
|
||||
;;; (proc getter)
|
||||
;;;
|
||||
(defmacro-public with-getter (vars proc)
|
||||
`(,proc ,(car (getter-and-setter-syntax vars))))
|
||||
|
||||
|
||||
;;; with-delegating-getter-and-setter <vars> get-delegate set-delegate proc
|
||||
;;; Compose getters and setters.
|
||||
;;;
|
||||
;;; <vars> is an unevaluated list of names that are bound in the caller.
|
||||
;;;
|
||||
;;; get-delegate is called by the new getter to extend the set of
|
||||
;;; gettable variables beyond just <vars>
|
||||
;;; set-delegate is called by the new setter to extend the set of
|
||||
;;; gettable variables beyond just <vars>
|
||||
;;;
|
||||
;;; proc is a procedure that is called
|
||||
;;; (proc getter setter)
|
||||
;;;
|
||||
(defmacro-public with-delegating-getter-and-setter (vars get-delegate set-delegate proc)
|
||||
`(,proc ,@ (delegating-getter-and-setter-syntax vars get-delegate set-delegate)))
|
||||
|
||||
|
||||
;;; with-excursion-getter-and-setter <vars> proc
|
||||
;;; <vars> is an unevaluated list of names that are bound in the caller.
|
||||
;;; proc is called:
|
||||
;;;
|
||||
;;; (proc excursion getter setter)
|
||||
;;;
|
||||
;;; See also:
|
||||
;;; with-getter-and-setter
|
||||
;;; with-excursion-function
|
||||
;;;
|
||||
(defmacro-public with-excursion-getter-and-setter (vars proc)
|
||||
`(,proc ,(excursion-function-syntax vars)
|
||||
,@ (getter-and-setter-syntax vars)))
|
||||
|
||||
|
||||
(define (excursion-function-syntax vars)
|
||||
(let ((saved-value-names (map gensym vars))
|
||||
(tmp-var-name (gensym 'temp))
|
||||
(swap-fn-name (gensym 'swap))
|
||||
(thunk-name (gensym 'thunk)))
|
||||
`(lambda (,thunk-name)
|
||||
(letrec ((,tmp-var-name #f)
|
||||
(,swap-fn-name
|
||||
(lambda () ,@ (map (lambda (n sn) `(set! ,tmp-var-name ,n ,n ,sn ,sn ,tmp-var-name))
|
||||
vars saved-value-names)))
|
||||
,@ (map (lambda (sn n) `(,sn ,n)) saved-value-names vars))
|
||||
(dynamic-wind
|
||||
,swap-fn-name
|
||||
,thunk-name
|
||||
,swap-fn-name)))))
|
||||
|
||||
|
||||
(define (getter-and-setter-syntax vars)
|
||||
(let ((args-name (gensym 'args))
|
||||
(an-arg-name (gensym 'an-arg))
|
||||
(new-val-name (gensym 'new-value))
|
||||
(loop-name (gensym 'loop))
|
||||
(kws (map symbol->keyword vars)))
|
||||
(list `(lambda ,args-name
|
||||
(let ,loop-name ((,args-name ,args-name))
|
||||
(if (null? ,args-name)
|
||||
,(if (null? kws)
|
||||
''()
|
||||
`(let ((all-vals (,loop-name ',kws)))
|
||||
(let ,loop-name ((vals all-vals)
|
||||
(kws ',kws))
|
||||
(if (null? vals)
|
||||
'()
|
||||
`(,(car kws) ,(car vals) ,@(,loop-name (cdr vals) (cdr kws)))))))
|
||||
(map (lambda (,an-arg-name)
|
||||
(case ,an-arg-name
|
||||
,@ (append
|
||||
(map (lambda (kw v) `((,kw) ,v)) kws vars)
|
||||
`((else (throw 'bad-get-option ,an-arg-name))))))
|
||||
,args-name))))
|
||||
|
||||
`(lambda ,args-name
|
||||
(let ,loop-name ((,args-name ,args-name))
|
||||
(or (null? ,args-name)
|
||||
(null? (cdr ,args-name))
|
||||
(let ((,an-arg-name (car ,args-name))
|
||||
(,new-val-name (cadr ,args-name)))
|
||||
(case ,an-arg-name
|
||||
,@ (append
|
||||
(map (lambda (kw v) `((,kw) (set! ,v ,new-val-name))) kws vars)
|
||||
`((else (throw 'bad-set-option ,an-arg-name)))))
|
||||
(,loop-name (cddr ,args-name)))))))))
|
||||
|
||||
(define (delegating-getter-and-setter-syntax vars get-delegate set-delegate)
|
||||
(let ((args-name (gensym 'args))
|
||||
(an-arg-name (gensym 'an-arg))
|
||||
(new-val-name (gensym 'new-value))
|
||||
(loop-name (gensym 'loop))
|
||||
(kws (map symbol->keyword vars)))
|
||||
(list `(lambda ,args-name
|
||||
(let ,loop-name ((,args-name ,args-name))
|
||||
(if (null? ,args-name)
|
||||
(append!
|
||||
,(if (null? kws)
|
||||
''()
|
||||
`(let ((all-vals (,loop-name ',kws)))
|
||||
(let ,loop-name ((vals all-vals)
|
||||
(kws ',kws))
|
||||
(if (null? vals)
|
||||
'()
|
||||
`(,(car kws) ,(car vals) ,@(,loop-name (cdr vals) (cdr kws)))))))
|
||||
(,get-delegate))
|
||||
(map (lambda (,an-arg-name)
|
||||
(case ,an-arg-name
|
||||
,@ (append
|
||||
(map (lambda (kw v) `((,kw) ,v)) kws vars)
|
||||
`((else (car (,get-delegate ,an-arg-name)))))))
|
||||
,args-name))))
|
||||
|
||||
`(lambda ,args-name
|
||||
(let ,loop-name ((,args-name ,args-name))
|
||||
(or (null? ,args-name)
|
||||
(null? (cdr ,args-name))
|
||||
(let ((,an-arg-name (car ,args-name))
|
||||
(,new-val-name (cadr ,args-name)))
|
||||
(case ,an-arg-name
|
||||
,@ (append
|
||||
(map (lambda (kw v) `((,kw) (set! ,v ,new-val-name))) kws vars)
|
||||
`((else (,set-delegate ,an-arg-name ,new-val-name)))))
|
||||
(,loop-name (cddr ,args-name)))))))))
|
||||
|
||||
|
||||
|
||||
|
||||
;;; with-configuration-getter-and-setter <vars-etc> proc
|
||||
;;;
|
||||
;;; Create a getter and setter that can trigger arbitrary computation.
|
||||
;;;
|
||||
;;; <vars-etc> is a list of variable specifiers, explained below.
|
||||
;;; proc is called:
|
||||
;;;
|
||||
;;; (proc getter setter)
|
||||
;;;
|
||||
;;; Each element of the <vars-etc> list is of the form:
|
||||
;;;
|
||||
;;; (<var> getter-hook setter-hook)
|
||||
;;;
|
||||
;;; Both hook elements are evaluated; the variable name is not.
|
||||
;;; Either hook may be #f or procedure.
|
||||
;;;
|
||||
;;; A getter hook is a thunk that returns a value for the corresponding
|
||||
;;; variable. If omitted (#f is passed), the binding of <var> is
|
||||
;;; returned.
|
||||
;;;
|
||||
;;; A setter hook is a procedure of one argument that accepts a new value
|
||||
;;; for the corresponding variable. If omitted, the binding of <var>
|
||||
;;; is simply set using set!.
|
||||
;;;
|
||||
(defmacro-public with-configuration-getter-and-setter (vars-etc proc)
|
||||
`((lambda (simpler-get simpler-set body-proc)
|
||||
(with-delegating-getter-and-setter ()
|
||||
simpler-get simpler-set body-proc))
|
||||
|
||||
(lambda (kw)
|
||||
(case kw
|
||||
,@(map (lambda (v) `((,(symbol->keyword (car v)))
|
||||
,(cond
|
||||
((cadr v) => list)
|
||||
(else `(list ,(car v))))))
|
||||
vars-etc)))
|
||||
|
||||
(lambda (kw new-val)
|
||||
(case kw
|
||||
,@(map (lambda (v) `((,(symbol->keyword (car v)))
|
||||
,(cond
|
||||
((caddr v) => (lambda (proc) `(,proc new-val)))
|
||||
(else `(set! ,(car v) new-val)))))
|
||||
vars-etc)))
|
||||
|
||||
,proc))
|
||||
|
||||
(defmacro-public with-delegating-configuration-getter-and-setter (vars-etc delegate-get delegate-set proc)
|
||||
`((lambda (simpler-get simpler-set body-proc)
|
||||
(with-delegating-getter-and-setter ()
|
||||
simpler-get simpler-set body-proc))
|
||||
|
||||
(lambda (kw)
|
||||
(case kw
|
||||
,@(append! (map (lambda (v) `((,(symbol->keyword (car v)))
|
||||
,(cond
|
||||
((cadr v) => list)
|
||||
(else `(list ,(car v))))))
|
||||
vars-etc)
|
||||
`((else (,delegate-get kw))))))
|
||||
|
||||
(lambda (kw new-val)
|
||||
(case kw
|
||||
,@(append! (map (lambda (v) `((,(symbol->keyword (car v)))
|
||||
,(cond
|
||||
((caddr v) => (lambda (proc) `(,proc new-val)))
|
||||
(else `(set! ,(car v) new-val)))))
|
||||
vars-etc)
|
||||
`((else (,delegate-set kw new-val))))))
|
||||
|
||||
,proc))
|
||||
|
||||
|
||||
;;; let-configuration-getter-and-setter <vars-etc> proc
|
||||
;;;
|
||||
;;; This procedure is like with-configuration-getter-and-setter (q.v.)
|
||||
;;; except that each element of <vars-etc> is:
|
||||
;;;
|
||||
;;; (<var> initial-value getter-hook setter-hook)
|
||||
;;;
|
||||
;;; Unlike with-configuration-getter-and-setter, let-configuration-getter-and-setter
|
||||
;;; introduces bindings for the variables named in <vars-etc>.
|
||||
;;; It is short-hand for:
|
||||
;;;
|
||||
;;; (let ((<var1> initial-value-1)
|
||||
;;; (<var2> initial-value-2)
|
||||
;;; ...)
|
||||
;;; (with-configuration-getter-and-setter ((<var1> v1-get v1-set) ...) proc))
|
||||
;;;
|
||||
(defmacro-public let-with-configuration-getter-and-setter (vars-etc proc)
|
||||
`(let ,(map (lambda (v) `(,(car v) ,(cadr v))) vars-etc)
|
||||
(with-configuration-getter-and-setter ,(map (lambda (v) `(,(car v) ,(caddr v) ,(cadddr v))) vars-etc)
|
||||
,proc)))
|
||||
|
||||
|
||||
|
||||
173
ice-9/common-list.scm
Normal file
173
ice-9/common-list.scm
Normal file
|
|
@ -0,0 +1,173 @@
|
|||
;;; {Implementation of COMMON LISP list functions for Scheme}
|
||||
|
||||
(define-module (ice-9 common-list))
|
||||
|
||||
;;"comlist.scm" Implementation of COMMON LISP list functions for Scheme
|
||||
; Copyright (C) 1991, 1993, 1995 Aubrey Jaffer.
|
||||
;
|
||||
;Permission to copy this software, to redistribute it, and to use it
|
||||
;for any purpose is granted, subject to the following restrictions and
|
||||
;understandings.
|
||||
;
|
||||
;1. Any copy made of this software must include this copyright notice
|
||||
;in full.
|
||||
;
|
||||
;2. I have made no warrantee or representation that the operation of
|
||||
;this software will be error-free, and I am under no obligation to
|
||||
;provide any services, by way of maintenance, update, or otherwise.
|
||||
;
|
||||
;3. In conjunction with products arising from the use of this
|
||||
;material, there shall be no use of my name in any advertising,
|
||||
;promotional, or sales literature without prior written consent in
|
||||
;each case.
|
||||
|
||||
(define-public (adjoin e l) (if (memq e l) l (cons e l)))
|
||||
|
||||
(define-public (union l1 l2)
|
||||
(cond ((null? l1) l2)
|
||||
((null? l2) l1)
|
||||
(else (union (cdr l1) (adjoin (car l1) l2)))))
|
||||
|
||||
(define-public (intersection l1 l2)
|
||||
(cond ((null? l1) l1)
|
||||
((null? l2) l2)
|
||||
((memv (car l1) l2) (cons (car l1) (intersection (cdr l1) l2)))
|
||||
(else (intersection (cdr l1) l2))))
|
||||
|
||||
(define-public (set-difference l1 l2)
|
||||
(cond ((null? l1) l1)
|
||||
((memv (car l1) l2) (set-difference (cdr l1) l2))
|
||||
(else (cons (car l1) (set-difference (cdr l1) l2)))))
|
||||
|
||||
(define-public (reduce-init p init l)
|
||||
(if (null? l)
|
||||
init
|
||||
(reduce-init p (p init (car l)) (cdr l))))
|
||||
|
||||
(define-public (reduce p l)
|
||||
(cond ((null? l) l)
|
||||
((null? (cdr l)) (car l))
|
||||
(else (reduce-init p (car l) (cdr l)))))
|
||||
|
||||
(define-public (some pred l . rest)
|
||||
(cond ((null? rest)
|
||||
(let mapf ((l l))
|
||||
(and (not (null? l))
|
||||
(or (pred (car l)) (mapf (cdr l))))))
|
||||
(else (let mapf ((l l) (rest rest))
|
||||
(and (not (null? l))
|
||||
(or (apply pred (car l) (map car rest))
|
||||
(mapf (cdr l) (map cdr rest))))))))
|
||||
|
||||
(define-public (every pred l . rest)
|
||||
(cond ((null? rest)
|
||||
(let mapf ((l l))
|
||||
(or (null? l)
|
||||
(and (pred (car l)) (mapf (cdr l))))))
|
||||
(else (let mapf ((l l) (rest rest))
|
||||
(or (null? l)
|
||||
(and (apply pred (car l) (map car rest))
|
||||
(mapf (cdr l) (map cdr rest))))))))
|
||||
|
||||
(define-public (notany pred . ls) (not (apply some pred ls)))
|
||||
|
||||
(define-public (notevery pred . ls) (not (apply every pred ls)))
|
||||
|
||||
(define-public (find-if t l)
|
||||
(cond ((null? l) #f)
|
||||
((t (car l)) (car l))
|
||||
(else (find-if t (cdr l)))))
|
||||
|
||||
(define-public (member-if t l)
|
||||
(cond ((null? l) #f)
|
||||
((t (car l)) l)
|
||||
(else (member-if t (cdr l)))))
|
||||
|
||||
(define-public (remove-if p l)
|
||||
(cond ((null? l) '())
|
||||
((p (car l)) (remove-if p (cdr l)))
|
||||
(else (cons (car l) (remove-if p (cdr l))))))
|
||||
|
||||
(define-public (delete-if! pred list)
|
||||
(let delete-if ((list list))
|
||||
(cond ((null? list) '())
|
||||
((pred (car list)) (delete-if (cdr list)))
|
||||
(else
|
||||
(set-cdr! list (delete-if (cdr list)))
|
||||
list))))
|
||||
|
||||
(define-public (delete-if-not! pred list)
|
||||
(let delete-if ((list list))
|
||||
(cond ((null? list) '())
|
||||
((not (pred (car list))) (delete-if (cdr list)))
|
||||
(else
|
||||
(set-cdr! list (delete-if (cdr list)))
|
||||
list))))
|
||||
|
||||
(define-public (butlast lst n)
|
||||
(letrec ((l (- (length lst) n))
|
||||
(bl (lambda (lst n)
|
||||
(cond ((null? lst) lst)
|
||||
((positive? n)
|
||||
(cons (car lst) (bl (cdr lst) (+ -1 n))))
|
||||
(else '())))))
|
||||
(bl lst (if (negative? n)
|
||||
(error "negative argument to butlast" n)
|
||||
l))))
|
||||
|
||||
(define-public (and? . args)
|
||||
(cond ((null? args) #t)
|
||||
((car args) (apply and? (cdr args)))
|
||||
(else #f)))
|
||||
|
||||
(define-public (or? . args)
|
||||
(cond ((null? args) #f)
|
||||
((car args) #t)
|
||||
(else (apply or? (cdr args)))))
|
||||
|
||||
(define-public (has-duplicates? lst)
|
||||
(cond ((null? lst) #f)
|
||||
((member (car lst) (cdr lst)) #t)
|
||||
(else (has-duplicates? (cdr lst)))))
|
||||
|
||||
(define-public (list* x . y)
|
||||
(define (list*1 x)
|
||||
(if (null? (cdr x))
|
||||
(car x)
|
||||
(cons (car x) (list*1 (cdr x)))))
|
||||
(if (null? y)
|
||||
x
|
||||
(cons x (list*1 y))))
|
||||
|
||||
;; pick p l
|
||||
;; Apply P to each element of L, returning a list of elts
|
||||
;; for which P returns a non-#f value.
|
||||
;;
|
||||
(define-public (pick p l)
|
||||
(let loop ((s '())
|
||||
(l l))
|
||||
(cond
|
||||
((null? l) s)
|
||||
((p (car l)) (loop (cons (car l) s) (cdr l)))
|
||||
(else (loop s (cdr l))))))
|
||||
|
||||
;; pick p l
|
||||
;; Apply P to each element of L, returning a list of the
|
||||
;; non-#f return values of P.
|
||||
;;
|
||||
(define-public (pick-mappings p l)
|
||||
(let loop ((s '())
|
||||
(l l))
|
||||
(cond
|
||||
((null? l) s)
|
||||
((p (car l)) => (lambda (mapping) (loop (cons mapping s) (cdr l))))
|
||||
(else (loop s (cdr l))))))
|
||||
|
||||
(define-public (uniq l)
|
||||
(if (null? l)
|
||||
'()
|
||||
(let ((u (uniq (cdr l))))
|
||||
(if (memq (car l) u)
|
||||
u
|
||||
(cons (car l) u)))))
|
||||
|
||||
67
ice-9/ls.scm
Normal file
67
ice-9/ls.scm
Normal file
|
|
@ -0,0 +1,67 @@
|
|||
;;; {Functions for browsing modules}
|
||||
|
||||
(define-module (ice-9 ls)
|
||||
:use-module (ice-9 common-list))
|
||||
|
||||
;;;;
|
||||
;;; local-definitions-in root name
|
||||
;;; Returns a list of names defined locally in the named
|
||||
;;; subdirectory of root.
|
||||
;;; definitions-in root name
|
||||
;;; Returns a list of all names defined in the named
|
||||
;;; subdirectory of root. The list includes alll locally
|
||||
;;; defined names as well as all names inherited from a
|
||||
;;; member of a use-list.
|
||||
;;;
|
||||
;;; A convenient interface for examining the nature of things:
|
||||
;;;
|
||||
;;; ls . various-names
|
||||
;;;
|
||||
;;; With just one argument, interpret that argument as the
|
||||
;;; name of a subdirectory of the current module and
|
||||
;;; return a list of names defined there.
|
||||
;;;
|
||||
;;; With more than one argument, still compute
|
||||
;;; subdirectory lists, but return a list:
|
||||
;;; ((<subdir-name> . <names-defined-there>)
|
||||
;;; (<subdir-name> . <names-defined-there>)
|
||||
;;; ...)
|
||||
;;;
|
||||
|
||||
(define-public (local-definitions-in root names)
|
||||
(let ((m (nested-ref root names))
|
||||
(answer '()))
|
||||
(if (not (module? m))
|
||||
(set! answer m)
|
||||
(module-for-each (lambda (k v) (set! answer (cons k answer))) m))
|
||||
answer))
|
||||
|
||||
(define-public (definitions-in root names)
|
||||
(let ((m (nested-ref root names)))
|
||||
(if (not (module? m))
|
||||
m
|
||||
(reduce union
|
||||
(cons (local-definitions-in m '())
|
||||
(map (lambda (m2) (definitions-in m2 '()))
|
||||
(module-uses m)))))))
|
||||
|
||||
(define-public (ls . various-refs)
|
||||
(and various-refs
|
||||
(if (cdr various-refs)
|
||||
(map (lambda (ref)
|
||||
(cons ref (definitions-in (current-module) ref)))
|
||||
various-refs)
|
||||
(definitions-in (current-module) (car various-refs)))))
|
||||
|
||||
(define-public (lls . various-refs)
|
||||
(and various-refs
|
||||
(if (cdr various-refs)
|
||||
(map (lambda (ref)
|
||||
(cons ref (local-definitions-in (current-module) ref)))
|
||||
various-refs)
|
||||
(local-definitions-in (current-module) (car various-refs)))))
|
||||
|
||||
(define-public (recursive-local-define name value)
|
||||
(let ((parent (reverse! (cdr (reverse name)))))
|
||||
(and parent (make-modules-in (current-module) parent))
|
||||
(local-define name value)))
|
||||
139
ice-9/q.scm
Normal file
139
ice-9/q.scm
Normal file
|
|
@ -0,0 +1,139 @@
|
|||
;;; {Queues}
|
||||
|
||||
(define-module (ice-9 q))
|
||||
|
||||
;;;; Copyright (C) 1995 Free Software Foundation, Inc.
|
||||
;;;;
|
||||
;;;; This program is free software; you can redistribute it and/or modify
|
||||
;;;; it under the terms of the GNU General Public License as published by
|
||||
;;;; the Free Software Foundation; either version 2, or (at your option)
|
||||
;;;; any later version.
|
||||
;;;;
|
||||
;;;; This program 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 General Public License for more details.
|
||||
;;;;
|
||||
;;;; You should have received a copy of the GNU General Public License
|
||||
;;;; along with this software; see the file COPYING. If not, write to
|
||||
;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
|
||||
;;;; Boston, MA 02111-1307 USA
|
||||
;;;;
|
||||
|
||||
;;;;
|
||||
;;; Q: Based on the interface to
|
||||
;;;
|
||||
;;; "queue.scm" Queues/Stacks for Scheme
|
||||
;;; Written by Andrew Wilcox (awilcox@astro.psu.edu) on April 1, 1992.
|
||||
;;;
|
||||
|
||||
;;;;
|
||||
;;; {Q}
|
||||
;;;
|
||||
;;; A list is just a bunch of cons pairs that follows some constrains, right?
|
||||
;;; Association lists are the same. Hash tables are just vectors and association
|
||||
;;; lists. You can print them, read them, write them as constants, pun them off as other data
|
||||
;;; structures etc. This is good. This is lisp. These structures are fast and compact
|
||||
;;; and easy to manipulate arbitrarily because of their simple, regular structure and
|
||||
;;; non-disjointedness (associations being lists and so forth).
|
||||
;;;
|
||||
;;; So I figured, queues should be the same -- just a "subtype" of cons-pair
|
||||
;;; structures in general.
|
||||
;;;
|
||||
;;; A queue is a cons pair:
|
||||
;;; ( <the-q> . <last-pair> )
|
||||
;;;
|
||||
;;; <the-q> is a list of things in the q. New elements go at the end of that list.
|
||||
;;;
|
||||
;;; <last-pair> is #f if the q is empty, and otherwise is the last pair of <the-q>.
|
||||
;;;
|
||||
;;; q's print nicely, but alas, they do not read well because the eq?-ness of
|
||||
;;; <last-pair> and (last-pair <the-q>) is lost by read. The procedure
|
||||
;;;
|
||||
;;; (sync-q! q)
|
||||
;;;
|
||||
;;; recomputes and resets the <last-pair> component of a queue.
|
||||
;;;
|
||||
|
||||
(define-public (sync-q! obj) (set-cdr! obj (and (car obj) (last-pair (car obj)))))
|
||||
|
||||
;;; make-q
|
||||
;;; return a new q.
|
||||
;;;
|
||||
(define-public (make-q) (cons '() '()))
|
||||
|
||||
;;; q? obj
|
||||
;;; Return true if obj is a Q.
|
||||
;;; An object is a queue if it is equal? to '(#f . #f) or
|
||||
;;; if it is a pair P with (list? (car P)) and (eq? (cdr P) (last-pair P)).
|
||||
;;;
|
||||
(define-public (q? obj) (and (pair? obj)
|
||||
(or (and (null? (car obj))
|
||||
(null? (cdr obj)))
|
||||
(and
|
||||
(list? (car obj))
|
||||
(eq? (cdr obj) (last-pair (car obj)))))))
|
||||
|
||||
;;; q-empty? obj
|
||||
;;;
|
||||
(define-public (q-empty? obj) (null? (car obj)))
|
||||
|
||||
;;; q-empty-check q
|
||||
;;; Throw a q-empty exception if Q is empty.
|
||||
(define-public (q-empty-check q) (if (q-empty? q) (throw 'q-empty q)))
|
||||
|
||||
|
||||
;;; q-front q
|
||||
;;; Return the first element of Q.
|
||||
(define-public (q-front q) (q-empty-check q) (caar q))
|
||||
|
||||
;;; q-rear q
|
||||
;;; Return the last element of Q.
|
||||
(define-public (q-rear q) (q-empty-check q) (cadr q))
|
||||
|
||||
;;; q-remove! q obj
|
||||
;;; Remove all occurences of obj from Q.
|
||||
(define-public (q-remove! q obj)
|
||||
(while (memq obj (car q))
|
||||
(set-car! q (delq! obj (car q))))
|
||||
(set-cdr! q (last-pair (car q))))
|
||||
|
||||
;;; q-push! q obj
|
||||
;;; Add obj to the front of Q
|
||||
(define-public (q-push! q d)
|
||||
(let ((h (cons d (car q))))
|
||||
(set-car! q h)
|
||||
(if (null? (cdr q))
|
||||
(set-cdr! q h))))
|
||||
|
||||
;;; enq! q obj
|
||||
;;; Add obj to the rear of Q
|
||||
(define-public (enq! q d)
|
||||
(let ((h (cons d '())))
|
||||
(if (not (null? (cdr q)))
|
||||
(set-cdr! (cdr q) h)
|
||||
(set-car! q h))
|
||||
(set-cdr! q h)))
|
||||
|
||||
;;; q-pop! q
|
||||
;;; Take the front of Q and return it.
|
||||
(define-public (q-pop! q)
|
||||
(q-empty-check q)
|
||||
(let ((it (caar q))
|
||||
(next (cdar q)))
|
||||
(if (not next)
|
||||
(set-cdr! q #f))
|
||||
(set-car! q next)
|
||||
it))
|
||||
|
||||
;;; deq! q
|
||||
;;; Take the front of Q and return it.
|
||||
(define-public deq! q-pop!)
|
||||
|
||||
;;; q-length q
|
||||
;;; Return the number of enqueued elements.
|
||||
;;;
|
||||
(define-public (q-length q) (length (car q)))
|
||||
|
||||
|
||||
|
||||
240
ice-9/runq.scm
Normal file
240
ice-9/runq.scm
Normal file
|
|
@ -0,0 +1,240 @@
|
|||
;;; {The runq data structure}
|
||||
|
||||
(define-module (ice-9 runq)
|
||||
:use-module (ice-9 q))
|
||||
|
||||
;;;; Copyright (C) 1996 Free Software Foundation, Inc.
|
||||
;;;;
|
||||
;;;; This program is free software; you can redistribute it and/or modify
|
||||
;;;; it under the terms of the GNU General Public License as published by
|
||||
;;;; the Free Software Foundation; either version 2, or (at your option)
|
||||
;;;; any later version.
|
||||
;;;;
|
||||
;;;; This program 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 General Public License for more details.
|
||||
;;;;
|
||||
;;;; You should have received a copy of the GNU General Public License
|
||||
;;;; along with this software; see the file COPYING. If not, write to
|
||||
;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
|
||||
;;;; Boston, MA 02111-1307 USA
|
||||
;;;;
|
||||
|
||||
;;;;
|
||||
;;;
|
||||
;;; One way to schedule parallel computations in a serial environment is
|
||||
;;; to explicitly divide each task up into small, finite execution time,
|
||||
;;; strips. Then you interleave the execution of strips from various
|
||||
;;; tasks to achieve a kind of parallelism. Runqs are a handy data
|
||||
;;; structure for this style of programming.
|
||||
;;;
|
||||
;;; We use thunks (nullary procedures) and lists of thunks to represent
|
||||
;;; strips. By convention, the return value of a strip-thunk must either
|
||||
;;; be another strip or the value #f.
|
||||
;;;
|
||||
;;; A runq is a procedure that manages a queue of strips. Called with no
|
||||
;;; arguments, it processes one strip from the queue. Called with
|
||||
;;; arguments, the arguments form a control message for the queue. The
|
||||
;;; first argument is a symbol which is the message selector.
|
||||
;;;
|
||||
;;; A strip is processed this way: If the strip is a thunk, the thunk is
|
||||
;;; called -- if it returns a strip, that strip is added back to the
|
||||
;;; queue. To process a strip which is a list of thunks, the CAR of that
|
||||
;;; list is called. After a call to that CAR, there are 0, 1, or 2 strips
|
||||
;;; -- perhaps one returned by the thunk, and perhaps the CDR of the
|
||||
;;; original strip if that CDR is not nil. The runq puts whichever of
|
||||
;;; these strips exist back on the queue. (The exact order in which
|
||||
;;; strips are put back on the queue determines the scheduling behavior of
|
||||
;;; a particular queue -- it's a parameter.)
|
||||
;;;
|
||||
;;;
|
||||
|
||||
|
||||
|
||||
;;;;
|
||||
;;; (runq-control q msg . args)
|
||||
;;;
|
||||
;;; processes in the default way the control messages that
|
||||
;;; can be sent to a runq. Q should be an ordinary
|
||||
;;; Q (see utils/q.scm).
|
||||
;;;
|
||||
;;; The standard runq messages are:
|
||||
;;;
|
||||
;;; 'add! strip0 strip1... ;; to enqueue one or more strips
|
||||
;;; 'enqueue! strip0 strip1... ;; to enqueue one or more strips
|
||||
;;; 'push! strip0 ... ;; add strips to the front of the queue
|
||||
;;; 'empty? ;; true if it is
|
||||
;;; 'length ;; how many strips in the queue?
|
||||
;;; 'kill! ;; empty the queue
|
||||
;;; else ;; throw 'not-understood
|
||||
;;;
|
||||
(define-public (runq-control q msg . args)
|
||||
(case msg
|
||||
((add!) (for-each (lambda (t) (enq! q t)) args) '*unspecified*)
|
||||
((enque!) (for-each (lambda (t) (enq! q t)) args) '*unspecified*)
|
||||
((push!) (for-each (lambda (t) (q-push! q t)) args) '*unspecified*)
|
||||
((empty?) (q-empty? q))
|
||||
((length) (q-length q))
|
||||
((kill!) (set! q (make-q)))
|
||||
(else (throw 'not-understood msg args))))
|
||||
|
||||
(define (run-strip thunk) (catch #t thunk (lambda ign (warn 'runq-strip thunk ign) #f)))
|
||||
|
||||
;;;;
|
||||
;;; make-void-runq
|
||||
;;;
|
||||
;;; Make a runq that discards all messages except "length", for which
|
||||
;;; it returns 0.
|
||||
;;;
|
||||
(define-public (make-void-runq)
|
||||
(lambda opts
|
||||
(and opts
|
||||
(apply-to-args opts
|
||||
(lambda (msg . args)
|
||||
(case msg
|
||||
((length) 0)
|
||||
(else #f)))))))
|
||||
|
||||
;;;;
|
||||
;;; (make-fair-runq)
|
||||
;;;
|
||||
;;; Returns a runq procedure.
|
||||
;;; Called with no arguments, the procedure processes one strip from the queue.
|
||||
;;; Called with arguments, it uses runq-control.
|
||||
;;;
|
||||
;;; In a fair runq, if a strip returns a new strip X, X is added
|
||||
;;; to the end of the queue, meaning it will be the last to execute
|
||||
;;; of all the remaining procedures.
|
||||
;;;
|
||||
(define-public (make-fair-runq)
|
||||
(letrec ((q (make-q))
|
||||
(self
|
||||
(lambda ctl
|
||||
(if ctl
|
||||
(apply runq-control q ctl)
|
||||
(and (not (q-empty? q))
|
||||
(let ((next-strip (deq! q)))
|
||||
(cond
|
||||
((procedure? next-strip) (let ((k (run-strip next-strip)))
|
||||
(and k (enq! q k))))
|
||||
((pair? next-strip) (let ((k (run-strip (car next-strip))))
|
||||
(and k (enq! q k)))
|
||||
(if (not (null? (cdr next-strip)))
|
||||
(enq! q (cdr next-strip)))))
|
||||
self))))))
|
||||
self))
|
||||
|
||||
|
||||
;;;;
|
||||
;;; (make-exclusive-runq)
|
||||
;;;
|
||||
;;; Returns a runq procedure.
|
||||
;;; Called with no arguments, the procedure processes one strip from the queue.
|
||||
;;; Called with arguments, it uses runq-control.
|
||||
;;;
|
||||
;;; In an exclusive runq, if a strip W returns a new strip X, X is added
|
||||
;;; to the front of the queue, meaning it will be the next to execute
|
||||
;;; of all the remaining procedures.
|
||||
;;;
|
||||
;;; An exception to this occurs if W was the CAR of a list of strips.
|
||||
;;; In that case, after the return value of W is pushed onto the front
|
||||
;;; of the queue, the CDR of the list of strips is pushed in front
|
||||
;;; of that (if the CDR is not nil). This way, the rest of the thunks
|
||||
;;; in the list that contained W have priority over the return value of W.
|
||||
;;;
|
||||
(define-public (make-exclusive-runq)
|
||||
(letrec ((q (make-q))
|
||||
(self
|
||||
(lambda ctl
|
||||
(if ctl
|
||||
(apply runq-control q ctl)
|
||||
(and (not (q-empty? q))
|
||||
(let ((next-strip (deq! q)))
|
||||
(cond
|
||||
((procedure? next-strip) (let ((k (run-strip next-strip)))
|
||||
(and k (q-push! q k))))
|
||||
((pair? next-strip) (let ((k (run-strip (car next-strip))))
|
||||
(and k (q-push! q k)))
|
||||
(if (not (null? (cdr next-strip)))
|
||||
(q-push! q (cdr next-strip)))))
|
||||
self))))))
|
||||
self))
|
||||
|
||||
|
||||
;;;;
|
||||
;;; (make-subordinate-runq-to superior basic-inferior)
|
||||
;;;
|
||||
;;; Returns a runq proxy for the runq basic-inferior.
|
||||
;;;
|
||||
;;; The proxy watches for operations on the basic-inferior that cause
|
||||
;;; a transition from a queue length of 0 to a non-zero length and
|
||||
;;; vice versa. While the basic-inferior queue is not empty,
|
||||
;;; the proxy installs a task on the superior runq. Each strip
|
||||
;;; of that task processes N strips from the basic-inferior where
|
||||
;;; N is the length of the basic-inferior queue when the proxy
|
||||
;;; strip is entered. [Countless scheduling variations are possible.]
|
||||
;;;
|
||||
(define-public (make-subordinate-runq-to superior-runq basic-runq)
|
||||
(let ((runq-task (cons #f #f)))
|
||||
(set-car! runq-task
|
||||
(lambda ()
|
||||
(if (basic-runq 'empty?)
|
||||
(set-cdr! runq-task #f)
|
||||
(do ((n (basic-runq 'length) (1- n)))
|
||||
((<= n 0) #f)
|
||||
(basic-runq)))))
|
||||
(letrec ((self
|
||||
(lambda ctl
|
||||
(if (not ctl)
|
||||
(let ((answer (basic-runq)))
|
||||
(self 'empty?)
|
||||
answer)
|
||||
(begin
|
||||
(case (car ctl)
|
||||
((suspend) (set-cdr! runq-task #f))
|
||||
(else (let ((answer (apply basic-runq ctl)))
|
||||
(if (and (not (cdr runq-task)) (not (basic-runq 'empty?)))
|
||||
(begin
|
||||
(set-cdr! runq-task runq-task)
|
||||
(superior-runq 'add! runq-task)))
|
||||
answer))))))))
|
||||
self)))
|
||||
|
||||
;;;;
|
||||
;;; (define fork-strips (lambda args args))
|
||||
;;; Return a strip that starts several strips in
|
||||
;;; parallel. If this strip is enqueued on a fair
|
||||
;;; runq, strips of the parallel subtasks will run
|
||||
;;; round-robin style.
|
||||
;;;
|
||||
(define fork-strips (lambda args args))
|
||||
|
||||
|
||||
;;;;
|
||||
;;; (strip-sequence . strips)
|
||||
;;;
|
||||
;;; Returns a new strip which is the concatenation of the argument strips.
|
||||
;;;
|
||||
(define-public ((strip-sequence . strips))
|
||||
(let loop ((st (let ((a strips)) (set! strips #f) a)))
|
||||
(and (not (null? st))
|
||||
(let ((then ((car st))))
|
||||
(if then
|
||||
(lambda () (loop (cons then (cdr st))))
|
||||
(lambda () (loop (cdr st))))))))
|
||||
|
||||
|
||||
;;;;
|
||||
;;; (fair-strip-subtask . initial-strips)
|
||||
;;;
|
||||
;;; Returns a new strip which is the synchronos, fair,
|
||||
;;; parallel execution of the argument strips.
|
||||
;;;
|
||||
;;;
|
||||
;;;
|
||||
(define-public (fair-strip-subtask . initial-strips)
|
||||
(let ((st (make-fair-runq)))
|
||||
(apply st 'add! initial-strips)
|
||||
st))
|
||||
|
||||
254
ice-9/string-fun.scm
Normal file
254
ice-9/string-fun.scm
Normal file
|
|
@ -0,0 +1,254 @@
|
|||
;;; {String Fun}
|
||||
|
||||
(define-module (ice-9 string-fun))
|
||||
|
||||
;;;;
|
||||
;;;
|
||||
;;; 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-public (split-after-char char str ret)
|
||||
(let ((end (cond
|
||||
((string-index str char) => 1+)
|
||||
(else (string-length str)))))
|
||||
(ret (make-shared-substring str 0 end)
|
||||
(make-shared-substring str end))))
|
||||
|
||||
(define-public (split-before-char char str ret)
|
||||
(let ((end (or (string-index str char)
|
||||
(string-length str))))
|
||||
(ret (make-shared-substring str 0 end)
|
||||
(make-shared-substring str end))))
|
||||
|
||||
(define-public (split-discarding-char char str ret)
|
||||
(let ((end (string-index str char)))
|
||||
(if (not end)
|
||||
(ret str "")
|
||||
(ret (make-shared-substring str 0 end)
|
||||
(make-shared-substring str (1+ end))))))
|
||||
|
||||
(define-public (split-after-char-last char str ret)
|
||||
(let ((end (cond
|
||||
((string-rindex str char) => 1+)
|
||||
(else 0))))
|
||||
(ret (make-shared-substring str 0 end)
|
||||
(make-shared-substring str end))))
|
||||
|
||||
(define-public (split-before-char-last char str ret)
|
||||
(let ((end (or (string-rindex str char) 0)))
|
||||
(ret (make-shared-substring str 0 end)
|
||||
(make-shared-substring str end))))
|
||||
|
||||
(define-public (split-discarding-char-last char str ret)
|
||||
(let ((end (string-rindex str char)))
|
||||
(if (not end)
|
||||
(ret str "")
|
||||
(ret (make-shared-substring str 0 end)
|
||||
(make-shared-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 (make-shared-substring str 0 n)
|
||||
(make-shared-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 (make-shared-substring str 0 (1+ n))
|
||||
(make-shared-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 (make-shared-substring str 0 n)
|
||||
(make-shared-substring str (1+ n)))))))
|
||||
|
||||
(define-public (separate-fields-discarding-char ch str ret)
|
||||
(let loop ((fields '())
|
||||
(str str))
|
||||
(cond
|
||||
((string-rindex str ch)
|
||||
=> (lambda (w) (loop (cons (make-shared-substring str (+ 1 w)) fields)
|
||||
(make-shared-substring str 0 w))))
|
||||
(else (apply ret str fields)))))
|
||||
|
||||
(define-public (separate-fields-after-char ch str ret)
|
||||
(reverse
|
||||
(let loop ((fields '())
|
||||
(str str))
|
||||
(cond
|
||||
((string-index str ch)
|
||||
=> (lambda (w) (loop (cons (make-shared-substring str 0 (+ 1 w)) fields)
|
||||
(make-shared-substring str (+ 1 w)))))
|
||||
(else (apply ret str fields))))))
|
||||
|
||||
(define-public (separate-fields-before-char ch str ret)
|
||||
(let loop ((fields '())
|
||||
(str str))
|
||||
(cond
|
||||
((string-rindex str ch)
|
||||
=> (lambda (w) (loop (cons (make-shared-substring str w) fields)
|
||||
(make-shared-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 (make-shared-substring str 0 (string-length prefix)))))
|
||||
;;;
|
||||
;;; (define-public string-prefix=? (string-prefix-predicate string=?))
|
||||
;;;
|
||||
|
||||
(define-public ((string-prefix-predicate pred?) prefix str)
|
||||
(and (<= (string-length prefix) (string-length str))
|
||||
(pred? prefix (make-shared-substring str 0 (string-length prefix)))))
|
||||
|
||||
(define-public string-prefix=? (string-prefix-predicate string=?))
|
||||
|
||||
|
||||
;;; {String Fun: Strippers}
|
||||
;;;
|
||||
;;; <stripper> = sans-<removable-part>
|
||||
;;;
|
||||
;;; <removable-part> = surrounding-whitespace
|
||||
;;; | trailing-whitespace
|
||||
;;; | leading-whitespace
|
||||
;;; | final-newline
|
||||
;;;
|
||||
|
||||
(define-public (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)
|
||||
""
|
||||
(make-shared-substring s st end))))
|
||||
|
||||
(define-public (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)
|
||||
""
|
||||
(make-shared-substring s st end))))
|
||||
|
||||
(define-public (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)
|
||||
""
|
||||
(make-shared-substring s st end))))
|
||||
|
||||
(define-public (sans-final-newline str)
|
||||
(cond
|
||||
((= 0 (string-length str))
|
||||
str)
|
||||
|
||||
((char=? #\nl (string-ref str (1- (string-length str))))
|
||||
(make-shared-substring str 0 (1- (string-length str))))
|
||||
|
||||
(else str)))
|
||||
|
||||
;;; {String Fun: has-trailing-newline?}
|
||||
;;;
|
||||
|
||||
(define-public (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))))
|
||||
|
||||
Loading…
Add table
Add a link
Reference in a new issue