[uim-commit] r1244 - branches/r5rs/scm
kzk at freedesktop.org
kzk at freedesktop.org
Sun Aug 21 03:41:08 EST 2005
Author: kzk
Date: 2005-08-20 10:41:05 -0700 (Sat, 20 Aug 2005)
New Revision: 1244
Added:
branches/r5rs/scm/slib-comlist.scm
branches/r5rs/scm/slib-mulapply.scm
branches/r5rs/scm/slib-sc2.scm
branches/r5rs/scm/slib-srfi-1.scm
Modified:
branches/r5rs/scm/custom.scm
branches/r5rs/scm/key.scm
branches/r5rs/scm/util.scm
Log:
* adopt slib's srfi-1 procedures
* change key.scm's equation proc
* scm/slib-mulapply.scm
* scm/slib-sc2.scm
* scm/slib-srfi-1.scm
* scm/slib-comlist.scm
- new file
* scm/util.scm
- require "slib-mulapply.scm" and "slib-srfi-1.scm"
- (string-escape): now returns newly allocated str
- (char-downcase, char-upcase): restored because current uim handles
char as integer
- (list-tabulate, make-list, iota, last, append!,
concatenate, concatenate!, zip, append-reverse,
find, any, every, fold, unfold, filter, filter-map,
remove, delete, alist-delete): replaced with SLIB's srfi-1 procs
This may be slow, but current iterate_list have some problems
with R5RS compatibility.
- (bitwise-not, bitwise-and, bitwise-or, bitwise-xor): restored
* scm/custom.scm
- (custom-list-as-literal, custom-value-as-literal): change the way
to use "string-escape"
- (prealloc-heaps-for-heavy-job): not supported now
* scm/key.scm
- (valid-key-str?, valid-strict-key-str?): use "eqv?" instead of "="
because first argument can be symbol
- (define-key): restored because it seems to work now
Modified: branches/r5rs/scm/custom.scm
===================================================================
--- branches/r5rs/scm/custom.scm 2005-08-20 16:56:51 UTC (rev 1243)
+++ branches/r5rs/scm/custom.scm 2005-08-20 17:41:05 UTC (rev 1244)
@@ -664,7 +664,7 @@
((symbol? elem)
(symbol->string elem))
((string? elem)
- (string-escape elem))
+ (set! elem (string-escape elem)))
(else
"")))
lst)))
@@ -679,9 +679,9 @@
((eq? type 'integer)
(digit->string val))
((eq? type 'string)
- (string-escape val))
+ (set! val (string-escape val)))
((eq? type 'pathname)
- (string-escape val))
+ (set! val (string-escape val)))
((eq? type 'choice)
(string-append "'" (symbol->string val)))
((or (eq? type 'ordered-list)
@@ -745,5 +745,5 @@
(_ "Hidden settings")
(_ "Hidden settings of this group. This group is invisible from uim_custom clients. Exists for internal variable management."))
-(prealloc-heaps-for-heavy-job)
+;(prealloc-heaps-for-heavy-job)
(custom-reload-customs)
Modified: branches/r5rs/scm/key.scm
===================================================================
--- branches/r5rs/scm/key.scm 2005-08-20 16:56:51 UTC (rev 1243)
+++ branches/r5rs/scm/key.scm 2005-08-20 17:41:05 UTC (rev 1244)
@@ -318,7 +318,7 @@
(key-state (nth 3 parsed)))
(and (string? key-str)
(string=? rest "")
- (not (= key -1))))))
+ (not (eqv? key -1))))))
;; 'strict-key-str' stands for key-str without translator-prefixes and
;; emacs like prefix
@@ -335,11 +335,11 @@
(set! res (and (string? key-str)
(string=? rest "")
(null? translators)
- (not (= key -1)))))
+ (not (eqv? key -1)))))
(set! enable-emacs-like-key-prefix? saved-enable-eprefix?)
res)))
;;
-;(define-key left-key? "left")
-;(define-key right-key? "right")
-;(define-key switch-im-key? '("<Control>Shift_key" "<Shift>Control_key"))
+(define-key left-key? "left")
+(define-key right-key? "right")
+(define-key switch-im-key? '("<Control>Shift_key" "<Shift>Control_key"))
Added: branches/r5rs/scm/slib-comlist.scm
===================================================================
--- branches/r5rs/scm/slib-comlist.scm 2005-08-20 16:56:51 UTC (rev 1243)
+++ branches/r5rs/scm/slib-comlist.scm 2005-08-20 17:41:05 UTC (rev 1244)
@@ -0,0 +1,338 @@
+;;"comlist.scm" Implementation of COMMON LISP list functions for Scheme
+; Copyright (C) 1991, 1993, 1995, 2001, 2003 Aubrey Jaffer.
+; Copyright (C) 2000 Colin Walters
+;
+;Permission to copy this software, to modify it, to redistribute it,
+;to distribute modified versions, 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 warranty 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.
+
+;;; Some of these functions may be already defined in your Scheme.
+;;; Comment out those definitions for functions which are already defined.
+
+;;;; LIST FUNCTIONS FROM COMMON LISP
+
+;;; Some tail-recursive optimizations made by
+;;; Colin Walters <walters at cis.ohio-state.edu>
+;;; AGJ restored order July 2001.
+
+;;;@ From: hugh at ear.mit.edu (Hugh Secker-Walker)
+(define (make-list k . init)
+ (set! init (if (pair? init) (car init)))
+ (do ((k (+ -1 k) (+ -1 k))
+ (result '() (cons init result)))
+ ((negative? k) result)))
+;@
+(define (copy-list lst) (append lst '()))
+;@
+(define (adjoin obj lst) (if (memv obj lst) lst (cons obj lst)))
+;@
+(define union
+ (letrec ((onion
+ (lambda (lst1 lst2)
+ (if (null? lst1)
+ lst2
+ (onion (cdr lst1) (comlist:adjoin (car lst1) lst2))))))
+ (lambda (lst1 lst2)
+ (cond ((null? lst1) lst2)
+ ((null? lst2) lst1)
+ ((null? (cdr lst1)) (comlist:adjoin (car lst1) lst2))
+ ((null? (cdr lst2)) (comlist:adjoin (car lst2) lst1))
+ ((< (length lst2) (length lst1)) (onion (reverse lst2) lst1))
+ (else (onion (reverse lst1) lst2))))))
+;@
+(define (intersection lst1 lst2)
+ (if (null? lst2)
+ lst2
+ (let build-intersection ((lst1 lst1)
+ (result '()))
+ (cond ((null? lst1) (reverse result))
+ ((memv (car lst1) lst2)
+ (build-intersection (cdr lst1) (cons (car lst1) result)))
+ (else
+ (build-intersection (cdr lst1) result))))))
+;@
+(define (set-difference lst1 lst2)
+ (if (null? lst2)
+ lst1
+ (let build-difference ((lst1 lst1)
+ (result '()))
+ (cond ((null? lst1) (reverse result))
+ ((memv (car lst1) lst2) (build-difference (cdr lst1) result))
+ (else (build-difference (cdr lst1) (cons (car lst1) result)))))))
+;@
+(define (subset? lst1 lst2)
+ (or (eq? lst1 lst2)
+ (let loop ((lst1 lst1))
+ (or (null? lst1)
+ (and (memv (car lst1) lst2)
+ (loop (cdr lst1)))))))
+;@
+(define (position obj lst)
+ (define pos (lambda (n lst)
+ (cond ((null? lst) #f)
+ ((eqv? obj (car lst)) n)
+ (else (pos (+ 1 n) (cdr lst))))))
+ (pos 0 lst))
+;@
+(define (reduce-init pred? init lst)
+ (if (null? lst)
+ init
+ (comlist:reduce-init pred? (pred? init (car lst)) (cdr lst))))
+;@
+(define (reduce pred? lst)
+ (cond ((null? lst) lst)
+ ((null? (cdr lst)) (car lst))
+ (else (comlist:reduce-init pred? (car lst) (cdr lst)))))
+;@
+(define (some pred lst . rest)
+ (cond ((null? rest)
+ (let mapf ((lst lst))
+ (and (not (null? lst))
+ (or (pred (car lst)) (mapf (cdr lst))))))
+ (else (let mapf ((lst lst) (rest rest))
+ (and (not (null? lst))
+ (or (apply pred (car lst) (map car rest))
+ (mapf (cdr lst) (map cdr rest))))))))
+;@
+(define (every pred lst . rest)
+ (cond ((null? rest)
+ (let mapf ((lst lst))
+ (or (null? lst)
+ (and (pred (car lst)) (mapf (cdr lst))))))
+ (else (let mapf ((lst lst) (rest rest))
+ (or (null? lst)
+ (and (apply pred (car lst) (map car rest))
+ (mapf (cdr lst) (map cdr rest))))))))
+;@
+(define (notany pred . ls) (not (apply comlist:some pred ls)))
+;@
+(define (notevery pred . ls) (not (apply comlist:every pred ls)))
+;@
+(define (list-of?? predicate . bound)
+ (define (errout) (apply slib:error 'list-of?? predicate bound))
+ (case (length bound)
+ ((0)
+ (lambda (obj)
+ (and (list? obj)
+ (comlist:every predicate obj))))
+ ((1)
+ (set! bound (car bound))
+ (cond ((negative? bound)
+ (set! bound (- bound))
+ (lambda (obj)
+ (and (list? obj)
+ (<= bound (length obj))
+ (comlist:every predicate obj))))
+ (else
+ (lambda (obj)
+ (and (list? obj)
+ (<= (length obj) bound)
+ (comlist:every predicate obj))))))
+ ((2)
+ (let ((low (car bound))
+ (high (cadr bound)))
+ (cond ((or (negative? low) (negative? high)) (errout))
+ ((< high low)
+ (set! high (car bound))
+ (set! low (cadr bound))))
+ (lambda (obj)
+ (and (list? obj)
+ (<= low (length obj) high)
+ (comlist:every predicate obj)))))
+ (else (errout))))
+;@
+(define (find-if pred? lst)
+ (cond ((null? lst) #f)
+ ((pred? (car lst)) (car lst))
+ (else (comlist:find-if pred? (cdr lst)))))
+;@
+(define (member-if pred? lst)
+ (cond ((null? lst) #f)
+ ((pred? (car lst)) lst)
+ (else (comlist:member-if pred? (cdr lst)))))
+;@
+(define (remove obj lst)
+ (define head (list '*head*))
+ (let remove ((lst lst)
+ (tail head))
+ (cond ((null? lst))
+ ((eqv? obj (car lst)) (remove (cdr lst) tail))
+ (else
+ (set-cdr! tail (list (car lst)))
+ (remove (cdr lst) (cdr tail)))))
+ (cdr head))
+;@
+(define (remove-if pred? lst)
+ (let remove-if ((lst lst)
+ (result '()))
+ (cond ((null? lst) (reverse result))
+ ((pred? (car lst)) (remove-if (cdr lst) result))
+ (else (remove-if (cdr lst) (cons (car lst) result))))))
+;@
+(define (remove-if-not pred? lst)
+ (let remove-if-not ((lst lst)
+ (result '()))
+ (cond ((null? lst) (reverse result))
+ ((pred? (car lst)) (remove-if-not (cdr lst) (cons (car lst) result)))
+ (else (remove-if-not (cdr lst) result)))))
+;@
+(define nconc
+ (if (provided? "rev2-procedures") append!
+ (lambda args
+ (cond ((null? args) '())
+ ((null? (cdr args)) (car args))
+ ((null? (car args)) (apply comlist:nconc (cdr args)))
+ (else
+ (set-cdr! (last-pair (car args))
+ (apply comlist:nconc (cdr args)))
+ (car args))))))
+
+;;;@ From: hugh at ear.mit.edu (Hugh Secker-Walker)
+(define (nreverse rev-it)
+;;; Reverse order of elements of LIST by mutating cdrs.
+ (cond ((null? rev-it) rev-it)
+ ((not (list? rev-it))
+ (slib:error "nreverse: Not a list in arg1" rev-it))
+ (else (do ((reved '() rev-it)
+ (rev-cdr (cdr rev-it) (cdr rev-cdr))
+ (rev-it rev-it rev-cdr))
+ ((begin (set-cdr! rev-it reved) (null? rev-cdr)) rev-it)))))
+;@
+(define (last lst n)
+ (comlist:nthcdr (- (length lst) n) lst))
+;@
+(define (butlast lst n)
+ (comlist:butnthcdr (- (length lst) n) lst))
+;@
+(define (nthcdr n lst)
+ (if (zero? n) lst (comlist:nthcdr (+ -1 n) (cdr lst))))
+;@
+(define (butnthcdr k lst)
+ (cond ((negative? k) lst) ;(slib:error "negative argument to butnthcdr" k)
+ ; SIMSYNCH FIFO8 uses negative k.
+ ((or (zero? k) (null? lst)) '())
+ (else (let ((ans (list (car lst))))
+ (do ((lst (cdr lst) (cdr lst))
+ (tail ans (cdr tail))
+ (k (+ -2 k) (+ -1 k)))
+ ((or (negative? k) (null? lst)) ans)
+ (set-cdr! tail (list (car lst))))))))
+
+;;;; CONDITIONALS
+;@
+(define (and? . args)
+ (cond ((null? args) #t)
+ ((car args) (apply comlist:and? (cdr args)))
+ (else #f)))
+;@
+(define (or? . args)
+ (cond ((null? args) #f)
+ ((car args) #t)
+ (else (apply comlist:or? (cdr args)))))
+
+;;;@ Checks to see if a list has any duplicate MEMBERs.
+(define (has-duplicates? lst)
+ (cond ((null? lst) #f)
+ ((member (car lst) (cdr lst)) #t)
+ (else (comlist:has-duplicates? (cdr lst)))))
+
+;;;@ remove duplicates of MEMBERs of a list
+(define remove-duplicates
+ (letrec ((rem-dup
+ (lambda (lst nlst)
+ (cond ((null? lst) (reverse nlst))
+ ((member (car lst) nlst) (rem-dup (cdr lst) nlst))
+ (else (rem-dup (cdr lst) (cons (car lst) nlst)))))))
+ (lambda (lst)
+ (rem-dup lst '()))))
+;@
+(define list*
+ (letrec ((list*1 (lambda (obj)
+ (if (null? (cdr obj))
+ (car obj)
+ (cons (car obj) (list*1 (cdr obj)))))))
+ (lambda (obj1 . obj2)
+ (if (null? obj2)
+ obj1
+ (cons obj1 (list*1 obj2))))))
+;@
+(define (atom? obj)
+ (not (pair? obj)))
+;@
+(define (delete obj lst)
+ (let delete ((lst lst))
+ (cond ((null? lst) '())
+ ((equal? obj (car lst)) (delete (cdr lst)))
+ (else
+ (set-cdr! lst (delete (cdr lst)))
+ lst))))
+;@
+(define (delete-if pred lst)
+ (let delete-if ((lst lst))
+ (cond ((null? lst) '())
+ ((pred (car lst)) (delete-if (cdr lst)))
+ (else
+ (set-cdr! lst (delete-if (cdr lst)))
+ lst))))
+;@
+(define (delete-if-not pred lst)
+ (let delete-if ((lst lst))
+ (cond ((null? lst) '())
+ ((not (pred (car lst))) (delete-if (cdr lst)))
+ (else
+ (set-cdr! lst (delete-if (cdr lst)))
+ lst))))
+
+;;; internal versions safe from name collisions.
+
+;;(define comlist:make-list make-list)
+;;(define comlist:copy-list copy-list)
+(define comlist:adjoin adjoin)
+;;(define comlist:union union)
+;;(define comlist:intersection intersection)
+;;(define comlist:set-difference set-difference)
+;;(define comlist:subset? subset?)
+;;(define comlist:position position)
+(define comlist:reduce-init reduce-init)
+;;(define comlist:reduce reduce) ; reduce is also in collect.scm
+(define comlist:some some)
+(define comlist:every every)
+;;(define comlist:notevery notevery)
+;;(define comlist:notany notany)
+(define comlist:find-if find-if)
+(define comlist:member-if member-if)
+;;(define comlist:remove remove)
+;;(define comlist:remove-if remove-if)
+;;(define comlist:remove-if-not remove-if-not)
+(define comlist:nconc nconc)
+;;(define comlist:nreverse nreverse)
+;;(define comlist:last last)
+;;(define comlist:butlast butlast)
+(define comlist:nthcdr nthcdr)
+(define comlist:butnthcdr butnthcdr)
+(define comlist:and? and?)
+(define comlist:or? or?)
+(define comlist:has-duplicates? has-duplicates?)
+;;(define comlist:remove-duplicates remove-duplicates)
+;;(define comlist:delete-if-not delete-if-not)
+;;(define comlist:delete-if delete-if)
+;;(define comlist:delete delete)
+;;(define comlist:atom? atom?)
+;;(define atom atom?)
+;;(define comlist:atom atom?)
+;;(define comlist:list* list*)
+;;(define comlist:list-of?? list-of??)
+
+(provide "comlist")
Added: branches/r5rs/scm/slib-mulapply.scm
===================================================================
--- branches/r5rs/scm/slib-mulapply.scm 2005-08-20 16:56:51 UTC (rev 1243)
+++ branches/r5rs/scm/slib-mulapply.scm 2005-08-20 17:41:05 UTC (rev 1244)
@@ -0,0 +1,30 @@
+; "mulapply.scm" Redefine APPLY take more than 2 arguments.
+;Copyright (C) 1991, 2003 Aubrey Jaffer
+;
+;Permission to copy this software, to modify it, to redistribute it,
+;to distribute modified versions, 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 warranty 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 apply
+ (letrec ((apply-2 apply)
+ (append-to-last
+ (lambda (lst)
+ (if (null? (cdr lst))
+ (car lst)
+ (cons (car lst) (append-to-last (cdr lst)))))))
+ (lambda args
+ (apply-2 (car args) (append-to-last (cdr args))))))
+
+(provide "mulapply")
Added: branches/r5rs/scm/slib-sc2.scm
===================================================================
--- branches/r5rs/scm/slib-sc2.scm 2005-08-20 16:56:51 UTC (rev 1243)
+++ branches/r5rs/scm/slib-sc2.scm 2005-08-20 17:41:05 UTC (rev 1244)
@@ -0,0 +1,69 @@
+;"sc2.scm" Implementation of rev2 procedures eliminated in subsequent versions.
+; Copyright (C) 1991, 1993 Aubrey Jaffer
+;
+;Permission to copy this software, to modify it, to redistribute it,
+;to distribute modified versions, 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 warranty 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 (substring-move-left! string1 start1 end1 string2 start2)
+ (do ((i start1 (+ i 1))
+ (j start2 (+ j 1))
+ (l (- end1 start1) (- l 1)))
+ ((<= l 0))
+ (string-set! string2 j (string-ref string1 i))))
+;@
+(define (substring-move-right! string1 start1 end1 string2 start2)
+ (do ((i (+ start1 (- end1 start1) -1) (- i 1))
+ (j (+ start2 (- end1 start1) -1) (- j 1))
+ (l (- end1 start1) (- l 1)))
+ ((<= l 0))
+ (string-set! string2 j (string-ref string1 i))))
+;@
+(define (substring-fill! string start end char)
+ (do ((i start (+ i 1))
+ (l (- end start) (- l 1)))
+ ((<= l 0))
+ (string-set! string i char)))
+;@
+(define (string-null? str)
+ (= 0 (string-length str)))
+;@
+(define append!
+ (lambda args
+ (cond ((null? args) '())
+ ((null? (cdr args)) (car args))
+ ((null? (car args)) (apply append! (cdr args)))
+ (else
+ (set-cdr! (last-pair (car args))
+ (apply append! (cdr args)))
+ (car args)))))
+
+;;;; need to add code for OBJECT-HASH and OBJECT-UNHASH
+;@
+(define 1+
+ (let ((+ +))
+ (lambda (n) (+ n 1))))
+(define -1+
+ (let ((+ +))
+ (lambda (n) (+ n -1))))
+;@
+(define <? <)
+(define <=? <=)
+(define =? =)
+(define >? >)
+(define >=? >=)
+
+(provide "rev2-procedures")
Added: branches/r5rs/scm/slib-srfi-1.scm
===================================================================
--- branches/r5rs/scm/slib-srfi-1.scm 2005-08-20 16:56:51 UTC (rev 1243)
+++ branches/r5rs/scm/slib-srfi-1.scm 2005-08-20 17:41:05 UTC (rev 1244)
@@ -0,0 +1,645 @@
+;;; "srfi-1.scm" SRFI-1 list-processing library -*-scheme-*-
+;; Copyright 2001 Aubrey Jaffer
+;; Copyright 2003 Sven Hartrumpf
+;; Copyright 2003-2004 Lars Buitinck
+;
+;Permission to copy this software, to modify it, to redistribute it,
+;to distribute modified versions, 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 warranty 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.
+
+; Some pieces from:
+;;;
+;;; Copyright (c) 1998, 1999 by Olin Shivers. You may do as you please with
+;;; this code as long as you do not remove this copyright notice or
+;;; hold me liable for its use. Please send bug reports to shivers at ai.mit.edu.
+;;; -Olin
+
+;;@code{(require 'srfi-1)}
+;;@ftindex srfi-1
+;;
+;;@noindent
+;;Implements the @dfn{SRFI-1} @dfn{list-processing library} as described
+;;at @url{http://srfi.schemers.org/srfi-1/srfi-1.html}
+
+(require "slib-mulapply.scm")
+(require "slib-sc2.scm") ;for append!
+(require "slib-comlist.scm")
+
+;;@subheading Constructors
+
+;;@body
+;; @code{(define (xcons d a) (cons a d))}.
+(define (xcons d a) (cons a d))
+
+;;@body
+;; Returns a list of length @1. Element @var{i} is
+;;@code{(@2 @var{i})} for 0 <= @var{i} < @1.
+(define (list-tabulate len proc)
+ (do ((i (- len 1) (- i 1))
+ (ans '() (cons (proc i) ans)))
+ ((< i 0) ans)))
+
+;;@args obj1 obj2
+(define cons* list*)
+
+;;@args flist
+(define list-copy copy-list)
+
+;;@args count start step
+;;@args count start
+;;@args count
+;;Returns a list of @1 numbers: (@2, @2+ at 3, @dots{}, @2+(@1-1)*@3).
+(define (iota count . args)
+ (let ((start (if (null? args) 0 (car args)))
+ (step (if (or (null? args) (null? (cdr args))) 1 (cadr args))))
+ (list-tabulate count (lambda (idx) (+ start (* step idx))))))
+
+;;@body
+;;Returns a circular list of @1, @2, @dots{}.
+(define (circular-list obj1 . obj2)
+ (let ((ans (cons obj1 obj2)))
+ (set-cdr! (last-pair ans) ans)
+ ans))
+
+;;@subheading Predicates
+
+;;@args obj
+(define proper-list? list?)
+
+;;@body
+(define (circular-list? x)
+ (let lp ((x x) (lag x))
+ (and (pair? x)
+ (let ((x (cdr x)))
+ (and (pair? x)
+ (let ((x (cdr x))
+ (lag (cdr lag)))
+ (or (eq? x lag) (lp x lag))))))))
+
+;;@body
+(define (dotted-list? obj)
+ (not (or (proper-list? obj) (circular-list? obj))))
+
+;;@args obj
+(define null-list? null?)
+
+;;@body
+(define (not-pair? obj) (not (pair? obj)))
+
+;;@body
+(define (list= =pred . lists)
+ (or (null? lists) ; special case
+ (let lp1 ((list-a (car lists)) (others (cdr lists)))
+ (or (null? others)
+ (let ((list-b (car others))
+ (others (cdr others)))
+ (if (eq? list-a list-b) ; EQ? => LIST=
+ (lp1 list-b others)
+ (let lp2 ((list-a list-a) (list-b list-b))
+ (if (null-list? list-a)
+ (and (null-list? list-b)
+ (lp1 list-b others))
+ (and (not (null-list? list-b))
+ (=pred (car list-a) (car list-b))
+ (lp2 (cdr list-a) (cdr list-b)))))))))))
+
+;;@subheading Selectors
+
+;;@args pair
+(define first car)
+;;@args pair
+(define second cadr)
+;;@args pair
+(define third caddr)
+;;@args pair
+(define fourth cadddr)
+;;@body
+(define (fifth pair) (car (cddddr pair)))
+(define (sixth pair) (cadr (cddddr pair)))
+(define (seventh pair) (caddr (cddddr pair)))
+(define (eighth pair) (cadddr (cddddr pair)))
+(define (ninth pair) (car (cddddr (cddddr pair))))
+(define (tenth pair) (cadr (cddddr (cddddr pair))))
+
+;;@body
+(define (car+cdr pair) (values (car pair) (cdr pair)))
+
+;;@args lst k
+(define (drop lst k) (nthcdr k lst))
+(define (take lst k) (butnthcdr k lst))
+(define (take! lst k)
+ (if (or (null? lst) (<= k 0))
+ '()
+ (begin (set-cdr! (drop (- k 1) lst) '()) lst)))
+;;@args lst k
+(define take-right last)
+;;@args lst k
+(define drop-right butlast)
+;;@args lst k
+(define drop-right! drop-right)
+
+;;@body
+(define (split-at lst k)
+ (let loop ((l '()) (r lst) (k k))
+ (if (or (null? r) (= k 0))
+ (values (reverse! l) r)
+ (loop (cons (car r) l) (cdr r) (- k 1)))))
+(define (split-at! lst k)
+ (if (= k 0)
+ (values '() lst)
+ (let* ((half (drop lst (- k 1)))
+ (r (cdr half)))
+ (set-cdr! half '())
+ (values lst r))))
+
+;;@body
+(define (last lst . k)
+ (if (null? k)
+ (car (last-pair lst))
+ (apply take-right lst k)))
+
+;;@subheading Miscellaneous
+
+;;@body
+(define (length+ clist) (and (list? clist) (length clist)))
+
+;;Append and append! are provided by R4RS and rev2-procedures.
+
+;;@body
+(define (concatenate lists) (reduce-right append '() lists))
+(define (concatenate! lists) (reduce-right append! '() lists))
+
+;;Reverse is provided by R4RS.
+;;@args lst
+(define reverse! nreverse)
+
+;;@body
+(define (append-reverse rev-head tail)
+ (let lp ((rev-head rev-head) (tail tail))
+ (if (null-list? rev-head) tail
+ (lp (cdr rev-head) (cons (car rev-head) tail)))))
+(define (append-reverse! rev-head tail)
+ (let lp ((rev-head rev-head) (tail tail))
+ (if (null-list? rev-head) tail
+ (let ((next-rev (cdr rev-head)))
+ (set-cdr! rev-head tail)
+ (lp next-rev rev-head)))))
+
+;;@body
+(define (zip list1 . list2) (apply map list list1 list2))
+
+;;@body
+(define (unzip1 lst) (map car lst))
+(define (unzip2 lst) (values (map car lst) (map cadr lst)))
+(define (unzip3 lst) (values (map car lst) (map cadr lst) (map caddr lst)))
+(define (unzip4 lst) (values (map car lst) (map cadr lst) (map caddr lst)
+ (map cadddr lst)))
+(define (unzip5 lst) (values (map car lst) (map cadr lst) (map caddr lst)
+ (map cadddr lst) (map fifth lst)))
+
+;;@body
+(define (count pred list1 . list2)
+ (cond ((null? list2)
+ (let mapf ((l list1) (count 0))
+ (if (null? l)
+ count (mapf (cdr l)
+ (+ count (if (pred (car l)) 1 0))))))
+ (else (let mapf ((l list1) (rest list2) (count 0))
+ (if (null? l)
+ count
+ (mapf (cdr l)
+ (map cdr rest)
+ (+ count (if (apply pred (car l) (map car rest))
+ 1 0))))))))
+
+;;@subheading Fold and Unfold
+
+;;@args kons knil clist1 clist2 ...
+(define (fold f z l1 . l)
+ (set! l (cons l1 l))
+ (if (any null? l)
+ z
+ (apply fold (cons* f (apply f (append! (map car l) (list z)))
+ (map cdr l)))))
+;;@args kons knil clist1 clist2 ...
+(define (fold-right f z l1 . l)
+ (set! l (cons l1 l))
+ (if (any null? l)
+ z
+ (apply f (append! (map car l)
+ (list (apply fold-right (cons* f z (map cdr l))))))))
+;;@args kons knil clist1 clist2 ...
+(define (pair-fold f z l) ;XXX should be multi-arg
+ (if (null? l)
+ z
+ (let ((tail (cdr l)))
+ (pair-fold f (f l z) tail))))
+;;@args kons knil clist1 clist2 ...
+(define (pair-fold-right f z l) ;XXX should be multi-arg
+ (if (null? l)
+ z
+ (f l (pair-fold-right f z (cdr l)))))
+
+;;@body
+(define (reduce f ridentity list)
+ (if (null? list) ridentity (fold f (car list) (cdr list))))
+(define (reduce-right f ridentity list)
+ (if (null? list)
+ ridentity
+ (let red ((l (cdr list)) (ridentity (car list)))
+ (if (null? list)
+ ridentity
+ (f ridentity (red (cdr list) (car list)))))))
+
+;;; We stop when CLIST1 runs out, not when any list runs out.
+;;@args f clist1 clist2 ...
+(define (map! f clist1 . lists)
+ (if (pair? lists)
+ (let lp ((clist1 clist1) (lists lists))
+ (if (not (null-list? clist1))
+ (call-with-values ; expanded a receive call
+ (lambda () (%cars+cdrs/no-test lists))
+ (lambda (heads tails)
+ (set-car! clist1 (apply f (car clist1) heads))
+ (lp (cdr clist1) tails)))))
+ ;; Fast path.
+ (pair-for-each (lambda (pair) (set-car! pair (f (car pair)))) clist1))
+ clist1)
+;;@args f clist1 clist2 ...
+(define (pair-for-each proc clist1 . lists)
+ (if (pair? lists)
+ (let lp ((lists (cons clist1 lists)))
+ (let ((tails (%cdrs lists)))
+ (if (pair? tails)
+ (begin (apply proc lists)
+ (lp tails)))))
+ ;; Fast path.
+ (let lp ((lis clist1))
+ (if (not (null-list? lis))
+ (let ((tail (cdr lis))) ; Grab the cdr now,
+ (proc lis) ; in case PROC SET-CDR!s LIS.
+ (lp tail))))))
+
+(define (filter-map f l1 . l)
+ (let loop ((l (cons l1 l)) (r '()))
+ (if (any null? l)
+ (reverse! r)
+ (let ((x (apply f (map car l))))
+ (loop (map! cdr l) (if x (cons x r) r))))))
+
+
+;;@subheading Filtering and Partitioning
+
+;;@args pred list
+(define (filter pred lis) ; Sleazing with EQ? makes this one faster.
+ (let recur ((lis lis))
+ (if (null-list? lis) lis ; Use NOT-PAIR? to handle dotted lists.
+ (let ((head (car lis))
+ (tail (cdr lis)))
+ (if (pred head)
+ (let ((new-tail (recur tail))) ; Replicate the RECUR call so
+ (if (eq? tail new-tail) lis
+ (cons head new-tail)))
+ (recur tail)))))) ; this one can be a tail call.
+;;@args pred list
+(define (filter! p? l)
+ (call-with-values (lambda () (partition! p? l))
+ (lambda (x y) x)))
+
+;;@args pred list
+(define (partition pred lis)
+ (let recur ((lis lis))
+ (if (null-list? lis) (values lis lis) ; Use NOT-PAIR? to handle dotted lists.
+ (let ((elt (car lis))
+ (tail (cdr lis)))
+ (call-with-values ; expanded a receive call
+ (lambda () (recur tail))
+ (lambda (in out)
+ (if (pred elt)
+ (values (if (pair? out) (cons elt in) lis) out)
+ (values in (if (pair? in) (cons elt out) lis)))))))))
+
+;;@args pred list
+(define remove
+ (let ((comlist:remove remove))
+ (lambda (pred l)
+ (if (procedure? pred)
+ (filter (lambda (x) (not (pred x))) l)
+ (comlist:remove pred l))))) ; 'remove' has incompatible semantics in comlist of SLIB!
+
+;;@args pred list
+(define (partition! p? l)
+ (if (null? l)
+ (values l l)
+ (let ((p-ptr (cons '*unused* l)) (not-ptr (cons '*unused* l)))
+ (let loop ((l l) (p-prev p-ptr) (not-prev not-ptr))
+ (cond ((null? l) (values (cdr p-ptr) (cdr not-ptr)))
+ ((p? (car l)) (begin (set-cdr! not-prev (cdr l))
+ (loop (cdr l) l not-prev)))
+ (else (begin (set-cdr! p-prev (cdr l))
+ (loop (cdr l) p-prev l))))))))
+
+;;@args pred list
+(define (remove! pred l) (filter! (lambda (x) (not (pred x))) l))
+
+
+;;@subheading Searching
+
+;;@args pred clist
+(define find find-if)
+;;@args pred clist
+(define find-tail member-if)
+
+;;@args pred list
+(define (span pred lis)
+ (let recur ((lis lis))
+ (if (null-list? lis) (values '() '())
+ (let ((x (car lis)))
+ (if (pred x)
+ (call-with-values ; eliminated a receive call
+ (lambda () (recur (cdr lis)))
+ (lambda (prefix suffix)
+ (values (cons x prefix) suffix)))
+ (values '() lis))))))
+
+;;@args pred list
+(define (span! p? lst)
+ (let loop ((l lst) (prev (cons '*unused* lst)))
+ (cond ((null? l) (values lst '()))
+ ((p? (car l)) (loop (cdr l) l))
+ (else (begin (set-cdr! prev '()) (values lst l))))))
+
+;;@args pred list
+(define (break p? l) (span (lambda (x) (not (p? x))) l))
+;;@args pred list
+(define (break! p? l) (span! (lambda (x) (not (p? x))) l))
+
+;;@args pred clist1 clist2 ...
+(define (any pred lis1 . lists)
+ (if (pair? lists)
+ ;; N-ary case
+ (call-with-values ; expanded a receive call
+ (lambda () (%cars+cdrs (cons lis1 lists)))
+ (lambda (heads tails)
+ (and (pair? heads)
+ (let lp ((heads heads) (tails tails))
+ (call-with-values ; expanded a receive call
+ (lambda () (%cars+cdrs tails))
+ (lambda (next-heads next-tails)
+ (if (pair? next-heads)
+ (or (apply pred heads) (lp next-heads next-tails))
+ (apply pred heads)))))))) ; Last PRED app is tail call.
+ ;; Fast path
+ (and (not (null-list? lis1))
+ (let lp ((head (car lis1)) (tail (cdr lis1)))
+ (if (null-list? tail)
+ (pred head) ; Last PRED app is tail call.
+ (or (pred head) (lp (car tail) (cdr tail))))))))
+;;@args pred clist1 clist2 ...
+(define (list-index pred lis1 . lists)
+ (if (pair? lists)
+ ;; N-ary case
+ (let lp ((lists (cons lis1 lists)) (n 0))
+ (call-with-values ; expanded a receive call
+ (lambda () (%cars+cdrs lists))
+ (lambda (heads tails)
+ (and (pair? heads)
+ (if (apply pred heads) n
+ (lp tails (+ n 1)))))))
+ ;; Fast path
+ (let lp ((lis lis1) (n 0))
+ (and (not (null-list? lis))
+ (if (pred (car lis)) n (lp (cdr lis) (+ n 1)))))))
+
+;;@args obj list =
+;;@args obj list
+(define member
+ (let ((old-member member))
+ (lambda (obj list . pred)
+ (if (null? pred)
+ (old-member obj list)
+ (let ((pred (car pred)))
+ (find-tail (lambda (ob) (pred ob obj)) list))))))
+
+;;@subheading Deleting
+
+;;@args x list =
+;;@args x list
+(define (delete-duplicates l =?)
+ (let loop ((l l) (r '()))
+ (if (null? l)
+ (reverse! r)
+ (loop (cdr l)
+ (if (member (car l) r =?) r (cons (car l) r))))))
+;;@args x list =
+;;@args x list
+(define delete-duplicates! delete-duplicates)
+
+;;@subheading Association lists
+
+;;@args obj alist pred
+;;@args obj alist
+(define assoc
+ (let ((old-assoc assoc))
+ (lambda (obj alist . pred)
+ (if (null? pred)
+ (old-assoc obj alist)
+ (let ((pred (car pred)))
+ (find (lambda (pair) (pred obj (car pair))) alist))))))
+
+;; XXX maybe define the following in alist and require that module here?
+
+;;@args key datum alist
+(define (alist-cons k d l) (cons (cons k d) l))
+
+;;@args alist
+(define (alist-copy l)
+ (map (lambda (x) (cons (car x) (cdr x))) l))
+
+;;@args key alist =
+;;@args key alist
+(define (alist-delete k l . opt)
+ (let ((key=? (if (pair? opt) (car opt) equal?)))
+ (remove (lambda (x) (key=? (car x) k)) l)))
+;;@args key alist =
+;;@args key alist
+(define (alist-delete! k l . opt)
+ (let ((key=? (if (pair? opt) (car opt) equal?)))
+ (remove! (lambda (x) (key=? (car x) k)) l)))
+
+;;@subheading Set operations
+
+;;@args = list1 @dots{}
+;;Determine if a transitive subset relation exists between the lists @2
+;;@dots{}, using @1 to determine equality of list members.
+(define (lset<= =? . l)
+ (or (null? l)
+ (letrec ((subset? (lambda (l1 l2)
+ (or (eq? l1 l2)
+ (every (lambda (x) (member x l2)) l1)))))
+ (let loop ((l1 (car l)) (l (cdr l)))
+ (or (null? l)
+ (let ((l2 (car l)))
+ (and (subset? l1 l2)
+ (loop l2 (cdr l)))))))))
+
+;;@args = list1 list2 @dots{}
+(define (lset= =? . l)
+ (or (null? l)
+ (let loop ((l1 (car l)) (l (cdr l)))
+ (or (null? l)
+ (let ((l2 (car l)))
+ (and (lset<= =? l1 l2)
+ (lset<= =? l2 l1)
+ (loop (if (< (length l1) (length l2)) l1 l2)
+ (cdr l))))))))
+
+;;@args list elt1 @dots{}
+(define (lset-adjoin =? l1 . l2)
+ (let ((adjoin (lambda (x l)
+ (if (member x l =?) l (cons x l)))))
+ (fold adjoin l1 l2)))
+
+;;@args = list1 @dots{}
+(define (lset-union =? . l)
+ (let ((union (lambda (l1 l2)
+ (if (or (null? l2) (eq? l1 l2))
+ l1
+ (apply lset-adjoin (cons* =? l2 l1))))))
+ (fold union '() l)))
+
+;;@args = list1 list2 @dots{}
+(define (lset-intersection =? l1 . l)
+ (let loop ((l l) (r l1))
+ (cond ((null? l) r)
+ ((null? (car l)) '())
+ (else (loop (cdr l)
+ (filter (lambda (x) (member x (car l) =?)) r))))))
+
+;;@args = list1 list2 ...
+(define (lset-difference =? l1 . l)
+ (call-with-current-continuation
+ (lambda (return)
+ (let ((diff (lambda (l1 l2)
+ (cond ((null? l2) (return '()))
+ ((null? l1) l2)
+ (else (remove (lambda (x) (member x l1 =?))
+ l2))))))
+ (fold diff l1 l)))))
+
+;; Alternatively definition of lset-difference, for large numbers of sets.
+;(define (lset-difference =? l1 . l)
+; (set! l (cdr (delete-duplicates! (cons l1 l) eq?)))
+; (case (length l)
+; ((0) l1)
+; ((1) (remove (lambda (x) (member x l1 =?)) (car l)))
+; (else (apply (lset-difference! (cons* =? (list-copy l1) l))))))
+
+;;@args = list1 ...
+(define (lset-xor =? . l)
+ (let ((xor (lambda (l1 l2) (lset-union =? (lset-difference =? l1 l2)
+ (lset-difference =? l2 l1)))))
+ (fold xor '() l)))
+
+;;@args = list1 list2 ...
+(define (lset-diff+intersection =? l1 . l)
+ (let ((u (apply lset-union (cons =? l))))
+ (values (lset-difference =? l1 u)
+ (lset-intersection =? l1 u))))
+
+;;@noindent
+;;These are linear-update variants. They are allowed, but not
+;;required, to use the cons cells in their first list parameter to
+;;construct their answer. @code{lset-union!} is permitted to recycle
+;;cons cells from any of its list arguments.
+
+;;@args = list1 list2 ...
+(define lset-intersection! lset-intersection)
+;;@args = list1 list2 ...
+(define (lset-difference! =? l1 . l)
+ (let loop ((l l) (d l1))
+ (if (or (null? l) (null? d))
+ d
+ (loop (cdr l)
+ (let ((l1 (car l)))
+ (if (null? l1) d (remove! (lambda (x) (member x l1 =?)) d)))))))
+
+;;@args = list1 ...
+(define (lset-union! =? . l)
+ (let loop ((l l) (u '()))
+ (if (null? l)
+ u
+ (loop (cdr l)
+ (cond ((null? (car l)) u)
+ ((eq? (car l) u) u)
+ ((null? u) (car l))
+ (else (append-reverse! (lset-difference! =? (car l) u)
+ u)))))))
+;;@args = list1 ...
+(define lset-xor! lset-xor)
+
+;;@args = list1 list2 ...
+(define lset-diff+intersection! lset-diff+intersection)
+
+
+;;;; helper functions from the reference implementation:
+
+;;; LISTS is a (not very long) non-empty list of lists.
+;;; Return two lists: the cars & the cdrs of the lists.
+;;; However, if any of the lists is empty, just abort and return [() ()].
+
+(define (%cars+cdrs lists)
+ (call-with-current-continuation
+ (lambda (abort)
+ (let recur ((lists lists))
+ (if (pair? lists)
+ (call-with-values ; expanded a receive call
+ (lambda () (car+cdr lists))
+ (lambda (list other-lists)
+ (if (null-list? list) (abort '() '()) ; LIST is empty -- bail out
+ (call-with-values ; expanded a receive call
+ (lambda () (car+cdr list))
+ (lambda (a d)
+ (call-with-values ; expanded a receive call
+ (lambda () (recur other-lists))
+ (lambda (cars cdrs)
+ (values (cons a cars) (cons d cdrs)))))))))
+ (values '() '()))))))
+
+;;; Like %CARS+CDRS, but blow up if any list is empty.
+(define (%cars+cdrs/no-test lists)
+ (let recur ((lists lists))
+ (if (pair? lists)
+ (call-with-values ; expanded a receive call
+ (lambda () (car+cdr lists))
+ (lambda (list other-lists)
+ (call-with-values ; expanded a receive call
+ (lambda () (car+cdr list))
+ (lambda (a d)
+ (call-with-values ; expanded a receive call
+ (lambda () (recur other-lists))
+ (lambda (cars cdrs)
+ (values (cons a cars) (cons d cdrs))))))))
+ (values '() '()))))
+
+(define (%cdrs lists)
+ (call-with-current-continuation
+ (lambda (abort)
+ (let recur ((lists lists))
+ (if (pair? lists)
+ (let ((lis (car lists)))
+ (if (null-list? lis) (abort '())
+ (cons (cdr lis) (recur (cdr lists)))))
+ '())))))
Modified: branches/r5rs/scm/util.scm
===================================================================
--- branches/r5rs/scm/util.scm 2005-08-20 16:56:51 UTC (rev 1243)
+++ branches/r5rs/scm/util.scm 2005-08-20 17:41:05 UTC (rev 1244)
@@ -28,6 +28,8 @@
;;; OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
;;; SUCH DAMAGE.
;;;;
+(require "slib-mulapply.scm")
+(require "slib-srfi-1.scm")
;; Current uim implementation treats char as integer
@@ -38,8 +40,7 @@
;; TODO: write test
(define string-escape
(lambda (s)
- (let ((buf (string-append "\"\"" s s)))
- (print-to-string s buf))))
+ (string-append "\"\"" s s)))
;; TODO: write test
(define string->char
@@ -265,6 +266,18 @@
(- c 48)
c)))
+(define char-downcase
+ (lambda (c)
+ (if (char-upper-case? c)
+ (+ c 32)
+ c)))
+
+(define char-upcase
+ (lambda (c)
+ (if (char-lower-case? c)
+ (- c 32)
+ c)))
+
;;
;; backward compatibility: should be obsoleted
;;
@@ -290,224 +303,29 @@
;;
;; SRFI procedures (don't expect 100% compatibility)
;;
-
-;;(define take)
-;;(define drop)
-;;(define take-right)
-;;(define drop-right)
-;;(define split-at)
-
-(define list-tabulate
- (lambda (n init-proc)
- (if (< n 0)
- (error "bad length for list-tabulate")
- (let self ((i (- n 1))
- (res ()))
- (if (< i 0)
- res
- (self (- i 1)
- (cons (init-proc i) res)))))))
-
-;; This procedure does not conform to the SRFI-1 specification. The
-;; argument 'fill' is required.
-(define make-list
- (lambda (n fill)
- (list-tabulate n
- (lambda (i)
- fill))))
-
-;; This procedure does not conform to the SRFI-1 specification. The
-;; optional argument 'step' is not supported.
-(define iota
- (lambda args
- (let ((count (car args))
- (start (if (not (null? (cdr args)))
- (cadr args)
- 0)))
- (list-tabulate (- count start)
- (lambda (i)
- (+ start i))))))
-
(define last-pair
(lambda (lst)
(if (pair? (cdr lst))
(last-pair (cdr lst))
lst)))
-;; TODO: write test
-(define last
- (lambda (lst)
- (car (last-pair lst))))
-
-;; only accepts 2 lists
-;; TODO: write test
-(define append! nconc)
-
-(define concatenate
- (lambda (lists)
- (apply append lists)))
-
-(define concatenate!
- (lambda (lists)
- ;;(fold-right append! () lists)
- (fold append! () (reverse lists))))
-
-(define zip
- (lambda lists
- (let ((runs-out? (apply proc-or (map null? lists))))
- (if runs-out?
- ()
- (let* ((elms (map car lists))
- (rests (map cdr lists)))
- (cons elms (apply zip rests)))))))
-
(define append-map
(lambda args
(concatenate! (apply map args))))
-(define append-reverse
- (lambda (rev-head tail)
- (fold cons tail rev-head)))
-
-(define find
- (lambda (f lst)
- (cond
- ((null? lst)
- #f)
- ((f (car lst))
- (car lst))
- (else
- (find f (cdr lst))))))
-
-;; TODO: write test
-;; replaced with faster C version
-;;(define find-tail
-;; (lambda (pred lst)
-;; (cond
-;; ((null? lst)
-;; #f)
-;; ((pred (car lst))
-;; lst)
-;; (else
-;; (find-tail pred (cdr lst))))))
-
-(define any
- (lambda args
- (let* ((pred (car args))
- (lists (cdr args)))
- (iterate-lists (lambda (state elms)
- (if (null? elms)
- '(#t . #f)
- (let ((res (apply pred elms)))
- (cons res res))))
- #f lists))))
-
-(define every
- (lambda args
- (let* ((pred (car args))
- (lists (cdr args)))
- (iterate-lists (lambda (state elms)
- (if (null? elms)
- '(#t . #t)
- (let ((res (apply pred elms)))
- (cons (not res) res))))
- #f lists))))
-
-(define fold
- (lambda args
- (let* ((kons (car args))
- (knil (cadr args))
- (lists (cddr args)))
- (iterate-lists (lambda (state elms)
- (if (null? elms)
- (cons #t state)
- (cons #f (apply kons (append elms (list state))))))
- knil lists))))
-
-(define unfold
- (lambda args
- (let ((term? (list-ref args 0))
- (kar (list-ref args 1))
- (kdr (list-ref args 2))
- (seed (list-ref args 3))
- (tail-gen (if (= (length args)
- 5)
- (list-ref args 4)
- (lambda (x) ()))))
- (if (term? seed)
- (tail-gen seed)
- (cons (kar seed)
- (unfold term? kar kdr (kdr seed) tail-gen))))))
-
-(define filter
- (lambda args
- (let ((pred (car args))
- (lst (cadr args)))
- (iterate-lists (lambda (state elms)
- (if (null? elms)
- (cons #t (reverse state))
- (let ((elm (car elms)))
- (cons #f (if (pred elm)
- (cons elm state)
- state)))))
- () (list lst)))))
-
-(define filter-map
- (lambda args
- (let ((f (car args))
- (lists (cdr args)))
- (iterate-lists (lambda (state elms)
- (if (null? elms)
- (cons #t (reverse state))
- (let ((mapped (apply f elms)))
- (cons #f (if mapped
- (cons mapped state)
- state)))))
- () lists))))
-
-(define remove
- (lambda (pred lst)
- (filter (lambda (elm)
- (not (pred elm)))
- lst)))
-
-;; TODO: write test
-(define delete
- (lambda args
- (let ((x (car args))
- (lst (cadr args))
- (val=? (if (null? (cddr args))
- equal?
- (car (cddr args)))))
- (filter (lambda (elm)
- (not (val=? elm x)))
- lst))))
-
-(define alist-delete
- (lambda args
- (let ((key (car args))
- (alist (cadr args))
- (key=? (if (null? (cddr args))
- equal?
- (car (cddr args)))))
- (remove (lambda (elm)
- (key=? (car elm)
- key))
- alist))))
-
;; SRFI-60 procedures
;; Siod's bit operation procedures take only two arguments
;; TODO: write tests
-;(define bitwise-not bit-not)
-;(define bitwise-and
-; (lambda xs
-; (fold bit-and (bitwise-not 0) xs)))
-;(define bitwise-or
-; (lambda xs
-; (fold bit-or 0 xs)))
-;(define bitwise-xor
-; (lambda xs
-; (fold bit-xor 0 xs)))
+(define bitwise-not bit-not)
+(define bitwise-and
+ (lambda xs
+ (fold bit-and (bitwise-not 0) xs)))
+(define bitwise-or
+ (lambda xs
+ (fold bit-or 0 xs)))
+(define bitwise-xor
+ (lambda xs
+ (fold bit-xor 0 xs)))
;;
;; uim-specific utilities
More information about the uim-commit
mailing list