Artifact
12ac5a7885fe4171901718edfc62354527d4a41a:
- File
data-structures.scm
— part of check-in
[edbaf21f17]
at
2016-12-09 20:15:57
on branch trunk
— added data-structures
(user:
aldo
size: 23634)
;;; data-structures.scm - Optional data structures extensions
;
; Copyright (c) 2008-2014, The Chicken Team
; All rights reserved.
;
; Redistribution and use in source and binary forms, with or without
; modification, are permitted provided that the following conditions
; are met:
;
; Redistributions of source code must retain the above copyright notice, this list of conditions and the following
; disclaimer.
; Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following
; disclaimer in the documentation and/or other materials provided with the distribution.
; Neither the name of the author nor the names of its contributors may be used to endorse or promote
; products derived from this software without specific prior written permission.
;
; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS
; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
; AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
; OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
; POSSIBILITY OF SUCH DAMAGE.
;;; Adapted to Chez Scheme
;;; Copyright (C) 2016 Aldo Nicolas Bruno
(define-syntax d (syntax-rules () ((_ . _) (void))))
(define-syntax define-alias
(syntax-rules ()
((_ new old)
(define-syntax new
(syntax-rules ___ ()
((_ args ___)
(old args ___)))))))
;;; Combinators:
(define (identity x) x)
(define (conjoin . preds)
(lambda (x)
(let loop ([preds preds])
(or (null? preds)
(and ((car preds) x)
(loop (cdr preds)) ) ) ) ) )
(define (disjoin . preds)
(lambda (x)
(let loop ([preds preds])
(and (not (null? preds))
(or ((car preds) x)
(loop (cdr preds)) ) ) ) ) )
(define (constantly . xs)
(if (= 1 (length xs))
(let ([x (car xs)])
(lambda _ x) )
(lambda _ (apply values xs)) ) )
(define (flip proc) (lambda (x y) (proc y x)))
(define complement
(lambda (p)
(lambda args (not (apply p args))) ) )
(define (compose . fns)
(define (rec f0 . fns)
(if (null? fns)
f0
(lambda args
(call-with-values
(lambda () (apply (apply rec fns) args))
f0) ) ) )
(if (null? fns)
values
(apply rec fns) ) )
(define (o . fns)
(if (null? fns)
identity
(let loop ((fns fns))
(let ((h (car fns))
(t (cdr fns)) )
(if (null? t)
h
(lambda (x) (h ((loop t) x))))))))
(define (list-of? pred)
(lambda (lst)
(let loop ([lst lst])
(cond [(null? lst) #t]
[(not (pair? lst)) #f]
[(pred (car lst)) (loop (cdr lst))]
[else #f] ) ) ) )
(define (each . procs)
(cond ((null? procs) (lambda _ (void)))
((null? (cdr procs)) (car procs))
(else
(lambda args
(let loop ((procs procs))
(let ((h (car procs))
(t (cdr procs)) )
(if (null? t)
(apply h args)
(begin
(apply h args)
(loop t) ) ) ) ) ) ) ) )
(define (any? x) #t)
;;; List operators:
(define (tail? x y)
(assert (and 'tail? (list? y)))
(or (null? x)
(let loop ((y y))
(cond ((null? y) #f)
((eq? x y) #t)
(else (loop (cdr y))) ) ) ) )
(define intersperse
(lambda (lst x)
(let loop ((ns lst))
(if (null? ns)
ns
(let ((tail (cdr ns)))
(if (null? tail)
ns
(cons (car ns) (cons x (loop tail))) ) ) ) ) ) )
(define (butlast lst)
(assert (and 'butlast (pair? lst )))
(let loop ((lst lst))
(let ((next (cdr lst )))
(if (pair? next)
(cons (car lst) (loop next))
'() ) ) ) )
(define (flatten . lists0)
(let loop ([lists lists0] [rest '()])
(cond [(null? lists) rest]
[else
(let ([head (car lists)]
[tail (cdr lists)] )
(if (list? head)
(loop head (loop tail rest))
(cons head (loop tail rest)) ) ) ] ) ) )
(define chop
(lambda (lst n)
(assert (and 'chop (exact? n)))
(when (fx<= n 0) (errorf 'chop "invalid numeric argument ~d" n))
(let ([len (length lst)])
(let loop ([lst lst] [i len])
(cond [(null? lst) '()]
[(fx< i n) (list lst)]
[else
(do ([hd '() (cons (car tl) hd)]
[tl lst (cdr tl)]
[c n (fx- c 1)] )
((fx= c 0)
(cons (reverse hd) (loop tl (fx- i n))) ) ) ] ) ) ) ) )
(define (join lsts . lst)
(let ([lst (if (pair? lst) (car lst) '())])
(assert (and 'join (list? lst)))
(let loop ([lsts lsts])
(cond [(null? lsts) '()]
[(not (pair? lsts))
(errorf 'join "not a proper list ~d" lsts) ]
[else
(let ([l (car lsts)]
[r (cdr lsts)] )
(if (null? r)
l
(append l lst (loop r)) ) ) ] ) ) ) )
(define compress
(lambda (blst lst)
(let ([msg "bad argument type - not a proper list"])
(assert (and 'compress (list? lst)))
(let loop ([blst blst] [lst lst])
(cond [(null? blst) '()]
[(not (pair? blst))
(error 'compress msg 'type-error blst) ]
[(not (pair? lst))
(error 'compress msg 'type-error lst) ]
[(car blst)
(cons (car lst) (loop (cdr blst) (cdr lst)))]
[else (loop (cdr blst) (cdr lst))] ) ) ) ) )
;;; Alists:
(define alist-update!
(case-lambda
[(x y lst)
(alist-update! x y lst eqv?)]
[(x y lst cmp)
(let* ([aq (cond [(eq? eq? cmp) assq]
[(eq? eqv? cmp) assv]
[(eq? equal? cmp) assoc]
[else
(lambda (x lst)
(let loop ([lst lst])
(and (pair? lst)
(let ([a (car lst)])
(if (and (pair? a) (cmp (car a) x))
a
(loop (cdr lst)) ) ) ) ) ) ] ) ]
[item (aq x lst)] )
(if item
(begin
(set-cdr! item y)
lst)
(cons (cons x y) lst) ) ) ]))
(define alist-update
(case-lambda
[(k v lst)
(alist-update k v lst eqv?)]
[(k v lst cmp)
(let loop ((lst lst))
(cond ((null? lst)
(list (cons k v)))
((not (pair? lst))
(error 'alist-update "bad argument type" lst))
(else
(let ((a (car lst)))
(cond ((not (pair? a))
(error 'alist-update "bad argument type" a))
((cmp (car a) k)
(cons (cons k v) (cdr lst)))
(else
(cons (cons (car a) (cdr a))
(loop (cdr lst)))))))))]))
(define alist-ref
(case-lambda
[(x lst)
(alist-ref x lst eqv?)]
[(x lst cmp)
(alist-ref x lst cmp #f)]
[(x lst cmp default)
(let* ([aq (cond [(eq? eq? cmp) assq]
[(eq? eqv? cmp) assv]
[(eq? equal? cmp) assoc]
[else
(lambda (x lst)
(let loop ([lst lst])
(and (pair? lst)
(let ([a (car lst )])
(if (and (pair? a) (cmp (car a ) x))
a
(loop (cdr lst )) ) ) ) ) ) ] ) ]
[item (aq x lst)] )
(if item
(cdr item )
default) ) ]))
(define (rassoc x lst . tst)
(assert (and 'rassoc (list? lst)))
(let ([tst (if (pair? tst) (car tst) eqv?)])
(let loop ([l lst])
(and (pair? l)
(let ([a (car l )])
(assert (and 'rassoc (pair? a)))
(if (tst x (cdr a ))
a
(loop (cdr l )) ) ) ) ) ) )
; (reverse-string-append l) = (apply string-append (reverse l))
(define (reverse-string-append l)
(define (rev-string-append l i)
(if (pair? l)
(let* ((str (car l))
(len (string-length str))
(result (rev-string-append (cdr l) (fx+ i len))))
(let loop ((j 0) (k (fx- (fx- (string-length result) i) len)))
(if (fx< j len)
(begin
(string-set! result k (string-ref str j))
(loop (fx+ j 1) (fx+ k 1)))
result)))
(make-string i)))
(rev-string-append l 0))
;;; Anything->string conversion:
(define ->string
(lambda (x)
(cond [(string? x) x]
[(symbol? x) (symbol->string x)]
[(char? x) (string x)]
[(number? x) (number->string x)]
[else
(let ([o (open-output-string)])
(display x o)
(get-output-string o) ) ] ) ) )
(define conc
(lambda args
(apply string-append (map ->string args)) ) )
;;; Concatenate list of strings:
(define (string-intersperse strs ds)
(assert (and 'string-intersperse (list? strs)))
(assert (and 'string-intersperse (string? ds)))
(let ((dslen (string-length ds)))
(let loop1 ((ss strs) (n 0))
(if (null? ss) ""
(string-append (car ss)
(if (null? (cdr ss)) ""
(string-append ds
(loop1 (cdr ss) (+ n 1) ))))))))
(define (string-translate* str smap)
(import (only (srfi s13 strings) string=))
(assert (and 'string-translate* (list? smap)))
(assert (and 'string-translate* (string? str)))
(let ([len (string-length str)])
(define (collect i from total fs)
(if (fx>= i len)
(apply string-append
(reverse
(if (fx> i from)
(cons (substring str from i) fs)
fs) ) )
(let loop ([smap smap])
(if (null? smap)
(collect (fx+ i 1) from (fx+ total 1) fs)
(let* ([p (car smap)]
[sm (car p)]
[smlen (string-length sm)]
[st (cdr p)] )
(if (string= str sm i (min (+ i smlen) len) 0 smlen)
(let ([i2 (fx+ i smlen)])
(when (fx> i from)
(set! fs (cons (substring str from i) fs)) )
(collect
i2 i2
(fx+ total (string-length st))
(cons st fs) ) )
(loop (cdr smap)) ) ) ) ) ) )
(collect 0 0 0 '()) ) )
;;; Chop string into substrings:
(define (string-chop str len)
(assert (and 'string-chop (exact? len)))
(assert (and 'string-chop (string? str)))
(let ([total (string-length str)])
(let loop ([total total] [pos 0])
(cond [(fx<= total 0) '()]
[(fx<= total len) (list (substring str pos (fx+ pos total)))]
[else (cons (substring str pos (fx+ pos len)) (loop (fx- total len) (fx+ pos len)))] ) ) ) )
;;; Defines: sorted?, merge, merge!, sort, sort!
;;; Author : Richard A. O'Keefe (based on Prolog code by D.H.D.Warren)
;;;
;;; This code is in the public domain.
;;; Updated: 11 June 1991
;;; Modified for scheme library: Aubrey Jaffer 19 Sept. 1991
;;; Updated: 19 June 1995
;;; (sorted? sequence less?)
;;; is true when sequence is a list (x0 x1 ... xm) or a vector #(x0 ... xm)
;;; such that for all 1 <= i <= m,
;;; (not (less? (list-ref list i) (list-ref list (- i 1)))).
; Modified by flw for use with CHICKEN:
;
(define (sorted? seq less?)
(cond
((null? seq)
#t)
((vector? seq)
(let ((n (vector-length seq)))
(if (<= n 1)
#t
(do ((i 1 (+ i 1)))
((or (= i n)
(less? (vector-ref seq i)
(vector-ref seq (- i 1))))
(= i n)) )) ))
(else
(let loop ((last (car seq)) (next (cdr seq)))
(or (null? next)
(and (not (less? (car next) last))
(loop (car next) (cdr next)) )) )) ))
;;; THESE ARE ALREADY IN CHEZ SCHEME
;; ;;; (merge a b less?)
;; ;;; takes two lists a and b such that (sorted? a less?) and (sorted? b less?)
;; ;;; and returns a new list in which the elements of a and b have been stably
;; ;;; interleaved so that (sorted? (merge a b less?) less?).
;; ;;; Note: this does _not_ accept vectors. See below.
;; (define (merge a b less?)
;; (cond
;; ((null? a) b)
;; ((null? b) a)
;; (else (let loop ((x (car a)) (a (cdr a)) (y (car b)) (b (cdr b)))
;; ;; The loop handles the merging of non-empty lists. It has
;; ;; been written this way to save testing and car/cdring.
;; (if (less? y x)
;; (if (null? b)
;; (cons y (cons x a))
;; (cons y (loop x a (car b) (cdr b)) ))
;; ;; x <= y
;; (if (null? a)
;; (cons x (cons y b))
;; (cons x (loop (car a) (cdr a) y b)) )) )) ))
;; ;;; (merge! a b less?)
;; ;;; takes two sorted lists a and b and smashes their cdr fields to form a
;; ;;; single sorted list including the elements of both.
;; ;;; Note: this does _not_ accept vectors.
;; (define (merge! a b less?)
;; (define (loop r a b)
;; (if (less? (car b) (car a))
;; (begin
;; (set-cdr! r b)
;; (if (null? (cdr b))
;; (set-cdr! b a)
;; (loop b a (cdr b)) ))
;; ;; (car a) <= (car b)
;; (begin
;; (set-cdr! r a)
;; (if (null? (cdr a))
;; (set-cdr! a b)
;; (loop a (cdr a) b)) )) )
;; (cond
;; ((null? a) b)
;; ((null? b) a)
;; ((less? (car b) (car a))
;; (if (null? (cdr b))
;; (set-cdr! b a)
;; (loop b a (cdr b)))
;; b)
;; (else ; (car a) <= (car b)
;; (if (null? (cdr a))
;; (set-cdr! a b)
;; (loop a (cdr a) b))
;; a)))
;; ;;; (sort! sequence less?)
;; ;;; sorts the list or vector sequence destructively. It uses a version
;; ;;; of merge-sort invented, to the best of my knowledge, by David H. D.
;; ;;; Warren, and first used in the DEC-10 Prolog system. R. A. O'Keefe
;; ;;; adapted it to work destructively in Scheme.
;; (define (sort! seq less?)
;; (define (step n)
;; (cond
;; ((> n 2)
;; (let* ((j (quotient n 2))
;; (a (step j))
;; (k (- n j))
;; (b (step k)))
;; (merge! a b less?)))
;; ((= n 2)
;; (let ((x (car seq))
;; (y (cadr seq))
;; (p seq))
;; (set! seq (cddr seq))
;; (if (less? y x) (begin
;; (set-car! p y)
;; (set-car! (cdr p) x)))
;; (set-cdr! (cdr p) '())
;; p))
;; ((= n 1)
;; (let ((p seq))
;; (set! seq (cdr seq))
;; (set-cdr! p '())
;; p))
;; (else
;; '()) ))
;; (if (vector? seq)
;; (let ((n (vector-length seq))
;; (vec seq))
;; (set! seq (vector->list seq))
;; (do ((p (step n) (cdr p))
;; (i 0 (+ i 1)))
;; ((null? p) vec)
;; (vector-set! vec i (car p)) ))
;; ;; otherwise, assume it is a list
;; (step (length seq)) ))
;; ;;; (sort sequence less?)
;; ;;; sorts a vector or list non-destructively. It does this by sorting a
;; ;;; copy of the sequence. My understanding is that the Standard says
;; ;;; that the result of append is always "newly allocated" except for
;; ;;; sharing structure with "the last argument", so (append x '()) ought
;; ;;; to be a standard way of copying a list x.
;; (define (sort seq less?)
;; (if (vector? seq)
;; (list->vector (sort! (vector->list seq) less?))
;; (sort! (append seq '()) less?)))
;; ;;; Topological sort with cycle detection:
;; ;;
;; ;; A functional implementation of the algorithm described in Cormen,
;; ;; et al. (2009), Introduction to Algorithms (3rd ed.), pp. 612-615.
;; (define (topological-sort dag pred)
;; (define (visit dag node edges path state)
;; (case (alist-ref node (car state) pred)
;; ((grey)
;; (errorf 'topological-sort "cycle detected"
;; ,(list (cons node (reverse path)))))
;; ((black)
;; state)
;; (else
;; (let walk ((edges (or edges (alist-ref node dag pred '())))
;; (state (cons (cons (cons node 'grey) (car state))
;; (cdr state))))
;; (if (null? edges)
;; (cons (alist-update! node 'black (car state) pred)
;; (cons node (cdr state)))
;; (let ((edge (car edges)))
;; (walk (cdr edges)
;; (visit dag
;; edge
;; #f
;; (cons edge path)
;; state))))))))
;; (let loop ((dag dag)
;; (state (cons (list) (list))))
;; (if (null? dag)
;; (cdr state)
;; (loop (cdr dag)
;; (visit dag
;; (caar dag)
;; (cdar dag)
;; '()
;; state)))))
;;; Binary search:
(define binary-search
(lambda (vec proc)
(if (pair? vec)
(set! vec (list->vector vec))
(assert (and 'binary-search (vector? vec))))
(let ([len (vector-length vec)])
(and (fx> len 0)
(let loop ([ps 0]
[pe len] )
(let ([p (fx+ ps (bitwise-arithmetic-shift-right (fx- pe ps) 1))])
(let* ([x (vector-ref vec p)]
[r (proc x)] )
(cond [(fx= r 0) p]
[(fx< r 0) (and (not (fx= pe p)) (loop ps p))]
[else (and (not (fx= ps p)) (loop p pe))] ) ) ) ) ) ) ) )
#!eof
;; TODO FIX THE STUFF BELOW
;;; Search one string inside another:
(let ()
(define (traverse which where start test loc)
(assert (string? which))
(assert (string? where))
(let ([wherelen (string-length where)]
[whichlen (string-length which)] )
(assert (exact? start ))
(let loop ([istart start] [iend whichlen])
(cond [(fx> iend wherelen) #f]
[(test istart whichlen) istart]
[else
(loop (fx+ istart 1)
(fx+ iend 1) ) ] ) ) ) )
(set! ##sys#substring-index
(lambda (which where start)
(traverse
which where start
(lambda (i l) (##core#inline "C_substring_compare" which where 0 i l))
'substring-index) ) )
(set! ##sys#substring-index-ci
(lambda (which where start)
(traverse
which where start
(lambda (i l) (##core#inline "C_substring_compare_case_insensitive" which where 0 i l))
'substring-index-ci) ) ) )
(define (substring-index which where #!optional (start 0))
(##sys#substring-index which where start) )
(define (substring-index-ci which where #!optional (start 0))
(##sys#substring-index-ci which where start) )
;;; 3-Way string comparison:
(define (string-compare3 s1 s2)
(##sys#check-string s1 'string-compare3)
(##sys#check-string s2 'string-compare3)
(let ((len1 (##sys#size s1))
(len2 (##sys#size s2)) )
(let* ((len-diff (fx- len1 len2))
(cmp (##core#inline "C_string_compare" s1 s2 (if (fx< len-diff 0) len1 len2))))
(if (fx= cmp 0)
len-diff
cmp))))
(define (string-compare3-ci s1 s2)
(##sys#check-string s1 'string-compare3-ci)
(##sys#check-string s2 'string-compare3-ci)
(let ((len1 (##sys#size s1))
(len2 (##sys#size s2)) )
(let* ((len-diff (fx- len1 len2))
(cmp (##core#inline "C_string_compare_case_insensitive" s1 s2 (if (fx< len-diff 0) len1 len2))))
(if (fx= cmp 0)
len-diff
cmp))))
;;; Substring comparison:
(define (##sys#substring=? s1 s2 start1 start2 n)
(##sys#check-string s1 'substring=?)
(##sys#check-string s2 'substring=?)
(let ((len (or n
(fxmin (fx- (##sys#size s1) start1)
(fx- (##sys#size s2) start2) ) ) ) )
(##sys#check-exact start1 'substring=?)
(##sys#check-exact start2 'substring=?)
(##core#inline "C_substring_compare" s1 s2 start1 start2 len) ) )
(define (substring=? s1 s2 #!optional (start1 0) (start2 0) len)
(##sys#substring=? s1 s2 start1 start2 len) )
(define (##sys#substring-ci=? s1 s2 start1 start2 n)
(##sys#check-string s1 'substring-ci=?)
(##sys#check-string s2 'substring-ci=?)
(let ((len (or n
(fxmin (fx- (##sys#size s1) start1)
(fx- (##sys#size s2) start2) ) ) ) )
(##sys#check-exact start1 'substring-ci=?)
(##sys#check-exact start2 'substring-ci=?)
(##core#inline "C_substring_compare_case_insensitive"
s1 s2 start1 start2 len) ) )
(define (substring-ci=? s1 s2 #!optional (start1 0) (start2 0) len)
(##sys#substring-ci=? s1 s2 start1 start2 len) )
;;; Split string into substrings:
(define string-split
(lambda (str . delstr-and-flag)
(##sys#check-string str 'string-split)
(let* ([del (if (null? delstr-and-flag) "\t\n " (car delstr-and-flag))]
[flag (if (fx= (length delstr-and-flag) 2) (cadr delstr-and-flag) #f)]
[strlen (##sys#size str)] )
(##sys#check-string del 'string-split)
(let ([dellen (##sys#size del)]
[first #f] )
(define (add from to last)
(let ([node (cons (##sys#substring str from to) '())])
(if first
(##sys#setslot last 1 node)
(set! first node) )
node) )
(let loop ([i 0] [last #f] [from 0])
(cond [(fx>= i strlen)
(when (or (fx> i from) flag) (add from i last))
(or first '()) ]
[else
(let ([c (##core#inline "C_subchar" str i)])
(let scan ([j 0])
(cond [(fx>= j dellen) (loop (fx+ i 1) last from)]
[(eq? c (##core#inline "C_subchar" del j))
(let ([i2 (fx+ i 1)])
(if (or (fx> i from) flag)
(loop i2 (add from i last) i2)
(loop i2 last i2) ) ) ]
[else (scan (fx+ j 1))] ) ) ) ] ) ) ) ) ) )
;;; Translate elements of a string:
(define string-translate
(lambda (str from . to)
(define (instring s)
(let ([len (##sys#size s)])
(lambda (c)
(let loop ([i 0])
(cond [(fx>= i len) #f]
[(eq? c (##core#inline "C_subchar" s i)) i]
[else (loop (fx+ i 1))] ) ) ) ) )
(let* ([from
(cond [(char? from) (lambda (c) (eq? c from))]
[(pair? from) (instring (list->string from))]
[else
(##sys#check-string from 'string-translate)
(instring from) ] ) ]
[to
(and (pair? to)
(let ([tx (car to )])
(cond [(char? tx) tx]
[(pair? tx) (list->string tx)]
[else
(##sys#check-string tx 'string-translate)
tx] ) ) ) ]
[tlen (and (string? to) (##sys#size to))] )
(##sys#check-string str 'string-translate)
(let* ([slen (##sys#size str)]
[str2 (make-string slen)] )
(let loop ([i 0] [j 0])
(if (fx>= i slen)
(if (fx< j i)
(##sys#substring str2 0 j)
str2)
(let* ([ci (##core#inline "C_subchar" str i)]
[found (from ci)] )
(cond [(not found)
(##core#inline "C_setsubchar" str2 j ci)
(loop (fx+ i 1) (fx+ j 1)) ]
[(not to) (loop (fx+ i 1) j)]
[(char? to)
(##core#inline "C_setsubchar" str2 j to)
(loop (fx+ i 1) (fx+ j 1)) ]
[(fx>= found tlen)
(##sys#error 'string-translate "invalid translation destination" i to) ]
[else
(##core#inline "C_setsubchar" str2 j (##core#inline "C_subchar" to found))
(loop (fx+ i 1) (fx+ j 1)) ] ) ) ) ) ) ) ) )
;;; Remove suffix
;; (define (string-chomp str #!optional (suffix "\n"))
;; (assert (and 'string-chomp (string? str)))
;; (assert (and 'string-chomp suffix))
;; (let* ((len (string-length str))
;; (slen (string-length suffix))
;; (diff (fx- len slen)) )
;; (if (and (fx>= len slen)
;; (##core#inline "C_substring_compare" str suffix diff 0 slen) )
;; (substring str 0 diff)
;; str) ) )
; (queue-push-back! queue item)
; Pushes an item into the first position of a queue.
(define (queue-push-back! q item) ; thread-safe
(##sys#check-structure q 'queue 'queue-push-back!)
(let ((newlist (cons item (##sys#slot q 1))))
(##sys#setslot q 1 newlist)
(if (eq? '() (##sys#slot q 2))
(##sys#setslot q 2 newlist))
(##sys#setislot q 3 (fx+ (##sys#slot q 3) 1))))
; (queue-push-back-list! queue item-list)
; Pushes the items in item-list back onto the queue,
; so that (car item-list) becomes the next removable item.
(define (last-pair lst0)
(do ((lst lst0 (cdr lst)))
((eq? (cdr lst) '()) lst)))
(define (queue-push-back-list! q itemlist)
(##sys#check-structure q 'queue 'queue-push-back-list!)
(##sys#check-list itemlist 'queue-push-back-list!)
(let* ((newlist (append itemlist (##sys#slot q 1)))
(newtail (if (eq? newlist '())
'()
(last-pair newlist))))
(##sys#setslot q 1 newlist)
(##sys#setslot q 2 newtail)
(##sys#setislot q 3 (fx+ (##sys#slot q 3) (##core#inline "C_i_length" itemlist)))))