1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-28 16:00:22 +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 1997-09-30 17:16:54 +00:00
parent cb0a5b3957
commit a6401ee0f2
9 changed files with 1181 additions and 1186 deletions

View file

@ -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

View file

@ -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

File diff suppressed because it is too large Load diff

300
ice-9/calling.scm Normal file
View 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
View 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
View 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
View 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
View 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
View 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))))